From 9ed75afdf41423dcb9b6e7369ad3f04c13ffe82d Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 31 Mar 2017 10:25:24 -0500 Subject: [PATCH 0001/1998] Update README with LambdaConf presentation. --- README.md | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 94ffc2072e..07dd123645 100644 --- a/README.md +++ b/README.md @@ -102,7 +102,12 @@ conference (yes the presentation is a mal program). At Midwest.io 2015, Joel Martin gave a presentation on Mal titled "Achievement Unlocked: A Better Path to Language Learning". [Video](https://www.youtube.com/watch?v=lgyOAiRtZGw), -[Slides](http://kanaka.github.io/midwest.io.mal/). +[Slides](http://kanaka.github.io/midwest.io.mal/). More recently +Joel gave a presentation on "Make Your Own Lisp Interpreter in +10 Incremental Steps" at LambdaConf 2016: [Part +1](https://www.youtube.com/watch?v=jVhupfthTEk), [Part +2](https://www.youtube.com/watch?v=X5OQBMGpaTU), +[Slides](http://kanaka.github.io/lambdaconf/). If you are interesting in creating a mal implementation (or just interested in using mal for something), please drop by the #mal From dcccf1b26386e207a8de253c9ae348524ea52cc8 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 5 Apr 2017 22:01:41 +0200 Subject: [PATCH 0002/1998] Added livescript --- .gitignore | 1 + Makefile | 3 ++- livescript/Makefile | 16 ++++++++++++++++ livescript/package.json | 15 +++++++++++++++ livescript/run | 2 ++ livescript/step0_repl.ls | 23 +++++++++++++++++++++++ 6 files changed, 59 insertions(+), 1 deletion(-) create mode 100644 livescript/Makefile create mode 100644 livescript/package.json create mode 100755 livescript/run create mode 100644 livescript/step0_repl.ls diff --git a/.gitignore b/.gitignore index c7d90d9a16..a7f1a11bfd 100644 --- a/.gitignore +++ b/.gitignore @@ -124,3 +124,4 @@ common-lisp/*.fasl common-lisp/*.lib common-lisp/images/* common-lisp/hist/* +livescript/*.js diff --git a/Makefile b/Makefile index ab2b4fd058..1ad8c84f7c 100644 --- a/Makefile +++ b/Makefile @@ -82,7 +82,7 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ python r racket rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ - vimscript + vimscript livescript EXTENSION = .mal @@ -215,6 +215,7 @@ vb_STEP_TO_PROG = vb/$($(1)).exe vhdl_STEP_TO_PROG = vhdl/$($(1)) vimscript_STEP_TO_PROG = vimscript/$($(1)).vim guile_STEP_TO_PROG = guile/$($(1)).scm +livescript_STEP_TO_PROG = livescript/$($(1)).js # Needed some argument munging diff --git a/livescript/Makefile b/livescript/Makefile new file mode 100644 index 0000000000..cc5e7a8052 --- /dev/null +++ b/livescript/Makefile @@ -0,0 +1,16 @@ +TESTS = + +SOURCES_BASE = +SOURCES_LISP = stepA_mal.ls +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: node_modules + +node_modules: + npm install + +%.js: %.ls + lsc -d -c $(@:%.js=%.ls) + +clean: + rm -f *.js diff --git a/livescript/package.json b/livescript/package.json new file mode 100644 index 0000000000..e4325a1b5b --- /dev/null +++ b/livescript/package.json @@ -0,0 +1,15 @@ +{ + "name": "livescript", + "version": "1.0.0", + "description": "", + "main": "index.js", + "dependencies": { + "prelude-ls": "^1.1.2" + }, + "devDependencies": {}, + "scripts": { + "test": "echo \"Error: no test specified\" && exit 1" + }, + "author": "", + "license": "ISC" +} diff --git a/livescript/run b/livescript/run new file mode 100755 index 0000000000..6605303a29 --- /dev/null +++ b/livescript/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" diff --git a/livescript/step0_repl.ls b/livescript/step0_repl.ls new file mode 100644 index 0000000000..b57aa61ffa --- /dev/null +++ b/livescript/step0_repl.ls @@ -0,0 +1,23 @@ +readline = require 'readline' +{id} = require 'prelude-ls' + + +READ = id +EVAL = -> +PRINT = id +rep = (line) -> + + +rl = readline.createInterface do + input : process.stdin + output : process.stdout + prompt: 'user> ' + +rl.on 'line', (line) -> + console.log rep line + rl.prompt! + +rl.on 'close', -> + process.exit 0 + +rl.prompt! From 185052f14d0a730ba67f0187cb453c370fc7e3a7 Mon Sep 17 00:00:00 2001 From: boyned//Kampfkarren Date: Wed, 12 Apr 2017 08:22:19 -0700 Subject: [PATCH 0003/1998] Fix guide's explanation of Regex it didn't incude the parantheses --- process/guide.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/process/guide.md b/process/guide.md index fa0dec29f2..cd17969bf0 100644 --- a/process/guide.md +++ b/process/guide.md @@ -329,7 +329,7 @@ expression support. * `~@`: Captures the special two-characters `~@` (tokenized). * ```[\[\]{}()'`~^@]```: Captures any special single character, one of - ```[]{}'`~^@``` (tokenized). + ```[]{}()'`~^@``` (tokenized). * `"(?:\\.|[^\\"])*"`: Starts capturing at a double-quote and stops at the next double-quote unless it was proceeded by a backslash in which case it From 18ed1641768adafc3269d49b6c381a08a94468ec Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Fri, 5 May 2017 22:19:54 +0200 Subject: [PATCH 0004/1998] Step 0 & 1 --- livescript/Makefile | 8 +-- livescript/env | 2 + livescript/package.json | 3 +- livescript/printer.ls | 11 ++++ livescript/reader.ls | 91 ++++++++++++++++++++++++++++++++++ livescript/step0_repl.ls | 31 +++++++----- livescript/step1_read_print.ls | 17 +++++++ 7 files changed, 145 insertions(+), 18 deletions(-) create mode 100644 livescript/env create mode 100644 livescript/printer.ls create mode 100644 livescript/reader.ls create mode 100644 livescript/step1_read_print.ls diff --git a/livescript/Makefile b/livescript/Makefile index cc5e7a8052..a8da36b488 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -1,15 +1,15 @@ TESTS = -SOURCES_BASE = -SOURCES_LISP = stepA_mal.ls +SOURCES_BASE = reader.js printer.js +SOURCES_LISP = SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -all: node_modules +all: $(SOURCES) node_modules node_modules: npm install -%.js: %.ls +%.js: %.ls $(SOURCES) lsc -d -c $(@:%.js=%.ls) clean: diff --git a/livescript/env b/livescript/env new file mode 100644 index 0000000000..6c312492f1 --- /dev/null +++ b/livescript/env @@ -0,0 +1,2 @@ +test + STEP=step0_repl ./run diff --git a/livescript/package.json b/livescript/package.json index e4325a1b5b..8cb53e1afa 100644 --- a/livescript/package.json +++ b/livescript/package.json @@ -4,7 +4,8 @@ "description": "", "main": "index.js", "dependencies": { - "prelude-ls": "^1.1.2" + "prelude-ls": "^1.1.2", + "ffi": "2.0.x" }, "devDependencies": {}, "scripts": { diff --git a/livescript/printer.ls b/livescript/printer.ls new file mode 100644 index 0000000000..7328c90b3d --- /dev/null +++ b/livescript/printer.ls @@ -0,0 +1,11 @@ +{is-type, map, join} = require 'prelude-ls' + +export pr_str = (ast) -> + if is-type \Array ast + '(' + (ast |> map pr_str |> join ' ') + ')' + else + {type, value} = ast + switch type + | \int => value + | \string => value + | \symbol => value diff --git a/livescript/reader.ls b/livescript/reader.ls new file mode 100644 index 0000000000..1fd4734997 --- /dev/null +++ b/livescript/reader.ls @@ -0,0 +1,91 @@ +readline = require 'readline' +{id} = require 'prelude-ls' + +class Reader + (tokens) -> + @tokens = tokens + @pos = 0 + + # returns the token at the current position + # and increments position. + next: -> + result = @peek! + if result? then @pos += 1 + result + + # just returns the token at the current position. + peek: -> + if @pos < @tokens.length + @tokens[@pos] + + +export read_str = (str) -> + str + |> tokenizer + |> (tokens) -> new Reader tokens + |> read_form + +# This function will take a single string and return an array/list +# of all the tokens (strings) in it. +tokenizer = (str) -> + re = // + [\s,]* # whitespace or commas + ( ~@ # special two-char ~@ + | [\[\]{}()'`~^@] # special single char one of []{}'`~^@ + | "(?:\\.| [^\\"])*" # double-quoted string + | ;.* # any seq of chars starting ; + | [^\s\[\]{}('"`,;)]+ # seq of non-special chars: symbols, numbers, + ) # "true", "false" and "nil". + //y + + tokens = [] + while re.lastIndex < str.length + idx = re.lastIndex + m = re.exec str + # console.log 'at ', idx, 'matched', m + if not m + # Allow whitespace or commas at the end of the input. + break if /[\s,]+/.exec str.substring idx + throw new Error 'parse error at character ' + idx + + # Ignore comments. + tok = m[1] + if tok[1] != ';' then tokens.push tok + + tokens + +read_form = (reader) -> + if reader.peek! == '(' + read_list reader + else if reader.peek!? + read_atom reader + else + throw new Error 'parse error: expected a form' + +read_list = (reader) -> + list = [] + reader.next! # accept '(' + loop + token = reader.peek! + if not token? + throw new Error 'expected \')\', got EOF' + else if token == ')' + reader.next! + break + + list.push read_form reader + + return list + +special_chars = '[]{}\'`~^@' + +read_atom = (reader) -> + token = reader.peek! + if token[0] == '"' + {type: \string, value: reader.next!} + else if token.match /^-?\d+$/ + {type: \int, value: reader.next!} + else if token != '~@' and token not in special_chars + {type: \symbol, value: reader.next!} + else + throw new Error 'parse error: expected an atom, got ' + token diff --git a/livescript/step0_repl.ls b/livescript/step0_repl.ls index b57aa61ffa..0395fc9a23 100644 --- a/livescript/step0_repl.ls +++ b/livescript/step0_repl.ls @@ -1,23 +1,28 @@ -readline = require 'readline' +readline = require './node_readline' {id} = require 'prelude-ls' READ = id -EVAL = -> +EVAL = id PRINT = id -rep = (line) -> +rep = (line) -> PRINT EVAL READ line -rl = readline.createInterface do - input : process.stdin - output : process.stdout - prompt: 'user> ' +loop + line = readline.readline 'user> ' + break if not line? or line == '' + console.log rep line -rl.on 'line', (line) -> - console.log rep line - rl.prompt! +# rl = readline.createInterface do +# input : process.stdin +# output : process.stdout +# prompt: 'user> ' -rl.on 'close', -> - process.exit 0 +# rl.prompt! -rl.prompt! +# rl.on 'line', (line) -> +# console.log rep line +# rl.prompt! + +# rl.on 'close', -> +# process.exit 0 diff --git a/livescript/step1_read_print.ls b/livescript/step1_read_print.ls new file mode 100644 index 0000000000..cd1ca0225f --- /dev/null +++ b/livescript/step1_read_print.ls @@ -0,0 +1,17 @@ +readline = require './node_readline' +{id} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' + + +EVAL = id + +rep = (line) -> pr_str EVAL read_str line + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.log message From cb86911fac1ecbc589d83a87a6413e7bfd7fba9f Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Fri, 5 May 2017 23:02:54 +0200 Subject: [PATCH 0005/1998] Step 2 --- livescript/Makefile | 2 +- livescript/printer.ls | 18 +++++++------- livescript/reader.ls | 23 +++++++++++------- livescript/step2_eval.ls | 51 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 76 insertions(+), 18 deletions(-) create mode 100644 livescript/step2_eval.ls diff --git a/livescript/Makefile b/livescript/Makefile index a8da36b488..0b5cacda3c 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -1,7 +1,7 @@ TESTS = SOURCES_BASE = reader.js printer.js -SOURCES_LISP = +SOURCES_LISP = SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) all: $(SOURCES) node_modules diff --git a/livescript/printer.ls b/livescript/printer.ls index 7328c90b3d..0286c39397 100644 --- a/livescript/printer.ls +++ b/livescript/printer.ls @@ -1,11 +1,11 @@ {is-type, map, join} = require 'prelude-ls' -export pr_str = (ast) -> - if is-type \Array ast - '(' + (ast |> map pr_str |> join ' ') + ')' - else - {type, value} = ast - switch type - | \int => value - | \string => value - | \symbol => value +pr_list = (list) -> list |> map pr_str |> join ' ' + +export pr_str = ({type, value}: ast) -> + switch type + | \int => value + | \string => value + | \symbol => value + | \list => '(' + (pr_list value) + ')' + | \vector => '[' + (pr_list value) + ']' diff --git a/livescript/reader.ls b/livescript/reader.ls index 1fd4734997..8ee4e08f0b 100644 --- a/livescript/reader.ls +++ b/livescript/reader.ls @@ -23,7 +23,12 @@ export read_str = (str) -> str |> tokenizer |> (tokens) -> new Reader tokens - |> read_form + |> (reader) -> + result = read_form reader + if reader.peek! + throw new Error "expected EOF, got #{reader.peek!}" + result + # This function will take a single string and return an array/list # of all the tokens (strings) in it. @@ -56,26 +61,28 @@ tokenizer = (str) -> read_form = (reader) -> if reader.peek! == '(' - read_list reader + read_list reader, ')' + else if reader.peek! == '[' + read_list reader, ']' else if reader.peek!? read_atom reader else throw new Error 'parse error: expected a form' -read_list = (reader) -> +read_list = (reader, end) -> list = [] - reader.next! # accept '(' + reader.next! # accept '(' or '[' loop token = reader.peek! if not token? - throw new Error 'expected \')\', got EOF' - else if token == ')' + throw new Error "expected '#{end}', got EOF" + else if token == end reader.next! break list.push read_form reader - return list + return {type: if end == ')' then \list else \vector, value: list} special_chars = '[]{}\'`~^@' @@ -84,7 +91,7 @@ read_atom = (reader) -> if token[0] == '"' {type: \string, value: reader.next!} else if token.match /^-?\d+$/ - {type: \int, value: reader.next!} + {type: \int, value: parseInt reader.next!} else if token != '~@' and token not in special_chars {type: \symbol, value: reader.next!} else diff --git a/livescript/step2_eval.ls b/livescript/step2_eval.ls new file mode 100644 index 0000000000..d74fad639c --- /dev/null +++ b/livescript/step2_eval.ls @@ -0,0 +1,51 @@ +readline = require './node_readline' +{id, map} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' + +repl_env = do + '+': + type: \function + value: (a, b) -> {type: \int, value: a.value + b.value} + '-': + type: \function + value: (a, b) -> {type: \int, value: a.value - b.value} + '*': + type: \function + value: (a, b) -> {type: \int, value: a.value * b.value} + '/': + type: \function + value: (a, b) -> {type: \int, value: parseInt(a.value / b.value)} + +eval_ast = (repl_env, {type, value}: ast) --> + switch type + | \symbol => + result = repl_env[value] + if not result? then throw new Error 'symbol not found: ', value + result + | \list, \vector => + result = value |> map eval_ast repl_env + if type == \list and result.length != 0 + fn = result[0] + if fn.type != \function + throw new Error fn.value, ' is not a function' + fn.value.apply repl_env, result.slice 1 + else + {type: type, value: result} + | otherwise => + ast + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> pr_str + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From a9c0e8ba8de4ea13fd92d6634e936d129f626a49 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 6 May 2017 15:48:44 +0200 Subject: [PATCH 0006/1998] Step 3 --- livescript/Makefile | 2 +- livescript/env | 2 - livescript/env.ls | 16 ++++++ livescript/step3_env.ls | 115 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 132 insertions(+), 3 deletions(-) delete mode 100644 livescript/env create mode 100644 livescript/env.ls create mode 100644 livescript/step3_env.ls diff --git a/livescript/Makefile b/livescript/Makefile index 0b5cacda3c..064a52daa3 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -1,6 +1,6 @@ TESTS = -SOURCES_BASE = reader.js printer.js +SOURCES_BASE = reader.js printer.js env.js SOURCES_LISP = SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) diff --git a/livescript/env b/livescript/env deleted file mode 100644 index 6c312492f1..0000000000 --- a/livescript/env +++ /dev/null @@ -1,2 +0,0 @@ -test - STEP=step0_repl ./run diff --git a/livescript/env.ls b/livescript/env.ls new file mode 100644 index 0000000000..46adbe2ab7 --- /dev/null +++ b/livescript/env.ls @@ -0,0 +1,16 @@ +export class Env + (outer = null, data = {}) -> + @outer = outer + @data = data + + set: (symbol, ast) -> + @data[symbol] = ast + + find: (symbol) -> + if symbol of @data then @ + else if @outer? then @outer.find symbol + + get: (symbol) -> + env = @find symbol + if env then env.data[symbol] + else throw new Error "symbol not found: #{symbol}" diff --git a/livescript/step3_env.ls b/livescript/step3_env.ls new file mode 100644 index 0000000000..9a493ef2fb --- /dev/null +++ b/livescript/step3_env.ls @@ -0,0 +1,115 @@ +readline = require './node_readline' +{id, map, each} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' + +repl_env = new Env null, do + '+': + type: \function + value: (a, b) -> {type: \int, value: a.value + b.value} + '-': + type: \function + value: (a, b) -> {type: \int, value: a.value - b.value} + '*': + type: \function + value: (a, b) -> {type: \int, value: a.value * b.value} + '/': + type: \function + value: (a, b) -> {type: \int, value: parseInt(a.value / b.value)} + + +is-symbol = ({type, value}: ast, name) -> + type == \symbol and value == name + + +list-to-pairs = (list) -> + [0 to (list.length - 2) by 2] \ + |> map (idx) -> [list[idx], list[idx+1]] + + +eval_ast = (env, {type, value}: ast) --> + switch type + | \symbol => env.get value + | \vector => do + type: \vector + value: value |> map eval_ast env + + | \list => + # Empty list, return empty list. + if value.length == 0 + ast + + # Symbol definition. + else if is-symbol value[0], 'def!' + if value.length != 3 + throw new Error "def! expected 2 parameters, + got #{value.length - 1}" + + # Name is in the first parameter, and is not evaluated. + name = value[1] + if name.type != \symbol + throw new Error "expected a symbol + for the first parameter of def!, + got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, value[2]) + + # Create a new environment. + else if is-symbol value[0], 'let*' + if value.length != 3 + throw new Error "let* expected 2 parameters, + got #{value.length - 1}" + + binding_list = value[1] + if binding_list.type not in [\list \vector] + throw new Error "expected 1st parameter of let* to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + throw new Error "binding list of let* must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + throw new Error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Evaluate the 'body' of let* with the new environment. + eval_ast let_env, value[2] + else + [fn, ...args] = value |> map eval_ast env + if fn.type != \function + throw new Error fn.value, ' is not a function' + fn.value.apply env, args + + | otherwise => + ast + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> pr_str + + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From 3181c695486bb83b7e559b68cde5ac48a6bf3c9d Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Mon, 8 May 2017 21:31:26 +0200 Subject: [PATCH 0007/1998] Step 4 --- livescript/Makefile | 2 +- livescript/core.ls | 69 ++++++++++++++ livescript/printer.ls | 4 +- livescript/reader.ls | 6 +- livescript/step3_env.ls | 139 ++++++++++++++------------- livescript/step4_if_fn_do.ls | 177 +++++++++++++++++++++++++++++++++++ 6 files changed, 329 insertions(+), 68 deletions(-) create mode 100644 livescript/core.ls create mode 100644 livescript/step4_if_fn_do.ls diff --git a/livescript/Makefile b/livescript/Makefile index 064a52daa3..b80d940136 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -1,6 +1,6 @@ TESTS = -SOURCES_BASE = reader.js printer.js env.js +SOURCES_BASE = reader.js printer.js env.js core.js SOURCES_LISP = SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) diff --git a/livescript/core.ls b/livescript/core.ls new file mode 100644 index 0000000000..2f952f9b83 --- /dev/null +++ b/livescript/core.ls @@ -0,0 +1,69 @@ +{zip, map, apply, and-list, join} = require 'prelude-ls' +{pr_str} = require './printer' + + +export runtime-error = (msg) -> throw new Error msg + + +fn = (body) -> {type: \function, value: body} +const-nil = {type: \const, value: \nil} +const-int = (int) -> {type: \int, value: int} +const-bool = (bool) -> {type: \const, value: if bool then \true else \false} +const-str = (str) -> {type: \string, value: str} + +list-or-vector = ({type}) -> type in [\list \vector] + +deep-equals = (a, b) -> + if not list-or-vector a then + if a.type != b.type then false + else a.value == b.value + else if list-or-vector b then + if a.value.length != b.value.length then false + else + # Compare all elements of a and b with deep-equals. + zip a.value, b.value + |> map (apply deep-equals) + |> and-list # all must be true (equals) + else false + + +export ns = do + '+': fn (a, b) -> const-int a.value + b.value + '-': fn (a, b) -> const-int a.value - b.value + '*': fn (a, b) -> const-int a.value * b.value + '/': fn (a, b) -> const-int parseInt (a.value / b.value) + + 'list': fn (...list) -> {type: \list, value: list} + 'list?': fn (param) -> const-bool param.type == \list + + 'empty?': fn (param) -> + if not list-or-vector param + runtime-error "'empty?' expected first parameter + to be of type list or vector, + got a #{param.type}." + + const-bool param.value.length == 0 + + 'count': fn (param) -> + if not list-or-vector param + runtime-error "'count' expected first parameter + to be of type list or vector, + got a #{param.type}." + + const-int param.value.length + + 'prn': fn (param) -> + if param + console.log pr_str param + + const-nil + + '=': fn (a, b) -> const-bool (deep-equals a, b) + '<': fn (a, b) -> const-bool a.value < b.value + '>': fn (a, b) -> const-bool a.value > b.value + '<=': fn (a, b) -> const-bool a.value <= b.value + '>=': fn (a, b) -> const-bool a.value >= b.value + + 'not': fn (a) -> const-bool (a.type == \const and a.value == \false) + + 'str': fn (...params) -> const-str (params |> map pr_str |> join '') \ No newline at end of file diff --git a/livescript/printer.ls b/livescript/printer.ls index 0286c39397..f4c8d5138a 100644 --- a/livescript/printer.ls +++ b/livescript/printer.ls @@ -4,8 +4,10 @@ pr_list = (list) -> list |> map pr_str |> join ' ' export pr_str = ({type, value}: ast) -> switch type + | \const => value | \int => value - | \string => value + | \string => value # TODO encode string | \symbol => value | \list => '(' + (pr_list value) + ')' | \vector => '[' + (pr_list value) + ']' + | \function => '#' diff --git a/livescript/reader.ls b/livescript/reader.ls index 8ee4e08f0b..4b01a4b3f8 100644 --- a/livescript/reader.ls +++ b/livescript/reader.ls @@ -85,10 +85,14 @@ read_list = (reader, end) -> return {type: if end == ')' then \list else \vector, value: list} special_chars = '[]{}\'`~^@' +constants = [\true \false \nil] read_atom = (reader) -> token = reader.peek! - if token[0] == '"' + if token in constants + {type: \const, value: reader.next!} + else if token[0] == '"' + # TODO decode string {type: \string, value: reader.next!} else if token.match /^-?\d+$/ {type: \int, value: parseInt reader.next!} diff --git a/livescript/step3_env.ls b/livescript/step3_env.ls index 9a493ef2fb..3c7dfc5cb8 100644 --- a/livescript/step3_env.ls +++ b/livescript/step3_env.ls @@ -28,75 +28,84 @@ list-to-pairs = (list) -> |> map (idx) -> [list[idx], list[idx+1]] -eval_ast = (env, {type, value}: ast) --> +eval_simple = (env, {type, value}: ast) -> switch type | \symbol => env.get value - | \vector => do - type: \vector + | \list, \vector => do + type: type value: value |> map eval_ast env + | otherwise => ast + - | \list => - # Empty list, return empty list. - if value.length == 0 - ast - - # Symbol definition. - else if is-symbol value[0], 'def!' - if value.length != 3 - throw new Error "def! expected 2 parameters, - got #{value.length - 1}" - - # Name is in the first parameter, and is not evaluated. - name = value[1] - if name.type != \symbol - throw new Error "expected a symbol - for the first parameter of def!, - got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, value[2]) - - # Create a new environment. - else if is-symbol value[0], 'let*' - if value.length != 3 - throw new Error "let* expected 2 parameters, - got #{value.length - 1}" - - binding_list = value[1] - if binding_list.type not in [\list \vector] - throw new Error "expected 1st parameter of let* to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - throw new Error "binding list of let* must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - throw new Error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Evaluate the 'body' of let* with the new environment. - eval_ast let_env, value[2] - else - [fn, ...args] = value |> map eval_ast env - if fn.type != \function - throw new Error fn.value, ' is not a function' - fn.value.apply env, args - - | otherwise => - ast +eval_ast = (env, {type, value}: ast) --> + if type != \list then eval_simple env, ast + else if value.length == 0 then ast + else if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + +check_params = (name, params, expected) -> + if params.length != expected + throw new Error "#{name} expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + throw new Error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + throw new Error "expected 1st parameter of let* to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + throw new Error "binding list of let* must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + throw new Error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Evaluate the 'body' of let* with the new environment. + eval_ast let_env, params[1] + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + throw new Error fn.value, ' is not a function' + fn.value.apply env, args rep = (line) -> diff --git a/livescript/step4_if_fn_do.ls b/livescript/step4_if_fn_do.ls new file mode 100644 index 0000000000..52488564e3 --- /dev/null +++ b/livescript/step4_if_fn_do.ls @@ -0,0 +1,177 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +list-to-pairs = (list) -> + [0 to (list.length - 2) by 2] \ + |> map (idx) -> [list[idx], list[idx+1]] + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => do + type: type + value: value |> map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + if type != \list then eval_simple env, ast + else if value.length == 0 then ast + else if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Evaluate the 'body' of let* with the new environment. + eval_ast let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + params |> map eval_ast env |> last + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + eval_ast env, params[1] + else if params.length > 2 + eval_ast env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + # TODO also support (& args) + # and (a & args) + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + for [name, value] in (zip binds, values) + fn_env.set name, value + + # Evaluate the function body with the new environment. + eval_ast fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function" + + fn.value.apply env, args + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> pr_str + + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From 2ff2d84b40526c21f1f58f95d6bc4ddc5142f78d Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 10 May 2017 17:57:31 +0200 Subject: [PATCH 0008/1998] Deferrables until step 4 --- livescript/Makefile | 2 +- livescript/core.ls | 77 +++++++++++++------- livescript/printer.ls | 54 +++++++++++--- livescript/reader.ls | 129 +++++++++++++++++++++++++++------ livescript/step1_read_print.ls | 7 +- livescript/step2_eval.ls | 4 +- livescript/step4_if_fn_do.ls | 41 ++++++++--- livescript/utils.ls | 6 ++ 8 files changed, 245 insertions(+), 75 deletions(-) create mode 100644 livescript/utils.ls diff --git a/livescript/Makefile b/livescript/Makefile index b80d940136..62b91c1bb2 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -1,6 +1,6 @@ TESTS = -SOURCES_BASE = reader.js printer.js env.js core.js +SOURCES_BASE = reader.js printer.js env.js core.js utils.js SOURCES_LISP = SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) diff --git a/livescript/core.ls b/livescript/core.ls index 2f952f9b83..433b6311e2 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -1,4 +1,4 @@ -{zip, map, apply, and-list, join} = require 'prelude-ls' +{zip, map, apply, and-list, join, Obj} = require 'prelude-ls' {pr_str} = require './printer' @@ -6,7 +6,7 @@ export runtime-error = (msg) -> throw new Error msg fn = (body) -> {type: \function, value: body} -const-nil = {type: \const, value: \nil} +const-nil = -> {type: \const, value: \nil} const-int = (int) -> {type: \int, value: int} const-bool = (bool) -> {type: \const, value: if bool then \true else \false} const-str = (str) -> {type: \string, value: str} @@ -36,27 +36,31 @@ export ns = do 'list': fn (...list) -> {type: \list, value: list} 'list?': fn (param) -> const-bool param.type == \list - 'empty?': fn (param) -> - if not list-or-vector param - runtime-error "'empty?' expected first parameter - to be of type list or vector, - got a #{param.type}." - - const-bool param.value.length == 0 - - 'count': fn (param) -> - if not list-or-vector param - runtime-error "'count' expected first parameter - to be of type list or vector, - got a #{param.type}." - - const-int param.value.length - - 'prn': fn (param) -> - if param - console.log pr_str param - - const-nil + 'empty?': fn ({type, value}) -> + switch type + | \const => + if value == \nil + then const-bool true + else runtime-error "'empty?' is not supported on #{value}" + | \list, \vector => + const-bool value.length == 0 + | \map => + const-bool Obj.empty value + | otherwise => + runtime-error "'empty?' is not supported on type #{type}" + + 'count': fn ({type, value}) -> + switch type + | \const => + if value == \nil + then const-int 0 + else runtime-error "'count' is not supported on #{value}" + | \list, \vector => + const-int value.length + | \map => + value |> Obj.keys |> (.length) |> const-int + | otherwise => + runtime-error "'count' is not supported on type #{type}" '=': fn (a, b) -> const-bool (deep-equals a, b) '<': fn (a, b) -> const-bool a.value < b.value @@ -64,6 +68,27 @@ export ns = do '<=': fn (a, b) -> const-bool a.value <= b.value '>=': fn (a, b) -> const-bool a.value >= b.value - 'not': fn (a) -> const-bool (a.type == \const and a.value == \false) - - 'str': fn (...params) -> const-str (params |> map pr_str |> join '') \ No newline at end of file + 'not': fn ({type, value}) -> + const-bool (type == \const and value == \false) + + 'pr-str': fn (...params) -> + params |> map (p) -> pr_str p, print_readably=true + |> join ' ' + |> const-str + + 'str': fn (...params) -> + params |> map (p) -> pr_str p, print_readably=false + |> join '' + |> const-str + + 'prn': fn (...params) -> + params |> map (p) -> pr_str p, print_readably=true + |> join ' ' + |> console.log + |> const-nil + + 'println': fn (...params) -> + params |> map (p) -> pr_str p, print_readbly=false + |> join ' ' + |> console.log + |> const-nil diff --git a/livescript/printer.ls b/livescript/printer.ls index f4c8d5138a..05277af4dc 100644 --- a/livescript/printer.ls +++ b/livescript/printer.ls @@ -1,13 +1,49 @@ -{is-type, map, join} = require 'prelude-ls' +{is-type, map, join, obj-to-pairs} = require 'prelude-ls' +{keyword-prefix} = require './reader' -pr_list = (list) -> list |> map pr_str |> join ' ' -export pr_str = ({type, value}: ast) -> +export pr_str = ({type, value}: ast, print_readably=true) -> switch type - | \const => value - | \int => value - | \string => value # TODO encode string - | \symbol => value - | \list => '(' + (pr_list value) + ')' - | \vector => '[' + (pr_list value) + ']' + | \const => value + | \int => value + | \string => + if print_readably + then encode-string value + else value + | \symbol => value + | \keyword => value + | \list => '(' + (pr_list value, print_readably) + ')' + | \vector => '[' + (pr_list value, print_readably) + ']' + | \map => '{' + (pr_map value, print_readably) + '}' | \function => '#' + + +encode-string = (str) -> + str |> (.replace /[\n\"\\]/g, + (ch) -> switch ch + | '\n' => '\\n' + | '"' => '\\"' + | '\\' => '\\\\') + |> (enc) -> "\"#{enc}\"" + + +pr_list = (list, print_readably) -> + list |> map (ast) -> pr_str ast, print_readably + |> join ' ' + + +pr_map_key = (key, print_readably) -> + if key.startsWith keyword-prefix + key.substring 1 + else if print_readably + encode-string key + else + key + +pr_map = (obj, print_readably) -> + obj |> obj-to-pairs + |> map ([key, value]) -> + key_str = pr_map_key key, print_readably + value_str = pr_str value, print_readably + key_str + ' ' + value_str + |> join ' ' diff --git a/livescript/reader.ls b/livescript/reader.ls index 4b01a4b3f8..dfde5762c0 100644 --- a/livescript/reader.ls +++ b/livescript/reader.ls @@ -1,5 +1,10 @@ readline = require 'readline' -{id} = require 'prelude-ls' +{id, map, pairs-to-obj} = require 'prelude-ls' +{list-to-pairs} = require './utils' + +export class OnlyComment + +parse-error = (msg) -> throw new Error msg class Reader (tokens) -> @@ -19,14 +24,26 @@ class Reader @tokens[@pos] +accept-comment = (reader) -> + token = reader.peek! + if token? and token.startsWith ';' + throw new OnlyComment + + +eof-or-comment = (reader) -> + token = reader.peek! + if token? and not token.startsWith ';' + then parse-error "expected EOF, got '#{token}'" + + export read_str = (str) -> str |> tokenizer |> (tokens) -> new Reader tokens |> (reader) -> + accept-comment reader result = read_form reader - if reader.peek! - throw new Error "expected EOF, got #{reader.peek!}" + eof-or-comment reader result @@ -51,52 +68,118 @@ tokenizer = (str) -> if not m # Allow whitespace or commas at the end of the input. break if /[\s,]+/.exec str.substring idx - throw new Error 'parse error at character ' + idx + parse-error "parse error at character #{idx}" - # Ignore comments. - tok = m[1] - if tok[1] != ';' then tokens.push tok + tokens.push m[1] tokens read_form = (reader) -> - if reader.peek! == '(' - read_list reader, ')' - else if reader.peek! == '[' - read_list reader, ']' - else if reader.peek!? - read_atom reader - else - throw new Error 'parse error: expected a form' + switch reader.peek! + | '(' => read_list reader, ')' + | '[' => read_list reader, ']' + | '{' => read_list reader, '}' + | '\'' => read-macro 'quote', reader + | '\`' => read-macro 'quasiquote', reader + | '~' => read-macro 'unquote', reader + | '~@' => read-macro 'splice-unquote', reader + | '@' => read-macro 'deref', reader # todo only symbol? + | '^' => read-with-meta reader + | otherwise => + if that? then read_atom reader + else parse-error 'expected a form, got EOF' + read_list = (reader, end) -> list = [] - reader.next! # accept '(' or '[' + reader.next! # accept '(', '[' or '{' loop token = reader.peek! if not token? - throw new Error "expected '#{end}', got EOF" + parse-error "expected '#{end}', got EOF" else if token == end reader.next! break list.push read_form reader - - return {type: if end == ')' then \list else \vector, value: list} + + switch end + | ')' => {type: \list, value: list} + | ']' => {type: \vector, value: list} + | '}' => list-to-map list + special_chars = '[]{}\'`~^@' constants = [\true \false \nil] + read_atom = (reader) -> token = reader.peek! if token in constants {type: \const, value: reader.next!} else if token[0] == '"' - # TODO decode string - {type: \string, value: reader.next!} + {type: \string, value: decode-string reader.next!} else if token.match /^-?\d+$/ {type: \int, value: parseInt reader.next!} else if token != '~@' and token not in special_chars - {type: \symbol, value: reader.next!} + if token.startsWith ':' + {type: \keyword, value: reader.next!} + else + {type: \symbol, value: reader.next!} else - throw new Error 'parse error: expected an atom, got ' + token + parse-error "expected an atom, got #{token}" + + +decode-string = (str) -> + str |> (.slice 1, -1) + |> (.replace /\\[\"\\n]/g, + (esc) -> switch esc + | '\\n' => '\n' + | '\\"' => '"' + | '\\\\' => '\\') + + +export keyword-prefix = '\u029e' + + +list-to-map = (list) -> + if list.length % 2 != 0 + parse-error "map should have an even number + of elements, got #{list.length}" + + list-to-pairs list + |> map ([key, value]) -> + switch key.type + | \string => [key.value, value] + | \keyword => [keyword-prefix + key.value, value] + | otherwise => + parse-error "map can only have strings or keywords as keys, + got a #{key.type}" + |> pairs-to-obj + |> (obj) -> {type: \map, value: obj} + + +read-macro = (symbol, reader) -> + reader.next! # accept macro start token + + do + type: \list + value: + * {type: \symbol, value: symbol} + * read_form reader + + +read-with-meta = (reader) -> + reader.next! # accept ^ + if reader.peek! != '{' + parse-error "expected a map after with-meta reader macro '^'" + + meta = read_list reader, '}' + form = read_form reader + + do + type: \list + value: + * {type: \symbol, value: 'with-meta'} + * form + * meta diff --git a/livescript/step1_read_print.ls b/livescript/step1_read_print.ls index cd1ca0225f..1c15955a16 100644 --- a/livescript/step1_read_print.ls +++ b/livescript/step1_read_print.ls @@ -1,6 +1,6 @@ readline = require './node_readline' {id} = require 'prelude-ls' -{read_str} = require './reader' +{read_str, OnlyComment} = require './reader' {pr_str} = require './printer' @@ -13,5 +13,6 @@ loop break if not line? or line == '' try console.log rep line - catch {message} - console.log message + catch {message}: ex + if ex not instanceof OnlyComment + console.log message diff --git a/livescript/step2_eval.ls b/livescript/step2_eval.ls index d74fad639c..aa4124da97 100644 --- a/livescript/step2_eval.ls +++ b/livescript/step2_eval.ls @@ -1,5 +1,5 @@ readline = require './node_readline' -{id, map} = require 'prelude-ls' +{id, map, Obj} = require 'prelude-ls' {read_str} = require './reader' {pr_str} = require './printer' @@ -32,6 +32,8 @@ eval_ast = (repl_env, {type, value}: ast) --> fn.value.apply repl_env, result.slice 1 else {type: type, value: result} + | \map => + {type: \map, value: value |> Obj.map eval_ast repl_env} | otherwise => ast diff --git a/livescript/step4_if_fn_do.ls b/livescript/step4_if_fn_do.ls index 52488564e3..e368ff2e42 100644 --- a/livescript/step4_if_fn_do.ls +++ b/livescript/step4_if_fn_do.ls @@ -1,26 +1,25 @@ readline = require './node_readline' -{id, map, each, last, all, unique, zip} = require 'prelude-ls' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' {read_str} = require './reader' {pr_str} = require './printer' {Env} = require './env' {runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' is-thruthy = ({type, value}) -> type != \const or value not in [\nil \false] -list-to-pairs = (list) -> - [0 to (list.length - 2) by 2] \ - |> map (idx) -> [list[idx], list[idx+1]] +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} eval_simple = (env, {type, value}: ast) -> switch type | \symbol => env.get value - | \list, \vector => do - type: type - value: value |> map eval_ast env + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env | otherwise => ast @@ -119,13 +118,21 @@ eval_fn = (env, params) -> if params[0].type not in [\list \vector] runtime-error "'fn*' expected first parameter to be a list or vector." - # TODO also support (& args) - # and (a & args) - if not all (.type == \symbol), params[0].value runtime-error "'fn*' expected only symbols in the parameters list." binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." if (unique binds).length != binds.length runtime-error "'fn*' duplicate symbols in parameters list." @@ -133,15 +140,25 @@ eval_fn = (env, params) -> body = params[1] fn_instance = (...values) -> - if values.length != binds.length + if not vargs and values.length != binds.length runtime-error "function expected #{binds.length} parameters, got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" # Set binds to values in the new env. fn_env = new Env env + for [name, value] in (zip binds, values) fn_env.set name, value + if vargs + fn_env.set vargs, do + type: \list + value: values.slice binds.length + # Evaluate the function body with the new environment. eval_ast fn_env, body @@ -165,7 +182,7 @@ rep = (line) -> line |> read_str |> eval_ast repl_env - |> pr_str + |> (ast) -> pr_str ast, print_readably=true loop diff --git a/livescript/utils.ls b/livescript/utils.ls new file mode 100644 index 0000000000..21d1ac3c22 --- /dev/null +++ b/livescript/utils.ls @@ -0,0 +1,6 @@ +{map} = require 'prelude-ls' + + +export list-to-pairs = (list) -> + [0 to (list.length - 2) by 2] \ + |> map (idx) -> [list[idx], list[idx+1]] From 3b88488d82459d0dffd5a96486d2e67aae0b64b8 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 10 May 2017 21:27:23 +0200 Subject: [PATCH 0009/1998] Step 5 --- livescript/step5_tco.ls | 212 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 212 insertions(+) create mode 100644 livescript/step5_tco.ls diff --git a/livescript/step5_tco.ls b/livescript/step5_tco.ls new file mode 100644 index 0000000000..04be185498 --- /dev/null +++ b/livescript/step5_tco.ls @@ -0,0 +1,212 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + loop + if type != \list + return eval_simple env, ast + else if value.length == 0 + return ast + + result = if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + if result.type == \tco + env = result.env + {type, value}: ast = result.ast + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, do + type: \list + value: values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function" + + fn.value.apply env, args + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From 25bb14c94ab0ac8393303cac51bd7448338728ae Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Thu, 11 May 2017 21:37:12 +0200 Subject: [PATCH 0010/1998] Step 6 --- livescript/core.ls | 40 +++++++ livescript/error.ls | 0 livescript/printer.ls | 1 + livescript/reader.ls | 14 +-- livescript/step6_file.ls | 241 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 286 insertions(+), 10 deletions(-) create mode 100644 livescript/error.ls create mode 100644 livescript/step6_file.ls diff --git a/livescript/core.ls b/livescript/core.ls index 433b6311e2..d02b1f2bb3 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -1,5 +1,7 @@ {zip, map, apply, and-list, join, Obj} = require 'prelude-ls' {pr_str} = require './printer' +{read_str} = require './reader' +fs = require 'fs' export runtime-error = (msg) -> throw new Error msg @@ -27,6 +29,11 @@ deep-equals = (a, b) -> else false +check-type = (name, required-type, given-type) -> + if required-type != given-type + runtime-error "'#{name}' is not supported on #{given-type}" + + export ns = do '+': fn (a, b) -> const-int a.value + b.value '-': fn (a, b) -> const-int a.value - b.value @@ -92,3 +99,36 @@ export ns = do |> join ' ' |> console.log |> const-nil + + 'read-string': fn ({type, value}) -> + check-type 'read-string', \string, type + read_str value + + 'slurp': fn (filename) -> + if filename.type != \string + runtime-error "'slurp' expected the first parameter + to be a string, got a #{filename.type}" + + const-str <| fs.readFileSync filename.value, 'utf8' + + 'atom': fn (value) -> {type: \atom, value: value} + 'atom?': fn (atom) -> const-bool atom.type == \atom + 'deref': fn (atom) -> + check-type 'deref', \atom, atom.type + atom.value + + 'reset!': fn (atom, value) -> + check-type 'reset!', \atom, atom.type + atom.value = value + + 'swap!': fn (atom, fn, ...args) -> + check-type 'swap!', \atom, atom.type + if fn.type != \function + runtime-error "'swap!' expected the second parameter + to be a function, got a #{fn.type}" + + atom.value = fn.value.apply @, [atom.value] ++ args + if atom.value.type == \tco # TODO make this a method. + atom.value = atom.value.eval! + + atom.value diff --git a/livescript/error.ls b/livescript/error.ls new file mode 100644 index 0000000000..e69de29bb2 diff --git a/livescript/printer.ls b/livescript/printer.ls index 05277af4dc..f02fc429a9 100644 --- a/livescript/printer.ls +++ b/livescript/printer.ls @@ -16,6 +16,7 @@ export pr_str = ({type, value}: ast, print_readably=true) -> | \vector => '[' + (pr_list value, print_readably) + ']' | \map => '{' + (pr_map value, print_readably) + '}' | \function => '#' + | \atom => '(atom ' + (pr_str value) + ')' encode-string = (str) -> diff --git a/livescript/reader.ls b/livescript/reader.ls index dfde5762c0..1397283356 100644 --- a/livescript/reader.ls +++ b/livescript/reader.ls @@ -24,12 +24,6 @@ class Reader @tokens[@pos] -accept-comment = (reader) -> - token = reader.peek! - if token? and token.startsWith ';' - throw new OnlyComment - - eof-or-comment = (reader) -> token = reader.peek! if token? and not token.startsWith ';' @@ -41,9 +35,8 @@ export read_str = (str) -> |> tokenizer |> (tokens) -> new Reader tokens |> (reader) -> - accept-comment reader result = read_form reader - eof-or-comment reader + if token? then parse-error "expected EOF, got '#{token}'" result @@ -64,13 +57,14 @@ tokenizer = (str) -> while re.lastIndex < str.length idx = re.lastIndex m = re.exec str - # console.log 'at ', idx, 'matched', m if not m # Allow whitespace or commas at the end of the input. break if /[\s,]+/.exec str.substring idx parse-error "parse error at character #{idx}" - tokens.push m[1] + tok = m[1] + # Ignore comments. + if tok[0] != ';' then tokens.push m[1] tokens diff --git a/livescript/step6_file.ls b/livescript/step6_file.ls new file mode 100644 index 0000000000..1844ebe80f --- /dev/null +++ b/livescript/step6_file.ls @@ -0,0 +1,241 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + loop + if type != \list + return eval_simple env, ast + else if value.length == 0 + return ast + + result = if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + if result.type == \tco + env = result.env + {type, value}: ast = result.ast + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, do + type: \list + value: values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function" + + fn.value.apply env, args + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) ")")))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From a650ae5b9c9176ec320e3b3d51c3e2612777329d Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Thu, 11 May 2017 22:46:47 +0200 Subject: [PATCH 0011/1998] Step 7 --- livescript/core.ls | 33 +++-- livescript/step7_quote.ls | 282 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 307 insertions(+), 8 deletions(-) create mode 100644 livescript/step7_quote.ls diff --git a/livescript/core.ls b/livescript/core.ls index d02b1f2bb3..18b9c9e4b5 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -1,4 +1,4 @@ -{zip, map, apply, and-list, join, Obj} = require 'prelude-ls' +{zip, map, apply, and-list, join, Obj, concat, all} = require 'prelude-ls' {pr_str} = require './printer' {read_str} = require './reader' fs = require 'fs' @@ -29,9 +29,14 @@ deep-equals = (a, b) -> else false -check-type = (name, required-type, given-type) -> - if required-type != given-type - runtime-error "'#{name}' is not supported on #{given-type}" +check-param = (name, idx, test, expected, actual) -> + if not test + runtime-error "'#{name}' expected parameter #{idx} + to be #{expected}, got #{actual}" + + +check-type = (name, idx, expected, actual) -> + check-param name, idx, expected == actual, expected, actual export ns = do @@ -101,7 +106,7 @@ export ns = do |> const-nil 'read-string': fn ({type, value}) -> - check-type 'read-string', \string, type + check-type 'read-string', 0, \string, type read_str value 'slurp': fn (filename) -> @@ -114,15 +119,15 @@ export ns = do 'atom': fn (value) -> {type: \atom, value: value} 'atom?': fn (atom) -> const-bool atom.type == \atom 'deref': fn (atom) -> - check-type 'deref', \atom, atom.type + check-type 'deref', 0, \atom, atom.type atom.value 'reset!': fn (atom, value) -> - check-type 'reset!', \atom, atom.type + check-type 'reset!', 0, \atom, atom.type atom.value = value 'swap!': fn (atom, fn, ...args) -> - check-type 'swap!', \atom, atom.type + check-type 'swap!', 0, \atom, atom.type if fn.type != \function runtime-error "'swap!' expected the second parameter to be a function, got a #{fn.type}" @@ -132,3 +137,15 @@ export ns = do atom.value = atom.value.eval! atom.value + + 'cons': fn (value, list) -> + check-param 'cons', 1, (list-or-vector list), + 'list or vector', list.type + + {type: \list, value: [value] ++ list.value} + + 'concat': fn (...params) -> + if not all list-or-vector, params + runtime-error "'concat' expected all parameters to be a list or vector" + + {type: \list, value: params |> map (.value) |> concat} diff --git a/livescript/step7_quote.ls b/livescript/step7_quote.ls new file mode 100644 index 0000000000..16e1283614 --- /dev/null +++ b/livescript/step7_quote.ls @@ -0,0 +1,282 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + loop + if type != \list + return eval_simple env, ast + else if value.length == 0 + return ast + + result = if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquote' => eval_quasiquote env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + if result.type == \tco + env = result.env + {type, value}: ast = result.ast + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 + + +eval_quasiquote = (env, params) -> + # if params.length != 1 + # runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + new-ast = if not is-pair ast + make-call 'quote', [ast] + else if is-symbol ast.value[0], 'unquote' + ast.value[1] + else if is-pair ast.value[0] and \ + is-symbol ast.value[0].value[0], 'splice-unquote' + make-call 'concat', [ + ast.value[0].value[1] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + else + make-call 'cons', [ + make-call 'quasiquote', [ast.value[0]] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + + defer-tco env, new-ast + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) ")")))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From 86e32f4d5adc214b4d8c1e46779e4b25df09358d Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Fri, 12 May 2017 22:04:31 +0200 Subject: [PATCH 0012/1998] Step 8 --- livescript/core.ls | 11 +- livescript/env.ls | 7 +- livescript/step8_macros.ls | 334 +++++++++++++++++++++++++++++++++++++ 3 files changed, 346 insertions(+), 6 deletions(-) create mode 100644 livescript/step8_macros.ls diff --git a/livescript/core.ls b/livescript/core.ls index 18b9c9e4b5..a803e1dbc5 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -6,6 +6,11 @@ fs = require 'fs' export runtime-error = (msg) -> throw new Error msg +export unpack-tco = (ast) -> + if ast.type == \tco + then ast.eval! + else ast + fn = (body) -> {type: \function, value: body} const-nil = -> {type: \const, value: \nil} @@ -132,11 +137,7 @@ export ns = do runtime-error "'swap!' expected the second parameter to be a function, got a #{fn.type}" - atom.value = fn.value.apply @, [atom.value] ++ args - if atom.value.type == \tco # TODO make this a method. - atom.value = atom.value.eval! - - atom.value + atom.value = unpack-tco (fn.value.apply @, [atom.value] ++ args) 'cons': fn (value, list) -> check-param 'cons', 1, (list-or-vector list), diff --git a/livescript/env.ls b/livescript/env.ls index 46adbe2ab7..1abdfa1af3 100644 --- a/livescript/env.ls +++ b/livescript/env.ls @@ -11,6 +11,11 @@ export class Env else if @outer? then @outer.find symbol get: (symbol) -> + result = @try-get symbol + if not result + then throw new Error "symbol not found: #{symbol}" + else result + + try-get: (symbol) -> env = @find symbol if env then env.data[symbol] - else throw new Error "symbol not found: #{symbol}" diff --git a/livescript/step8_macros.ls b/livescript/step8_macros.ls new file mode 100644 index 0000000000..d0cb83d988 --- /dev/null +++ b/livescript/step8_macros.ls @@ -0,0 +1,334 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns, unpack-tco} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, ast) --> + loop + if ast.type != \list + return eval_simple env, ast + + ast = macroexpand env, ast + if ast.type != \list + return eval_simple env, ast + else if ast.value.length == 0 + return ast + + result = if ast.value[0].type == \symbol + params = ast.value[1 to] + switch ast.value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquote' => eval_quasiquote env, params + | 'defmacro!' => eval_defmacro env, params + | 'macroexpand' => eval_macroexpand env, params + | otherwise => eval_apply env, ast.value + else + eval_apply env, ast.value + + if result.type == \tco + {env, ast} = result + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance, is_macro: false} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 + + +eval_quasiquote = (env, params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + new-ast = if not is-pair ast + make-call 'quote', [ast] + else if is-symbol ast.value[0], 'unquote' + ast.value[1] + else if is-pair ast.value[0] and \ + is-symbol ast.value[0].value[0], 'splice-unquote' + make-call 'concat', [ + ast.value[0].value[1] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + else + make-call 'cons', [ + make-call 'quasiquote', [ast.value[0]] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + + defer-tco env, new-ast + + +eval_defmacro = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of defmacro!, got a #{name.type}" + + # Evaluate the second parameter. + fn = eval_ast env, params[1] + if fn.type != \function + runtime-error "expected a function for the second parameter + of defmacro!, got a #{fn.type}" + + # Copy fn and mark the function as a macro. + macro_fn = fn with is_macro: true + env.set name.value, macro_fn + + +get-macro-fn = (env, ast) -> + if ast.type == \list and + ast.value.length != 0 and + ast.value[0].type == \symbol + fn = env.try-get ast.value[0].value + if fn and fn.type == \function and fn.is_macro + then fn + + +macroexpand = (env, ast) -> + loop # until ast is not a macro function call. + macro_fn = get-macro-fn env, ast + if not macro_fn then return ast + ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] + + +eval_macroexpand = (env, params) -> + if params.length != 1 + runtime-error "'macroexpand' expected 1 parameter, + got #{params.length}" + + macroexpand env, params[0] + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + +# Read, Evaluate, Print +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) ")")))))' + + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From 19677091f17c0d0cab1e681086979f6b0339ea21 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Fri, 12 May 2017 22:15:14 +0200 Subject: [PATCH 0013/1998] Added first, rest and nth --- livescript/core.ls | 25 +++++++++++++++++++++++++ livescript/step7_quote.ls | 4 ++-- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/livescript/core.ls b/livescript/core.ls index a803e1dbc5..0c55bd8c70 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -150,3 +150,28 @@ export ns = do runtime-error "'concat' expected all parameters to be a list or vector" {type: \list, value: params |> map (.value) |> concat} + + 'nth': fn (list, index) -> + check-param 'nth', 0, (list-or-vector list), + 'list or vector', list.type + check-param 'nth', 1, index.type == \int, + 'int', index.type + + if index.value < 0 or index.value >= list.value.length + runtime-error 'list index out of bounds' + + list.value[index.value] + + 'first': fn (list) -> + check-param 'first', 0, (list-or-vector list), + 'list or vector', list.type + + if list.value.length == 0 + then const-nil! + else list.value[0] + + 'rest': fn (list) -> + check-param 'rest', 0, (list-or-vector list), + 'list or vector', list.type + + {type: \list, value: list.value.slice 1} diff --git a/livescript/step7_quote.ls b/livescript/step7_quote.ls index 16e1283614..0deea8647f 100644 --- a/livescript/step7_quote.ls +++ b/livescript/step7_quote.ls @@ -210,8 +210,8 @@ is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 eval_quasiquote = (env, params) -> - # if params.length != 1 - # runtime-error "quasiquote expected 1 parameter, got #{params.length}" + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" ast = params[0] new-ast = if not is-pair ast From b145558e39e6d88b22442d94c3b7692452cdeaf0 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 13 May 2017 21:13:10 +0200 Subject: [PATCH 0014/1998] Step 8 complete --- livescript/core.ls | 6 ++++++ livescript/step8_macros.ls | 21 +++++++++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/livescript/core.ls b/livescript/core.ls index 0c55bd8c70..a070658c3e 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -163,6 +163,9 @@ export ns = do list.value[index.value] 'first': fn (list) -> + if list.type == \const and list.value == \nil + return const-nil! + check-param 'first', 0, (list-or-vector list), 'list or vector', list.type @@ -171,6 +174,9 @@ export ns = do else list.value[0] 'rest': fn (list) -> + if list.type == \const and list.value == \nil + return {type: \list, value: []} + check-param 'rest', 0, (list-or-vector list), 'list or vector', list.type diff --git a/livescript/step8_macros.ls b/livescript/step8_macros.ls index d0cb83d988..d256ca9a47 100644 --- a/livescript/step8_macros.ls +++ b/livescript/step8_macros.ls @@ -307,6 +307,27 @@ rep ' (read-string (str "(do " (slurp f) ")")))))' +# Define cond. +rep ' +(defmacro! cond + (fn* (& xs) + (if (> (count xs) 0) + (list \'if (first xs) + (if (> (count xs) 1) + (nth xs 1) + (throw "odd number of forms to cond")) + (cons \'cond (rest (rest xs)))))))' + +# Define or. +rep ' +(defmacro! or + (fn* (& xs) + (if (empty? xs) + nil + (if (= 1 (count xs)) + (first xs) + `(let* (or_FIXME ~(first xs)) + (if or_FIXME or_FIXME (or ~@(rest xs))))))))' # Parse program arguments. # The first two (exe and core-file) are, respectively, From 65164fe20de03f6dae8cae9be0d229713c1de0da Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 13 May 2017 22:05:34 +0200 Subject: [PATCH 0015/1998] More of step 8 --- livescript/core.ls | 35 ++++ livescript/env.ls | 2 +- livescript/step9_try.ls | 384 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 420 insertions(+), 1 deletion(-) create mode 100644 livescript/step9_try.ls diff --git a/livescript/core.ls b/livescript/core.ls index a070658c3e..9407d0569d 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -181,3 +181,38 @@ export ns = do 'list or vector', list.type {type: \list, value: list.value.slice 1} + + 'throw': fn (value) -> throw value + + 'apply': fn (fn, ...params, list) -> + check-type 'apply', 0, \function, fn.type + if not list then runtime-error "apply expected at least two parameters" + check-param 'apply', params.length+1, (list-or-vector list), + 'list or vector', list.type + + unpack-tco fn.value.apply @, params ++ list.value + + 'map': fn (fn, list) -> + check-type 'map', 0, \function, fn.type + check-param 'map', 1, (list-or-vector list), + 'list or vector', list.type + + mapped-list = list.value |> map (value) -> + unpack-tco fn.value.apply @, [value] + + {type: \list, value: mapped-list} + + 'nil?': fn (ast) -> const-bool (ast.type == \const and ast.value == \nil) + 'true?': fn (ast) -> const-bool (ast.type == \const and ast.value == \true) + 'false?': fn (ast) -> const-bool (ast.type == \const and ast.value == \false) + 'symbol?': fn (ast) -> const-bool ast.type == \symbol + + 'symbol': fn (str) -> + check-type 'symbol', 0, \string, str.type + {type: \symbol, value: str.value} + + 'keyword': fn (str) -> + check-type 'keyword', 0, \string, str.type + {type: \keyword, value: str.value} + + 'keyword?': fn (ast) -> const-bool ast.type == \keyword diff --git a/livescript/env.ls b/livescript/env.ls index 1abdfa1af3..594048012d 100644 --- a/livescript/env.ls +++ b/livescript/env.ls @@ -13,7 +13,7 @@ export class Env get: (symbol) -> result = @try-get symbol if not result - then throw new Error "symbol not found: #{symbol}" + then throw new Error "'#{symbol}' not found" else result try-get: (symbol) -> diff --git a/livescript/step9_try.ls b/livescript/step9_try.ls new file mode 100644 index 0000000000..1b6fd3b2af --- /dev/null +++ b/livescript/step9_try.ls @@ -0,0 +1,384 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns, unpack-tco} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, ast) --> + loop + if ast.type != \list + return eval_simple env, ast + + ast = macroexpand env, ast + if ast.type != \list + return eval_simple env, ast + else if ast.value.length == 0 + return ast + + result = if ast.value[0].type == \symbol + params = ast.value[1 to] + switch ast.value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquote' => eval_quasiquote env, params + | 'defmacro!' => eval_defmacro env, params + | 'macroexpand' => eval_macroexpand env, params + | 'try*' => eval_try env, params + | otherwise => eval_apply env, ast.value + else + eval_apply env, ast.value + + if result.type == \tco + {env, ast} = result + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance, is_macro: false} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 + + +eval_quasiquote = (env, params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + new-ast = if not is-pair ast + make-call 'quote', [ast] + else if is-symbol ast.value[0], 'unquote' + ast.value[1] + else if is-pair ast.value[0] and \ + is-symbol ast.value[0].value[0], 'splice-unquote' + make-call 'concat', [ + ast.value[0].value[1] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + else + make-call 'cons', [ + make-call 'quasiquote', [ast.value[0]] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + + defer-tco env, new-ast + + +eval_defmacro = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of defmacro!, got a #{name.type}" + + # Evaluate the second parameter. + fn = eval_ast env, params[1] + if fn.type != \function + runtime-error "expected a function for the second parameter + of defmacro!, got a #{fn.type}" + + # Copy fn and mark the function as a macro. + macro_fn = fn with is_macro: true + env.set name.value, macro_fn + + +get-macro-fn = (env, ast) -> + if ast.type == \list and + ast.value.length != 0 and + ast.value[0].type == \symbol + fn = env.try-get ast.value[0].value + if fn and fn.type == \function and fn.is_macro + then fn + + +macroexpand = (env, ast) -> + loop # until ast is not a macro function call. + macro_fn = get-macro-fn env, ast + if not macro_fn then return ast + ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] + + +eval_macroexpand = (env, params) -> + if params.length != 1 + runtime-error "'macroexpand' expected 1 parameter, + got #{params.length}" + + macroexpand env, params[0] + + +eval_try = (env, params) -> + if params.length != 2 + runtime-error "'try*' expected 2 parameters, + got #{params.length}" + + try-form = params[0] + catch-clause = params[1] + if catch-clause.type != \list or + catch-clause.value.length != 3 or + not (is-symbol catch-clause.value[0], 'catch*') or + catch-clause.value[1].type != \symbol + runtime-error "'try*' expected the second parameter to be + of the form (catch* A B)" + + try + eval_ast env, try-form + catch error + error-symbol = catch-clause.value[1].value + error-value = \ + if error.message + then {type: \string, value: error.message} + else error + + catch-env = new Env env + catch-env.set error-symbol, error-value + eval_ast catch-env, catch-clause.value[2] + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + +# Read, Evaluate, Print +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) ")")))))' + +# Define cond. +rep ' +(defmacro! cond + (fn* (& xs) + (if (> (count xs) 0) + (list \'if (first xs) + (if (> (count xs) 1) + (nth xs 1) + (throw "odd number of forms to cond")) + (cons \'cond (rest (rest xs)))))))' + +# Define or. +rep ' +(defmacro! or + (fn* (& xs) + (if (empty? xs) + nil + (if (= 1 (count xs)) + (first xs) + `(let* (or_FIXME ~(first xs)) + (if or_FIXME or_FIXME (or ~@(rest xs))))))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From 894f5ce82c4b6a615ba35b73a5740471b6e397d8 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 14 May 2017 22:05:49 +0200 Subject: [PATCH 0016/1998] Completed step 9 --- livescript/core.ls | 101 +++++++++++++++++++++++++++++++++++++------ livescript/reader.ls | 16 +++---- 2 files changed, 95 insertions(+), 22 deletions(-) diff --git a/livescript/core.ls b/livescript/core.ls index 9407d0569d..2c480bf9f7 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -1,6 +1,10 @@ -{zip, map, apply, and-list, join, Obj, concat, all} = require 'prelude-ls' +{ + zip, map, apply, and-list, join, Obj, concat, all, + pairs-to-obj, obj-to-pairs, reject, keys, values, + difference, empty +} = require 'prelude-ls' {pr_str} = require './printer' -{read_str} = require './reader' +{read_str, list-to-map, map-keyword, keyword-prefix} = require './reader' fs = require 'fs' @@ -20,18 +24,25 @@ const-str = (str) -> {type: \string, value: str} list-or-vector = ({type}) -> type in [\list \vector] +are-lists-equal = (equals-fn, a, b) -> + if a.length != b.length then false + else zip a, b |> map (apply equals-fn) |> and-list + deep-equals = (a, b) -> - if not list-or-vector a then - if a.type != b.type then false - else a.value == b.value - else if list-or-vector b then - if a.value.length != b.value.length then false - else - # Compare all elements of a and b with deep-equals. - zip a.value, b.value - |> map (apply deep-equals) - |> and-list # all must be true (equals) - else false + if (list-or-vector a) and (list-or-vector b) then + are-lists-equal deep-equals, a.value, b.value + else if a.type == \map and b.type == \map then + a-keys = keys a.value + b-keys = keys b.value + if a-keys.length == b-keys.length and \ + empty (difference a-keys, b-keys) + #if are-lists-equal (==), a-keys, b-keys + a-keys |> map (key) -> [a.value[key], b.value[key]] + |> map (apply deep-equals) + |> and-list + else false + else if a.type != b.type then false + else a.value == b.value check-param = (name, idx, test, expected, actual) -> @@ -213,6 +224,68 @@ export ns = do 'keyword': fn (str) -> check-type 'keyword', 0, \string, str.type - {type: \keyword, value: str.value} + {type: \keyword, value: ':' + str.value} 'keyword?': fn (ast) -> const-bool ast.type == \keyword + + 'vector': fn (...params) -> {type: \vector, value: params} + 'vector?': fn (ast) -> const-bool ast.type == \vector + + 'hash-map': fn (...params) -> list-to-map params + + 'map?': fn (ast) -> const-bool ast.type == \map + + 'assoc': fn (m, ...params) -> + check-type 'assoc', 0, \map, m.type + + # Turn the params into a map, this is kind of hacky. + params-map = list-to-map params + + # Copy the map by cloning (prototyping). + new-map = ^^m.value + + for k, v of params-map.value + new-map[k] = v + + {type: \map, value: new-map} + + 'dissoc': fn (m, ...keys) -> + check-type 'dissoc', 0, \map, m.type + + # Convert keyword to map key strings. + str-keys = keys |> map map-keyword + + new-map = m.value + |> obj-to-pairs + |> reject ([key, value]) -> key in str-keys + |> pairs-to-obj + + {type: \map, value: new-map} + + 'get': fn (m, key) -> + if m.type == \const and m.value == \nil + then return const-nil! + + check-type 'get', 0, \map, m.type + str-key = map-keyword key + value = m.value[str-key] + if value then value else const-nil! + + 'contains?': fn (m, key) -> + check-type 'contains?', 0, \map, m.type + str-key = map-keyword key + const-bool (str-key of m.value) + + 'keys': fn (m) -> + check-type 'keys', 0, \map, m.type + result = keys m.value |> map (key) -> + if key.startsWith keyword-prefix + then {type: \keyword, value: key.substring 1} + else {type: \string, value: key} + {type: \list, value: result} + + 'vals': fn (m) -> + check-type 'vals', 0, \map, m.type + {type: \list, value: values m.value} + + 'sequential?': fn (ast) -> const-bool list-or-vector ast diff --git a/livescript/reader.ls b/livescript/reader.ls index 1397283356..96aad575ac 100644 --- a/livescript/reader.ls +++ b/livescript/reader.ls @@ -135,20 +135,20 @@ decode-string = (str) -> export keyword-prefix = '\u029e' +export map-keyword = (key) -> + switch key.type + | \string => key.value + | \keyword => keyword-prefix + key.value + | otherwise => + parse-error "#{key.type} can't be a map key" -list-to-map = (list) -> +export list-to-map = (list) -> if list.length % 2 != 0 parse-error "map should have an even number of elements, got #{list.length}" list-to-pairs list - |> map ([key, value]) -> - switch key.type - | \string => [key.value, value] - | \keyword => [keyword-prefix + key.value, value] - | otherwise => - parse-error "map can only have strings or keywords as keys, - got a #{key.type}" + |> map ([key, value]) -> [(map-keyword key), value] |> pairs-to-obj |> (obj) -> {type: \map, value: obj} From 681ce637b6ce51fb8bc44bac1e21075607997da2 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 23 May 2017 11:04:32 -0500 Subject: [PATCH 0017/1998] Deprecate tests/docker/Dockerfile --- tests/docker/Dockerfile | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/docker/Dockerfile b/tests/docker/Dockerfile index 3286498781..0357c61f78 100644 --- a/tests/docker/Dockerfile +++ b/tests/docker/Dockerfile @@ -1,3 +1,6 @@ +# WARNING: This file is deprecated. Each implementation now has its +# own Dockerfile. + FROM ubuntu:utopic MAINTAINER Joel Martin From 4603f2a931e8305afae3428012b522e87b518b63 Mon Sep 17 00:00:00 2001 From: Dennis Felsing Date: Tue, 23 May 2017 14:46:37 +0200 Subject: [PATCH 0018/1998] Update to Nim 0.17.0 --- README.md | 4 ++-- nim/Dockerfile | 6 +++--- tests/docker/Dockerfile | 6 +++--- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 07dd123645..0a0ace4564 100644 --- a/README.md +++ b/README.md @@ -566,11 +566,11 @@ cd make make -f stepX_YYY.mk ``` -### Nim 0.15.2 +### Nim 0.17.0 *The Nim implementation was created by [Dennis Felsing (def-)](https://github.com/def-)* -The Nim implementation of mal has been tested with Nim 0.15.2. +The Nim implementation of mal has been tested with Nim 0.17.0. ``` cd nim diff --git a/nim/Dockerfile b/nim/Dockerfile index 20c3d79439..9744753e93 100644 --- a/nim/Dockerfile +++ b/nim/Dockerfile @@ -26,10 +26,10 @@ RUN apt-get -y install g++ # Nim RUN apt-get -y install xz-utils -RUN cd /tmp && curl -O http://nim-lang.org/download/nim-0.16.0.tar.xz \ - && tar xvJf /tmp/nim-0.16.0.tar.xz && cd nim-0.16.0 \ +RUN cd /tmp && curl -O http://nim-lang.org/download/nim-0.17.0.tar.xz \ + && tar xvJf /tmp/nim-0.17.0.tar.xz && cd nim-0.17.0 \ && make && sh install.sh /usr/local/bin \ && cp bin/nim /usr/local/bin/ \ - && rm -r /tmp/nim-0.16.0 + && rm -r /tmp/nim-0.17.0 ENV HOME /mal diff --git a/tests/docker/Dockerfile b/tests/docker/Dockerfile index 3286498781..6172429efe 100644 --- a/tests/docker/Dockerfile +++ b/tests/docker/Dockerfile @@ -116,10 +116,10 @@ RUN luarocks install linenoise RUN npm install -g minimal-lisp # Nim -RUN cd /tmp && wget http://nim-lang.org/download/nim-0.11.0.tar.xz \ - && tar xvJf /tmp/nim-0.11.0.tar.xz && cd nim-0.11.0 \ +RUN cd /tmp && wget http://nim-lang.org/download/nim-0.17.0.tar.xz \ + && tar xvJf /tmp/nim-0.17.0.tar.xz && cd nim-0.17.0 \ && make && sh install.sh /usr/local/bin \ - && rm -r /tmp/nim-0.11.0 + && rm -r /tmp/nim-0.17.0 # OCaml RUN apt-get -y install ocaml-batteries-included From 5182fdad56aba07adc09e4d85fabd1bdc54658ff Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 23 May 2017 23:28:48 +0200 Subject: [PATCH 0019/1998] Apply hack to Emacs 25 instead of Emacs 25.1 --- elisp/reader.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/reader.el b/elisp/reader.el index e63b1aaced..af68fd1fad 100644 --- a/elisp/reader.el +++ b/elisp/reader.el @@ -1,6 +1,6 @@ ;; HACK: `text-quoting-style' prettifies quotes in error messages on -;; Emacs 25.1, but no longer does from 25.2 upwards... -(when (and (= emacs-major-version 25) (= emacs-minor-version 1)) +;; Emacs 25, but no longer does from 26 upwards... +(when (= emacs-major-version 25) (setq text-quoting-style 'grave)) (defvar tokens nil) From 4d8cfe7ec7b9bd228d284168f13d0c2decb18e1c Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 24 May 2017 14:48:55 +0200 Subject: [PATCH 0020/1998] Self hosting! --- livescript/core.ls | 57 +++++- livescript/stepA_mal.ls | 397 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 451 insertions(+), 3 deletions(-) create mode 100644 livescript/stepA_mal.ls diff --git a/livescript/core.ls b/livescript/core.ls index 2c480bf9f7..c1bc034838 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -1,11 +1,13 @@ + { zip, map, apply, and-list, join, Obj, concat, all, pairs-to-obj, obj-to-pairs, reject, keys, values, - difference, empty + difference, empty, reverse, chars } = require 'prelude-ls' {pr_str} = require './printer' {read_str, list-to-map, map-keyword, keyword-prefix} = require './reader' fs = require 'fs' +{readline} = require './node_readline' export runtime-error = (msg) -> throw new Error msg @@ -15,7 +17,6 @@ export unpack-tco = (ast) -> then ast.eval! else ast - fn = (body) -> {type: \function, value: body} const-nil = -> {type: \const, value: \nil} const-int = (int) -> {type: \int, value: int} @@ -97,7 +98,7 @@ export ns = do '>=': fn (a, b) -> const-bool a.value >= b.value 'not': fn ({type, value}) -> - const-bool (type == \const and value == \false) + const-bool (type == \const and value in [\false \nil]) 'pr-str': fn (...params) -> params |> map (p) -> pr_str p, print_readably=true @@ -289,3 +290,53 @@ export ns = do {type: \list, value: values m.value} 'sequential?': fn (ast) -> const-bool list-or-vector ast + + 'with-meta': fn (ast, m) -> + ast with {meta: m} + + 'meta': fn (ast) -> + if ast.meta + then ast.meta + else const-nil! + + 'readline': fn (prompt) -> + check-type 'readline', 0, \string, prompt.type + result = readline prompt.value + if result? + then const-str result + else const-nil! + + 'time-ms': fn -> + const-int (new Date).getTime! + + 'conj': fn (list, ...params) -> + check-param 'conj', 0, (list-or-vector list), + 'list or vector', list.type + + if list.type == \list + type: \list + value: (reverse params) ++ list.value + else + type: \vector + value: list.value ++ params + + 'string?': fn (ast) -> const-bool ast.type == \string + + 'seq': fn (seq) -> + switch seq.type + | \list => + if seq.value.length + then seq + else const-nil! + | \vector => + if seq.value.length + then {type: \list, value: seq.value} + else const-nil! + | \string => + if seq.value.length + then {type: \list, value: chars seq.value |> map const-str} + else const-nil! + | otherwise => + if seq.type == \const and seq.value == \nil + then const-nil! + else runtime-error "unsupported type for 'seq': #{seq.type}" diff --git a/livescript/stepA_mal.ls b/livescript/stepA_mal.ls new file mode 100644 index 0000000000..eb39d8f9bb --- /dev/null +++ b/livescript/stepA_mal.ls @@ -0,0 +1,397 @@ +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns, unpack-tco} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, ast) --> + loop + if ast.type != \list + return eval_simple env, ast + + ast = macroexpand env, ast + if ast.type != \list + return eval_simple env, ast + else if ast.value.length == 0 + return ast + + result = if ast.value[0].type == \symbol + params = ast.value[1 to] + switch ast.value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquote' => eval_quasiquote env, params + | 'defmacro!' => eval_defmacro env, params + | 'macroexpand' => eval_macroexpand env, params + | 'try*' => eval_try env, params + | otherwise => eval_apply env, ast.value + else + eval_apply env, ast.value + + if result.type == \tco + {env, ast} = result + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance, is_macro: false} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 + + +eval_quasiquote = (env, params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + new-ast = if not is-pair ast + make-call 'quote', [ast] + else if is-symbol ast.value[0], 'unquote' + ast.value[1] + else if is-pair ast.value[0] and \ + is-symbol ast.value[0].value[0], 'splice-unquote' + make-call 'concat', [ + ast.value[0].value[1] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + else + make-call 'cons', [ + make-call 'quasiquote', [ast.value[0]] + make-call 'quasiquote', [make-list ast.value[1 to]] + ] + + defer-tco env, new-ast + + +eval_defmacro = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of defmacro!, got a #{name.type}" + + # Evaluate the second parameter. + fn = eval_ast env, params[1] + if fn.type != \function + runtime-error "expected a function for the second parameter + of defmacro!, got a #{fn.type}" + + # Copy fn and mark the function as a macro. + macro_fn = fn with is_macro: true + env.set name.value, macro_fn + + +get-macro-fn = (env, ast) -> + if ast.type == \list and + ast.value.length != 0 and + ast.value[0].type == \symbol + fn = env.try-get ast.value[0].value + if fn and fn.type == \function and fn.is_macro + then fn + + +macroexpand = (env, ast) -> + loop # until ast is not a macro function call. + macro_fn = get-macro-fn env, ast + if not macro_fn then return ast + ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] + + +eval_macroexpand = (env, params) -> + if params.length != 1 + runtime-error "'macroexpand' expected 1 parameter, + got #{params.length}" + + macroexpand env, params[0] + + +eval_try = (env, params) -> + if params.length != 2 + runtime-error "'try*' expected 2 parameters, + got #{params.length}" + + try-form = params[0] + catch-clause = params[1] + if catch-clause.type != \list or + catch-clause.value.length != 3 or + not (is-symbol catch-clause.value[0], 'catch*') or + catch-clause.value[1].type != \symbol + runtime-error "'try*' expected the second parameter to be + of the form (catch* A B)" + + try + eval_ast env, try-form + catch error + error-symbol = catch-clause.value[1].value + error-value = \ + if error.message + then {type: \string, value: error.message} + else error + + catch-env = new Env env + catch-env.set error-symbol, error-value + eval_ast catch-env, catch-clause.value[2] + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + +# Read, Evaluate, Print +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) ")")))))' + +# Define cond. +rep ' +(defmacro! cond + (fn* (& xs) + (if (> (count xs) 0) + (list \'if (first xs) + (if (> (count xs) 1) + (nth xs 1) + (throw "odd number of forms to cond")) + (cons \'cond (rest (rest xs)))))))' + +rep '(def! *gensym-counter* (atom 0))' + +rep ' +(def! gensym + (fn* [] + (symbol + (str "G__" + (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))' + +rep ' +(defmacro! or + (fn* (& xs) + (if (empty? xs) + nil + (if (= 1 (count xs)) + (first xs) + (let* (condvar (gensym)) + `(let* (~condvar ~(first xs)) + (if ~condvar ~condvar (or ~@(rest xs)))))))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + +repl_env.set '*host-language*', + {type: \string, value: 'livescript'} + + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + rep '(println (str "Mal [" *host-language* "]"))' + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message From a873632f191afcc606bd445102df4ce118c3d18f Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 24 May 2017 15:03:48 +0200 Subject: [PATCH 0021/1998] Fixed recursion in Makefile --- livescript/Makefile | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/livescript/Makefile b/livescript/Makefile index 62b91c1bb2..a18354c4e1 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -1,16 +1,18 @@ -TESTS = +SOURCES_BASE = reader.ls printer.ls env.ls core.ls utils.ls +SOURCES_STEPS = step0_repl.ls step1_read_print.ls step2_eval.ls \ + step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ + step8_macros.ls step9_try.ls stepA_mal.ls +SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) -SOURCES_BASE = reader.js printer.js env.js core.js utils.js -SOURCES_LISP = -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) +BINS = $(SOURCES:%.ls=%.js) -all: $(SOURCES) node_modules +all: $(BINS) node_modules node_modules: npm install -%.js: %.ls $(SOURCES) +%.js: %.ls lsc -d -c $(@:%.js=%.ls) clean: - rm -f *.js + rm -f $(BINS) From 361dffd818245f32e997fc2eb9f144385a2e68ff Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 24 May 2017 15:07:09 +0200 Subject: [PATCH 0022/1998] Fixed wrong ignore of livescript/node_readline.js --- .gitignore | 2 ++ livescript/node_readline.js | 47 +++++++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+) create mode 100644 livescript/node_readline.js diff --git a/.gitignore b/.gitignore index a7f1a11bfd..354278e904 100644 --- a/.gitignore +++ b/.gitignore @@ -125,3 +125,5 @@ common-lisp/*.lib common-lisp/images/* common-lisp/hist/* livescript/*.js +!livescript/node_readline.js +livescript/node_modules diff --git a/livescript/node_readline.js b/livescript/node_readline.js new file mode 100644 index 0000000000..e59a62bd1e --- /dev/null +++ b/livescript/node_readline.js @@ -0,0 +1,47 @@ +// IMPORTANT: choose one +var RL_LIB = "libreadline"; // NOTE: libreadline is GPL +//var RL_LIB = "libedit"; + +var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); + +var rlwrap = {}; // namespace for this module in web context + +var ffi = require('ffi'), + fs = require('fs'); + +var rllib = ffi.Library(RL_LIB, { + 'readline': [ 'string', [ 'string' ] ], + 'add_history': [ 'int', [ 'string' ] ]}); + +var rl_history_loaded = false; + +exports.readline = rlwrap.readline = function(prompt) { + prompt = typeof prompt !== 'undefined' ? prompt : "user> "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i Date: Wed, 24 May 2017 15:10:53 +0200 Subject: [PATCH 0023/1998] Added livescript to dependencies + use local livescript compiler --- livescript/Makefile | 6 ++++-- livescript/package.json | 8 +++++--- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/livescript/Makefile b/livescript/Makefile index a18354c4e1..080d572732 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -6,13 +6,15 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) BINS = $(SOURCES:%.ls=%.js) -all: $(BINS) node_modules +LSC = node_modules/.bin/lsc + +all: node_modules $(BINS) node_modules: npm install %.js: %.ls - lsc -d -c $(@:%.js=%.ls) + $(LSC) -d -c $(@:%.js=%.ls) clean: rm -f $(BINS) diff --git a/livescript/package.json b/livescript/package.json index 8cb53e1afa..af94704c1e 100644 --- a/livescript/package.json +++ b/livescript/package.json @@ -4,10 +4,12 @@ "description": "", "main": "index.js", "dependencies": { - "prelude-ls": "^1.1.2", - "ffi": "2.0.x" + "ffi": "2.0.x", + "prelude-ls": "^1.1.2" + }, + "devDependencies": { + "livescript": "^1.5.0" }, - "devDependencies": {}, "scripts": { "test": "echo \"Error: no test specified\" && exit 1" }, From 0af8fd20ce0342ea5ae45b9082c3c5bd520ddd30 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 24 May 2017 19:12:00 +0200 Subject: [PATCH 0024/1998] Fixed Makefile, added Dockerfile and updated README. --- .travis.yml | 1 + README.md | 15 ++++++++++++++- livescript/Dockerfile | 31 +++++++++++++++++++++++++++++++ livescript/Makefile | 22 +++++++++++++++++++++- 4 files changed, 67 insertions(+), 2 deletions(-) create mode 100644 livescript/Dockerfile diff --git a/.travis.yml b/.travis.yml index 010ac7cea7..711212ab7d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -36,6 +36,7 @@ matrix: - {env: IMPL=js, services: [docker]} - {env: IMPL=julia, services: [docker]} - {env: IMPL=kotlin, services: [docker]} + - {env: IMPL=livescript, services: [docker]} - {env: IMPL=logo, services: [docker]} - {env: IMPL=lua, services: [docker]} - {env: IMPL=make, services: [docker]} diff --git a/README.md b/README.md index 07dd123645..97aa11167a 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 64 languages: +Mal is implemented in 65 languages: * Ada * GNU awk @@ -39,6 +39,7 @@ Mal is implemented in 64 languages: * JavaScript ([Online Demo](http://kanaka.github.io/mal)) * Julia * Kotlin +* LiveScript * Logo * Lua * GNU Make @@ -525,6 +526,18 @@ make java -jar stepX_YYY.jar ``` +### LiveScript + +*The LiveScript implementation was created by [Jos van Bakel](https://github.com/c0deaddict)* + +The LiveScript implementation of mal has been tested with LiveScript 1.5. + +``` +cd livescript +make +node_modules/.bin/lsc stepX_YYY.ls +``` + ### Logo *The Logo implementation was created by [Dov Murik](https://github.com/dubek)* diff --git a/livescript/Dockerfile b/livescript/Dockerfile new file mode 100644 index 0000000000..fbb4b5572e --- /dev/null +++ b/livescript/Dockerfile @@ -0,0 +1,31 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 7.X +RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs \ No newline at end of file diff --git a/livescript/Makefile b/livescript/Makefile index 080d572732..faec18c5a6 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -2,6 +2,7 @@ SOURCES_BASE = reader.ls printer.ls env.ls core.ls utils.ls SOURCES_STEPS = step0_repl.ls step1_read_print.ls step2_eval.ls \ step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ step8_macros.ls step9_try.ls stepA_mal.ls +SOURCES_LISP = env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) BINS = $(SOURCES:%.ls=%.js) @@ -13,8 +14,27 @@ all: node_modules $(BINS) node_modules: npm install -%.js: %.ls +%.js: %.ls node_modules $(LSC) -d -c $(@:%.js=%.ls) +step1_read_print.js: utils.js reader.js printer.js +step2_eval.js: utils.js reader.js printer.js +step3_env.js: utils.js reader.js printer.js env.js +step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js +step5_tco.js: utils.js reader.js printer.js env.js core.js +step6_file.js: utils.js reader.js printer.js env.js core.js +step7_quote.js: utils.js reader.js printer.js env.js core.js +step8_macros.js: utils.js reader.js printer.js env.js core.js +step9_try.js: utils.js reader.js printer.js env.js core.js +stepA_mal.js: utils.js reader.js printer.js env.js core.js + clean: rm -f $(BINS) + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" + +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" From f5df79b639c6875531ce1a843aac08ca62af13d0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 24 May 2017 12:32:00 -0500 Subject: [PATCH 0025/1998] Livescript: update Dockerfile to support Travis. --- livescript/Dockerfile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/livescript/Dockerfile b/livescript/Dockerfile index fbb4b5572e..edfa6948c6 100644 --- a/livescript/Dockerfile +++ b/livescript/Dockerfile @@ -28,4 +28,7 @@ RUN apt-get -y install g++ RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - # Install nodejs -RUN apt-get -y install nodejs \ No newline at end of file +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + From bff7ae8bc81a4712385bbbb2cabc8a4a30afe9bc Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 4 Jun 2017 11:54:24 +0200 Subject: [PATCH 0026/1998] Elm: step 0 --- .gitignore | 5 +++ Makefile | 3 +- elm/Dockerfile | 31 +++++++++++++++++ elm/Makefile | 40 ++++++++++++++++++++++ elm/bootstrap.js | 20 +++++++++++ elm/elm-package.json | 14 ++++++++ elm/node_readline.js | 47 +++++++++++++++++++++++++ elm/package.json | 17 ++++++++++ elm/run | 2 ++ elm/step0_repl.elm | 81 ++++++++++++++++++++++++++++++++++++++++++++ 10 files changed, 259 insertions(+), 1 deletion(-) create mode 100644 elm/Dockerfile create mode 100644 elm/Makefile create mode 100644 elm/bootstrap.js create mode 100644 elm/elm-package.json create mode 100644 elm/node_readline.js create mode 100644 elm/package.json create mode 100755 elm/run create mode 100644 elm/step0_repl.elm diff --git a/.gitignore b/.gitignore index 354278e904..b5bfa49851 100644 --- a/.gitignore +++ b/.gitignore @@ -127,3 +127,8 @@ common-lisp/hist/* livescript/*.js !livescript/node_readline.js livescript/node_modules +elm/node_modules +elm/elm-stuff +elm/*.js +!elm/node_readline.js +!elm/bootstrap.js diff --git a/Makefile b/Makefile index 1ad8c84f7c..7473c11cc0 100644 --- a/Makefile +++ b/Makefile @@ -82,7 +82,7 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ python r racket rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ - vimscript livescript + vimscript livescript elm EXTENSION = .mal @@ -216,6 +216,7 @@ vhdl_STEP_TO_PROG = vhdl/$($(1)) vimscript_STEP_TO_PROG = vimscript/$($(1)).vim guile_STEP_TO_PROG = guile/$($(1)).scm livescript_STEP_TO_PROG = livescript/$($(1)).js +elm_STEP_TO_PROG = elm/$($(1)).elm # Needed some argument munging diff --git a/elm/Dockerfile b/elm/Dockerfile new file mode 100644 index 0000000000..fbb4b5572e --- /dev/null +++ b/elm/Dockerfile @@ -0,0 +1,31 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 7.X +RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs \ No newline at end of file diff --git a/elm/Makefile b/elm/Makefile new file mode 100644 index 0000000000..e5daf40fa0 --- /dev/null +++ b/elm/Makefile @@ -0,0 +1,40 @@ +SOURCES_BASE = #reader.ls printer.ls env.ls core.ls utils.ls +SOURCES_STEPS = step0_repl.elm #step1_read_print.ls step2_eval.ls \ + step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ + step8_macros.ls step9_try.ls stepA_mal.ls +SOURCES_LISP = #env.ls core.ls stepA_mal.ls +SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) + +BINS = $(SOURCES:%.elm=%.js) + +ELM_MAKE = node_modules/.bin/elm-make + +all: node_modules $(BINS) + +node_modules: + npm install + +%.js: %.elm node_modules + $(ELM_MAKE) $(@:%.js=%.elm) --output $@ + +# step1_read_print.js: utils.js reader.js printer.js +# step2_eval.js: utils.js reader.js printer.js +# step3_env.js: utils.js reader.js printer.js env.js +# step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js +# step5_tco.js: utils.js reader.js printer.js env.js core.js +# step6_file.js: utils.js reader.js printer.js env.js core.js +# step7_quote.js: utils.js reader.js printer.js env.js core.js +# step8_macros.js: utils.js reader.js printer.js env.js core.js +# step9_try.js: utils.js reader.js printer.js env.js core.js +# stepA_mal.js: utils.js reader.js printer.js env.js core.js + +clean: + rm -f $(BINS) + +# stats: $(SOURCES) +# @wc $^ +# @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" + +# stats-lisp: $(SOURCES_LISP) +# @wc $^ +# @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" diff --git a/elm/bootstrap.js b/elm/bootstrap.js new file mode 100644 index 0000000000..6ec5f3048c --- /dev/null +++ b/elm/bootstrap.js @@ -0,0 +1,20 @@ +var readline = require('./node_readline'); + +// The first two arguments are: 'node' and 'bootstrap.js' +// The third argument is the name of the Elm module to load. +var args = process.argv.slice(2); +var mod = require('./' + args[0]); + +var app = mod.Main.worker({ + args: args.slice(1) +}); + +// Hook up the output and readLine ports of the app. +app.ports.output.subscribe(function(line) { + console.log(line); +}); + +app.ports.readLine.subscribe(function(prompt) { + var line = readline.readline(prompt); + app.ports.input.send(line); +}); diff --git a/elm/elm-package.json b/elm/elm-package.json new file mode 100644 index 0000000000..bec8632f38 --- /dev/null +++ b/elm/elm-package.json @@ -0,0 +1,14 @@ +{ + "version": "1.0.0", + "summary": "Make-A-Lisp implementation in Elm", + "repository": "https://github.com/kanaka/mal.git", + "license": "BSD3", + "source-directories": [ + "." + ], + "exposed-modules": [], + "dependencies": { + "elm-lang/core": "5.1.1 <= v < 6.0.0" + }, + "elm-version": "0.18.0 <= v < 0.19.0" +} diff --git a/elm/node_readline.js b/elm/node_readline.js new file mode 100644 index 0000000000..e59a62bd1e --- /dev/null +++ b/elm/node_readline.js @@ -0,0 +1,47 @@ +// IMPORTANT: choose one +var RL_LIB = "libreadline"; // NOTE: libreadline is GPL +//var RL_LIB = "libedit"; + +var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); + +var rlwrap = {}; // namespace for this module in web context + +var ffi = require('ffi'), + fs = require('fs'); + +var rllib = ffi.Library(RL_LIB, { + 'readline': [ 'string', [ 'string' ] ], + 'add_history': [ 'int', [ 'string' ] ]}); + +var rl_history_loaded = false; + +exports.readline = rlwrap.readline = function(prompt) { + prompt = typeof prompt !== 'undefined' ? prompt : "user> "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i Cmd msg + + +port readLine : String -> Cmd msg + + +port input : (Maybe String -> msg) -> Sub msg + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = \model -> input Input + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + } + + +type Msg + = Input (Maybe String) + + +init : Flags -> ( Model, Cmd Msg ) +init flags = + ( flags, readLine prompt ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Just line) -> + ( model + , Cmd.batch + [ output (rep line) + , readLine prompt + ] + ) + + Input Nothing -> + ( model, Cmd.none ) + + +prompt : String +prompt = + "user> " + + +read : String -> String +read ast = + ast + + +eval : String -> String +eval ast = + ast + + +print : String -> String +print ast = + ast + + +rep : String -> String +rep = + read >> eval >> print From 0d8a8d94fd972e964946cbefa52f20a1add89768 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 4 Jun 2017 23:41:21 +0200 Subject: [PATCH 0027/1998] Elm: step 1 using parser combinator --- elm/Makefile | 11 ++- elm/Printer.elm | 87 +++++++++++++++++ elm/Reader.elm | 203 +++++++++++++++++++++++++++++++++++++++ elm/Types.elm | 27 ++++++ elm/Utils.elm | 73 ++++++++++++++ elm/elm-package.json | 1 + elm/step1_read_print.elm | 111 +++++++++++++++++++++ 7 files changed, 509 insertions(+), 4 deletions(-) create mode 100644 elm/Printer.elm create mode 100644 elm/Reader.elm create mode 100644 elm/Types.elm create mode 100644 elm/Utils.elm create mode 100644 elm/step1_read_print.elm diff --git a/elm/Makefile b/elm/Makefile index e5daf40fa0..9dba7758bc 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,5 +1,5 @@ SOURCES_BASE = #reader.ls printer.ls env.ls core.ls utils.ls -SOURCES_STEPS = step0_repl.elm #step1_read_print.ls step2_eval.ls \ +SOURCES_STEPS = step0_repl.elm step1_read_print.elm #step2_eval.ls \ step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls @@ -7,17 +7,20 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) BINS = $(SOURCES:%.elm=%.js) -ELM_MAKE = node_modules/.bin/elm-make +ELM = node_modules/.bin/elm all: node_modules $(BINS) node_modules: npm install +elm_packages: + $(ELM) package install + %.js: %.elm node_modules - $(ELM_MAKE) $(@:%.js=%.elm) --output $@ + $(ELM) make $(@:%.js=%.elm) --output $@ -# step1_read_print.js: utils.js reader.js printer.js +step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm # step2_eval.js: utils.js reader.js printer.js # step3_env.js: utils.js reader.js printer.js env.js # step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/Printer.elm b/elm/Printer.elm new file mode 100644 index 0000000000..5667d53a2a --- /dev/null +++ b/elm/Printer.elm @@ -0,0 +1,87 @@ +module Printer exposing (..) + +import Array exposing (Array) +import Dict exposing (Dict) +import Types exposing (MalExpr(..), keywordPrefix) +import Utils exposing (encodeString, wrap) + + +printString : Bool -> MalExpr -> String +printString readably ast = + case ast of + MalNil -> + "nil" + + MalBool True -> + "true" + + MalBool False -> + "false" + + MalInt int -> + toString int + + MalString str -> + printRawString readably str + + MalSymbol sym -> + sym + + MalKeyword kw -> + kw + + MalList list -> + printList readably list + + MalVector vec -> + printVector readably vec + + MalMap map -> + printMap readably map + + +printRawString : Bool -> String -> String +printRawString readably str = + if readably then + encodeString str + else + str + + +printList : Bool -> List MalExpr -> String +printList readably = + List.map (printString readably) + >> String.join " " + >> wrap "(" ")" + + +printVector : Bool -> Array MalExpr -> String +printVector readably = + Array.map (printString readably) + >> Array.toList + >> String.join " " + >> wrap "[" "]" + + +printMap : Bool -> Dict String MalExpr -> String +printMap readably = + let + -- Strip off the keyword prefix if it is there. + printKey k = + case String.uncons k of + Just ( prefix, rest ) -> + if prefix == keywordPrefix then + rest + else + printRawString readably k + + _ -> + printRawString readably k + + printEntry ( k, v ) = + (printKey k) ++ " " ++ (printString readably v) + in + Dict.toList + >> List.map printEntry + >> String.join " " + >> wrap "{" "}" diff --git a/elm/Reader.elm b/elm/Reader.elm new file mode 100644 index 0000000000..bcd934486f --- /dev/null +++ b/elm/Reader.elm @@ -0,0 +1,203 @@ +module Reader exposing (..) + +import Array +import Dict +import Combine exposing (..) +import Combine.Num +import Types exposing (MalExpr(..), keywordPrefix) +import Utils exposing (decodeString, makeCall) + + +comment : Parser s String +comment = + regex ";.*" + + +ws : Parser s (List String) +ws = + many (comment <|> string "," <|> whitespace) + + +nil : Parser s MalExpr +nil = + MalNil <$ string "nil" "nil" + + +int : Parser s MalExpr +int = + MalInt <$> Combine.Num.int "int" + + +bool : Parser s MalExpr +bool = + MalBool + <$> choice + [ True <$ string "true" + , False <$ string "false" + ] + "bool" + + +symbolString : Parser s String +symbolString = + regex "[^\\s\\[\\]{}('\"`,;)]+" + + +symbol : Parser s MalExpr +symbol = + MalSymbol + <$> symbolString + "symbol" + + +keywordString : Parser s String +keywordString = + (++) + <$> string ":" + <*> symbolString + + +keyword : Parser s MalExpr +keyword = + MalKeyword <$> keywordString + + +list : Parser s MalExpr +list = + MalList + <$> parens (many form <* ws) + "list" + + +vector : Parser s MalExpr +vector = + MalVector + << Array.fromList + <$> (string "[" + *> many form + <* ws + <* string "]" + ) + "vector" + + +mapKey : Parser s String +mapKey = + choice + [ String.cons keywordPrefix <$> keywordString + , decodeString <$> strString + ] + + +mapEntry : Parser s ( String, MalExpr ) +mapEntry = + (,) <$> mapKey <*> form "map entry" + + +map : Parser s MalExpr +map = + lazy <| + \() -> + MalMap + << Dict.fromList + <$> (string "{" + *> many (ws *> mapEntry) + <* ws + <* string "}" + ) + "map" + + +atom : Parser s MalExpr +atom = + choice + [ int + , bool + , str + , nil + , keyword + , symbol + ] + "atom" + + +form : Parser s MalExpr +form = + lazy <| + \() -> + let + parsers = + [ list + , vector + , map + , simpleMacro "'" "quote" + , simpleMacro "`" "quasiquote" + , simpleMacro "~@" "splice-unquote" + , simpleMacro "~" "unquote" + , simpleMacro "@" "deref" + , withMeta + , atom + ] + in + ws *> choice parsers "form" + + +simpleMacro : String -> String -> Parser s MalExpr +simpleMacro token symbol = + makeCall symbol + << List.singleton + <$> (string token *> form) + symbol + + +withMeta : Parser s MalExpr +withMeta = + lazy <| + \() -> + let + make meta expr = + makeCall "with-meta" [ expr, meta ] + in + make + <$> (string "^" *> map) + <*> form + "with-meta" + + +readString : String -> Result String (Maybe MalExpr) +readString str = + case parse ((maybe form) <* ws <* end) str of + Ok ( _, _, ast ) -> + Ok ast + + Err ( _, stream, ms ) -> + Err <| formatError ms stream + + +formatError : List String -> InputStream -> String +formatError ms stream = + let + location = + currentLocation stream + in + "Parse error: expected a: " + ++ String.join ", " ms + ++ " " + ++ "(at " + ++ toString location.line + ++ ":" + ++ toString location.column + ++ ")" + + +str : Parser s MalExpr +str = + MalString << decodeString <$> strString + + +{-| Syntax highlighter in VS code is messed up by this regex, +that's why it's down below. :) +-} +strString : Parser s String +strString = + regex "\"(\\\\\"|[^\"])*\"" "string" diff --git a/elm/Types.elm b/elm/Types.elm new file mode 100644 index 0000000000..766457e756 --- /dev/null +++ b/elm/Types.elm @@ -0,0 +1,27 @@ +module Types exposing (MalExpr(..), keywordPrefix) + +import Array exposing (Array) +import Dict exposing (Dict) + + +type MalExpr + = MalNil + | MalBool Bool + | MalInt Int + | MalString String + | MalKeyword String + | MalSymbol String + | MalList (List MalExpr) + | MalVector (Array MalExpr) + | MalMap (Dict String MalExpr) + + +{-| Keywords are prefixed by this char for usage in a MalMap. +Elm doesn't support user defined types as keys in a Dict. + +The unicode char is: '\x029e' + +-} +keywordPrefix : Char +keywordPrefix = + 'ʞ' diff --git a/elm/Utils.elm b/elm/Utils.elm new file mode 100644 index 0000000000..809954a1a7 --- /dev/null +++ b/elm/Utils.elm @@ -0,0 +1,73 @@ +module Utils + exposing + ( decodeString + , encodeString + , makeCall + , wrap + , maybeToList + ) + +import Regex exposing (replace, regex, HowMany(All)) +import Types exposing (MalExpr(..)) + + +decodeString : String -> String +decodeString = + let + unescape { match } = + case match of + "\\n" -> + "\n" + + "\\\"" -> + "\"" + + "\\\\" -> + "\\" + + other -> + other + in + String.slice 1 -1 + >> replace All (regex "\\\\[\\\"\\\\n]") unescape + + +encodeString : String -> String +encodeString = + let + escape { match } = + case match of + "\n" -> + "\\n" + + "\"" -> + "\\\"" + + "\\" -> + "\\\\" + + other -> + other + in + wrap "\"" "\"" + << replace All (regex "[\\n\\\"\\\\]") escape + + +makeCall : String -> List MalExpr -> MalExpr +makeCall symbol args = + MalList <| (MalSymbol symbol) :: args + + +wrap : String -> String -> String -> String +wrap prefix suffix str = + prefix ++ str ++ suffix + + +maybeToList : Maybe a -> List a +maybeToList m = + case m of + Just x -> + [ x ] + + Nothing -> + [] diff --git a/elm/elm-package.json b/elm/elm-package.json index bec8632f38..5ba0b8cd82 100644 --- a/elm/elm-package.json +++ b/elm/elm-package.json @@ -8,6 +8,7 @@ ], "exposed-modules": [], "dependencies": { + "Bogdanp/elm-combine": "3.1.1 <= v < 4.0.0", "elm-lang/core": "5.1.1 <= v < 6.0.0" }, "elm-version": "0.18.0 <= v < 0.19.0" diff --git a/elm/step1_read_print.elm b/elm/step1_read_print.elm new file mode 100644 index 0000000000..0acd76fcdd --- /dev/null +++ b/elm/step1_read_print.elm @@ -0,0 +1,111 @@ +port module Main exposing (..) + +import Platform exposing (programWithFlags) +import Json.Decode +import Types exposing (MalExpr(..)) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList) + + +-- Output a string to stdout + + +port output : String -> Cmd msg + + + +-- Read a line from the stdin + + +port readLine : String -> Cmd msg + + + +-- Received a line from the stdin (in response to readLine). + + +port input : (Maybe String -> msg) -> Sub msg + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = \model -> input Input + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + } + + +type Msg + = Input (Maybe String) + + +init : Flags -> ( Model, Cmd Msg ) +init flags = + ( flags, readLine prompt ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Just line) -> + let + outputCmd = + rep line |> Maybe.map output + + cmds = + maybeToList outputCmd ++ [ readLine prompt ] + in + ( model + , Cmd.batch cmds + ) + + Input Nothing -> + ( model, Cmd.none ) + + +prompt : String +prompt = + "user> " + + +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : MalExpr -> MalExpr +eval ast = + ast + + +print : MalExpr -> String +print = + printString True + + +rep : String -> Maybe String +rep = + let + formatResult result = + case result of + Ok optStr -> + optStr + + Err msg -> + Just msg + in + readString + >> Result.map (Maybe.map (eval >> print)) + >> formatResult From 4e84165f907428541f90e40d7061e987ac23a809 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Mon, 5 Jun 2017 12:23:33 +0200 Subject: [PATCH 0028/1998] Elm: step 2 --- elm/Makefile | 6 +- elm/Printer.elm | 3 + elm/Reader.elm | 2 +- elm/Types.elm | 1 + elm/Utils.elm | 14 +++ elm/step1_read_print.elm | 33 +++-- elm/step2_eval.elm | 260 +++++++++++++++++++++++++++++++++++++++ 7 files changed, 303 insertions(+), 16 deletions(-) create mode 100644 elm/step2_eval.elm diff --git a/elm/Makefile b/elm/Makefile index 9dba7758bc..ef0bc9249d 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,6 +1,6 @@ SOURCES_BASE = #reader.ls printer.ls env.ls core.ls utils.ls -SOURCES_STEPS = step0_repl.elm step1_read_print.elm #step2_eval.ls \ - step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ +SOURCES_STEPS = step0_repl.elm step1_read_print.elm step2_eval.elm \ + #step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) @@ -21,7 +21,7 @@ elm_packages: $(ELM) make $(@:%.js=%.elm) --output $@ step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm -# step2_eval.js: utils.js reader.js printer.js +step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm # step3_env.js: utils.js reader.js printer.js env.js # step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js # step5_tco.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/Printer.elm b/elm/Printer.elm index 5667d53a2a..4d7f8fe01b 100644 --- a/elm/Printer.elm +++ b/elm/Printer.elm @@ -39,6 +39,9 @@ printString readably ast = MalMap map -> printMap readably map + MalFunction _ -> + "#" + printRawString : Bool -> String -> String printRawString readably str = diff --git a/elm/Reader.elm b/elm/Reader.elm index bcd934486f..11c4e5cf4e 100644 --- a/elm/Reader.elm +++ b/elm/Reader.elm @@ -180,7 +180,7 @@ formatError ms stream = location = currentLocation stream in - "Parse error: expected a: " + "Parse error: " ++ String.join ", " ms ++ " " ++ "(at " diff --git a/elm/Types.elm b/elm/Types.elm index 766457e756..32c002ccbd 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -14,6 +14,7 @@ type MalExpr | MalList (List MalExpr) | MalVector (Array MalExpr) | MalMap (Dict String MalExpr) + | MalFunction (List MalExpr -> Result String MalExpr) {-| Keywords are prefixed by this char for usage in a MalMap. diff --git a/elm/Utils.elm b/elm/Utils.elm index 809954a1a7..4097becff0 100644 --- a/elm/Utils.elm +++ b/elm/Utils.elm @@ -5,6 +5,7 @@ module Utils , makeCall , wrap , maybeToList + , zip ) import Regex exposing (replace, regex, HowMany(All)) @@ -71,3 +72,16 @@ maybeToList m = Nothing -> [] + + +zip : List a -> List b -> List ( a, b ) +zip a b = + case ( a, b ) of + ( [], _ ) -> + [] + + ( _, [] ) -> + [] + + ( x :: xs, y :: ys ) -> + ( x, y ) :: zip xs ys diff --git a/elm/step1_read_print.elm b/elm/step1_read_print.elm index 0acd76fcdd..285d447525 100644 --- a/elm/step1_read_print.elm +++ b/elm/step1_read_print.elm @@ -1,30 +1,29 @@ port module Main exposing (..) -import Platform exposing (programWithFlags) +{-| Your IDE might complain that the Json.Decode import +is not used, but it is. Without it you'll get a runtime exception. +-} + import Json.Decode +import Platform exposing (programWithFlags) import Types exposing (MalExpr(..)) import Reader exposing (readString) import Printer exposing (printString) import Utils exposing (maybeToList) --- Output a string to stdout - - +{-| Output a string to stdout +-} port output : String -> Cmd msg - --- Read a line from the stdin - - +{-| Read a line from the stdin +-} port readLine : String -> Cmd msg - --- Received a line from the stdin (in response to readLine). - - +{-| Received a line from the stdin (in response to readLine). +-} port input : (Maybe String -> msg) -> Sub msg @@ -64,6 +63,7 @@ update msg model = outputCmd = rep line |> Maybe.map output + -- Don't print output when 'rep' returns Nothing. cmds = maybeToList outputCmd ++ [ readLine prompt ] in @@ -80,6 +80,13 @@ prompt = "user> " +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} read : String -> Result String (Maybe MalExpr) read = readString @@ -95,6 +102,8 @@ print = printString True +{-| Read-Eval-Print +-} rep : String -> Maybe String rep = let diff --git a/elm/step2_eval.elm b/elm/step2_eval.elm new file mode 100644 index 0000000000..b12a93f81f --- /dev/null +++ b/elm/step2_eval.elm @@ -0,0 +1,260 @@ +port module Main exposing (..) + +{-| Your IDE might complain that the Json.Decode import +is not used, but it is. Without it you'll get a runtime exception. +-} + +import Json.Decode +import Platform exposing (programWithFlags) +import Types exposing (MalExpr(..)) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip) +import Dict exposing (Dict) +import Tuple exposing (mapFirst) +import Array + + +{-| Output a string to stdout +-} +port output : String -> Cmd msg + + +{-| Read a line from the stdin +-} +port readLine : String -> Cmd msg + + +{-| Received a line from the stdin (in response to readLine). +-} +port input : (Maybe String -> msg) -> Sub msg + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = \model -> input Input + } + + +type alias Flags = + { args : List String + } + + +type alias ReplEnv = + Dict String MalExpr + + +type alias Model = + { args : List String + , env : ReplEnv + } + + +type Msg + = Input (Maybe String) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + ( { args = args, env = initReplEnv }, readLine prompt ) + + +initReplEnv : ReplEnv +initReplEnv = + let + binaryOp fn args = + case args of + [ MalInt x, MalInt y ] -> + Ok <| MalInt (fn x y) + + _ -> + Err "unsupported arguments" + in + Dict.fromList + [ ( "+", MalFunction <| binaryOp (+) ) + , ( "-", MalFunction <| binaryOp (-) ) + , ( "*", MalFunction <| binaryOp (*) ) + , ( "/", MalFunction <| binaryOp (//) ) + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Just line) -> + case rep model.env line of + Nothing -> + ( model, readLine prompt ) + + Just ( result, newEnv ) -> + ( { model | env = newEnv } + , Cmd.batch + [ makeOutput result + , readLine prompt + ] + ) + + Input Nothing -> + ( model, Cmd.none ) + + +makeOutput : Result String String -> Cmd msg +makeOutput result = + output <| + case result of + Ok str -> + str + + Err msg -> + "ERR:" ++ msg + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : ReplEnv -> MalExpr -> ( Result String MalExpr, ReplEnv ) +eval env ast = + case ast of + MalList [] -> + ( Ok ast, env ) + + MalList list -> + case evalList env list [] of + ( Ok newList, newEnv ) -> + case newList of + [] -> + ( Err "can't happen", newEnv ) + + (MalFunction fn) :: args -> + ( fn args, newEnv ) + + fn :: _ -> + ( Err ((printString True fn) ++ " is not a function"), newEnv ) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + _ -> + evalAst env ast + + +evalAst : ReplEnv -> MalExpr -> ( Result String MalExpr, ReplEnv ) +evalAst env ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + case Dict.get sym env of + Just val -> + ( Ok val, env ) + + Nothing -> + ( Err "symbol not found", env ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList env list [] + |> mapFirst (Result.map MalList) + + MalVector vec -> + evalList env (Array.toList vec) [] + |> mapFirst (Result.map (Array.fromList >> MalVector)) + + MalMap map -> + evalList env (Dict.values map) [] + |> mapFirst + (Result.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + ) + + _ -> + ( Ok ast, env ) + + +evalList : ReplEnv -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), ReplEnv ) +evalList env list acc = + case list of + [] -> + ( Ok (List.reverse acc), env ) + + x :: rest -> + case eval env x of + ( Ok val, newEnv ) -> + evalList newEnv rest (val :: acc) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + +{-| Try to map a list with a fn that can return a Err. + +Maps the list from left to right. As soon as a error +occurs it will not process any more elements and return +the error. + +-} +tryMapList : (a -> Result e b) -> List a -> Result e (List b) +tryMapList fn list = + let + go x = + Result.andThen + (\acc -> + case fn x of + Ok val -> + Ok (val :: acc) + + Err msg -> + Err msg + ) + in + List.foldl go (Ok []) list + |> Result.map List.reverse + + +print : MalExpr -> String +print = + printString True + + +{-| Read-Eval-Print. rep returns: + +Nothing -> if an empty string is read (ws/comments) +Just ((Ok out), newEnv) -> input has been evaluated. +Just ((Err msg), env) -> error parsing or evaluating. + +-} +rep : ReplEnv -> String -> Maybe ( Result String String, ReplEnv ) +rep env input = + let + evalPrint = + eval env >> mapFirst (Result.map print) + in + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just ( Err msg, env ) + + Ok (Just ast) -> + Just (evalPrint ast) From 4cb2c1e49d234f1333d9a70ecc0150ef10c5119b Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Mon, 5 Jun 2017 13:30:12 +0200 Subject: [PATCH 0029/1998] Elm: step 3 --- elm/Env.elm | 33 +++++ elm/Makefile | 5 +- elm/step3_env.elm | 319 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 355 insertions(+), 2 deletions(-) create mode 100644 elm/Env.elm create mode 100644 elm/step3_env.elm diff --git a/elm/Env.elm b/elm/Env.elm new file mode 100644 index 0000000000..31f1d71b58 --- /dev/null +++ b/elm/Env.elm @@ -0,0 +1,33 @@ +module Env exposing (Env, make, set, get) + +import Types exposing (MalExpr(..)) +import Dict exposing (Dict) + + +type Env + = Env + { outer : Maybe Env + , data : Dict String MalExpr + } + + +make : Maybe Env -> Env +make outer = + Env { outer = outer, data = Dict.empty } + + +set : String -> MalExpr -> Env -> Env +set name expr (Env env) = + Env { env | data = Dict.insert name expr env.data } + + +get : String -> Env -> Result String MalExpr +get name ((Env { outer, data }) as env) = + case Dict.get name data of + Just val -> + Ok val + + Nothing -> + outer + |> Maybe.map (get name) + |> Maybe.withDefault (Err "symbol not found") diff --git a/elm/Makefile b/elm/Makefile index ef0bc9249d..05b4f13786 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,6 +1,7 @@ SOURCES_BASE = #reader.ls printer.ls env.ls core.ls utils.ls SOURCES_STEPS = step0_repl.elm step1_read_print.elm step2_eval.elm \ - #step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ + step3_env.elm # \ + step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) @@ -22,7 +23,7 @@ elm_packages: step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm -# step3_env.js: utils.js reader.js printer.js env.js +step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm # step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js # step5_tco.js: utils.js reader.js printer.js env.js core.js # step6_file.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/step3_env.elm b/elm/step3_env.elm new file mode 100644 index 0000000000..99958dc097 --- /dev/null +++ b/elm/step3_env.elm @@ -0,0 +1,319 @@ +port module Main exposing (..) + +{-| Your IDE might complain that the Json.Decode import +is not used, but it is. Without it you'll get a runtime exception. +-} + +import Json.Decode +import Platform exposing (programWithFlags) +import Types exposing (MalExpr(..)) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip) +import Dict exposing (Dict) +import Tuple exposing (mapFirst, mapSecond) +import Array +import Env exposing (Env) + + +{-| Output a string to stdout +-} +port output : String -> Cmd msg + + +{-| Read a line from the stdin +-} +port readLine : String -> Cmd msg + + +{-| Received a line from the stdin (in response to readLine). +-} +port input : (Maybe String -> msg) -> Sub msg + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = \model -> input Input + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + , env : Env + } + + +type Msg + = Input (Maybe String) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + ( { args = args, env = initReplEnv }, readLine prompt ) + + +initReplEnv : Env +initReplEnv = + let + binaryOp fn args = + case args of + [ MalInt x, MalInt y ] -> + Ok <| MalInt (fn x y) + + _ -> + Err "unsupported arguments" + in + Env.make Nothing + |> Env.set "+" (MalFunction <| binaryOp (+)) + |> Env.set "-" (MalFunction <| binaryOp (-)) + |> Env.set "*" (MalFunction <| binaryOp (*)) + |> Env.set "/" (MalFunction <| binaryOp (//)) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Just line) -> + case rep model.env line of + Nothing -> + ( model, readLine prompt ) + + Just ( result, newEnv ) -> + ( { model | env = newEnv } + , Cmd.batch + [ makeOutput result + , readLine prompt + ] + ) + + Input Nothing -> + ( model, Cmd.none ) + + +makeOutput : Result String String -> Cmd msg +makeOutput result = + output <| + case result of + Ok str -> + str + + Err msg -> + "ERR:" ++ msg + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : Env -> MalExpr -> ( Result String MalExpr, Env ) +eval env ast = + case ast of + MalList [] -> + ( Ok ast, env ) + + MalList ((MalSymbol "def!") :: args) -> + evalDef env args + + MalList ((MalSymbol "let*") :: args) -> + evalLet env args + + MalList list -> + case evalList env list [] of + ( Ok newList, newEnv ) -> + case newList of + [] -> + ( Err "can't happen", newEnv ) + + (MalFunction fn) :: args -> + ( fn args, newEnv ) + + fn :: _ -> + ( Err ((printString True fn) ++ " is not a function"), newEnv ) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + _ -> + evalAst env ast + + +evalAst : Env -> MalExpr -> ( Result String MalExpr, Env ) +evalAst env ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + case Env.get sym env of + Ok val -> + ( Ok val, env ) + + Err msg -> + ( Err msg, env ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList env list [] + |> mapFirst (Result.map MalList) + + MalVector vec -> + evalList env (Array.toList vec) [] + |> mapFirst (Result.map (Array.fromList >> MalVector)) + + MalMap map -> + evalList env (Dict.values map) [] + |> mapFirst + (Result.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + ) + + _ -> + ( Ok ast, env ) + + +evalList : Env -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), Env ) +evalList env list acc = + case list of + [] -> + ( Ok (List.reverse acc), env ) + + x :: rest -> + case eval env x of + ( Ok val, newEnv ) -> + evalList newEnv rest (val :: acc) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + +evalDef : Env -> List MalExpr -> ( Result String MalExpr, Env ) +evalDef env args = + case args of + [ MalSymbol name, uneValue ] -> + case eval env uneValue of + ( Ok value, newEnv ) -> + ( Ok value, Env.set name value newEnv ) + + err -> + err + + _ -> + ( Err "def! expected two args: name and value", env ) + + +evalLet : Env -> List MalExpr -> ( Result String MalExpr, Env ) +evalLet env args = + let + evalBinds env binds = + case binds of + (MalSymbol name) :: expr :: rest -> + case eval env expr of + ( Ok value, newEnv ) -> + let + newEnv = + Env.set name value env + in + if List.isEmpty rest then + Ok newEnv + else + evalBinds newEnv rest + + ( Err msg, _ ) -> + Err msg + + _ -> + Err "let* expected an even number of binds (symbol expr ..)" + + go binds body = + case evalBinds (Env.make (Just env)) binds of + Ok newEnv -> + mapSecond (\_ -> env) (eval newEnv body) + + Err msg -> + ( Err msg, env ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + ( Err "let* expected two args: binds and a body", env ) + + +{-| Try to map a list with a fn that can return a Err. + +Maps the list from left to right. As soon as a error +occurs it will not process any more elements and return +the error. + +-} +tryMapList : (a -> Result e b) -> List a -> Result e (List b) +tryMapList fn list = + let + go x = + Result.andThen + (\acc -> + case fn x of + Ok val -> + Ok (val :: acc) + + Err msg -> + Err msg + ) + in + List.foldl go (Ok []) list + |> Result.map List.reverse + + +print : MalExpr -> String +print = + printString True + + +{-| Read-Eval-Print. rep returns: + +Nothing -> if an empty string is read (ws/comments) +Just ((Ok out), newEnv) -> input has been evaluated. +Just ((Err msg), env) -> error parsing or evaluating. + +-} +rep : Env -> String -> Maybe ( Result String String, Env ) +rep env input = + let + evalPrint = + eval env >> mapFirst (Result.map print) + in + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just ( Err msg, env ) + + Ok (Just ast) -> + Just (evalPrint ast) From c792f15ef800868dc0abe1f89a11dc453d3e4420 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Thu, 8 Jun 2017 19:19:27 +0200 Subject: [PATCH 0030/1998] Elm: part 4 halfway finished. Hello Monads. --- elm/Core.elm | 121 ++++++++++++ elm/Env.elm | 11 +- elm/Eval.elm | 90 +++++++++ elm/IO.elm | 53 ++++++ elm/Makefile | 18 +- elm/Types.elm | 39 +++- elm/Utils.elm | 14 ++ elm/bootstrap.js | 7 +- elm/step0_repl.elm | 36 ++-- elm/step1_read_print.elm | 56 ++---- elm/step2_eval.elm | 57 ++---- elm/step3_env.elm | 56 ++---- elm/step4_if_fn_do.elm | 395 +++++++++++++++++++++++++++++++++++++++ 13 files changed, 799 insertions(+), 154 deletions(-) create mode 100644 elm/Core.elm create mode 100644 elm/Eval.elm create mode 100644 elm/IO.elm create mode 100644 elm/step4_if_fn_do.elm diff --git a/elm/Core.elm b/elm/Core.elm new file mode 100644 index 0000000000..b24c3549b1 --- /dev/null +++ b/elm/Core.elm @@ -0,0 +1,121 @@ +module Core exposing (..) + +import Types exposing (MalExpr(..), Eval, Env) +import Env +import Eval +import Printer exposing (printString) +import Array +import IO exposing (IO(..)) + + +ns : Env +ns = + let + binaryOp fn retType args = + case args of + [ MalInt x, MalInt y ] -> + Eval.succeed (retType (fn x y)) + + _ -> + Eval.fail "unsupported arguments" + + {- list -} + list = + Eval.succeed << MalList + + {- list? -} + isList args = + case args of + [ MalList _ ] -> + Eval.succeed (MalBool True) + + _ -> + Eval.succeed (MalBool False) + + {- empty? -} + isEmpty args = + case args of + [ MalList list ] -> + Eval.succeed <| MalBool (List.isEmpty list) + + [ MalVector vec ] -> + Eval.succeed <| MalBool (Array.isEmpty vec) + + _ -> + Eval.fail "unsupported arguments" + + {- count -} + count args = + case args of + [ MalList list ] -> + Eval.succeed <| MalInt (List.length list) + + [ MalVector vec ] -> + Eval.succeed <| MalInt (Array.length vec) + + _ -> + Eval.fail "unsupported arguments" + + {- = -} + equals args = + case args of + [ a, b ] -> + Eval.succeed <| MalBool (a == b) + + _ -> + Eval.fail "unsupported arguments" + + {- pr-str -} + prStr = + List.map (printString True) + >> String.join " " + >> MalString + >> Eval.succeed + + {- str -} + str = + List.map (printString False) + >> String.join "" + >> MalString + >> Eval.succeed + + writeLine str = + Eval.io (IO.writeLine str) + (\msg -> + case msg of + LineWritten -> + -- TODO need caller continuation here... + Eval.succeed MalNil + + _ -> + Eval.fail "wrong IO, expected LineWritten" + ) + + prn = + List.map (printString True) + >> String.join " " + >> writeLine + + println = + List.map (printString False) + >> String.join " " + >> writeLine + in + Env.make Nothing + |> Env.set "+" (MalFunction <| binaryOp (+) MalInt) + |> Env.set "-" (MalFunction <| binaryOp (-) MalInt) + |> Env.set "*" (MalFunction <| binaryOp (*) MalInt) + |> Env.set "/" (MalFunction <| binaryOp (//) MalInt) + |> Env.set "<" (MalFunction <| binaryOp (<) MalBool) + |> Env.set ">" (MalFunction <| binaryOp (>) MalBool) + |> Env.set "<=" (MalFunction <| binaryOp (<=) MalBool) + |> Env.set ">=" (MalFunction <| binaryOp (>=) MalBool) + |> Env.set "list" (MalFunction list) + |> Env.set "list?" (MalFunction isList) + |> Env.set "empty?" (MalFunction isEmpty) + |> Env.set "count" (MalFunction count) + |> Env.set "=" (MalFunction equals) + |> Env.set "pr-str" (MalFunction prStr) + |> Env.set "str" (MalFunction str) + |> Env.set "prn" (MalFunction prn) + |> Env.set "println" (MalFunction println) diff --git a/elm/Env.elm b/elm/Env.elm index 31f1d71b58..6240c837dc 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -1,16 +1,9 @@ -module Env exposing (Env, make, set, get) +module Env exposing (make, set, get) -import Types exposing (MalExpr(..)) +import Types exposing (MalExpr(..), Env(..)) import Dict exposing (Dict) -type Env - = Env - { outer : Maybe Env - , data : Dict String MalExpr - } - - make : Maybe Env -> Env make outer = Env { outer = outer, data = Dict.empty } diff --git a/elm/Eval.elm b/elm/Eval.elm new file mode 100644 index 0000000000..8ade773a1f --- /dev/null +++ b/elm/Eval.elm @@ -0,0 +1,90 @@ +module Eval exposing (..) + +import Types exposing (..) +import IO exposing (IO) + + +apply : Eval a -> EvalState -> EvalContext a +apply (Eval f) state = + f state + + +run : EvalState -> Eval a -> EvalContext a +run state e = + apply e state + + +withState : (EvalState -> Eval a) -> Eval a +withState f = + Eval <| + \state -> + apply (f state) state + + +putState : EvalState -> Eval () +putState state = + Eval <| + \_ -> + apply (succeed ()) state + + +modifyState : (EvalState -> EvalState) -> Eval () +modifyState f = + Eval <| + \state -> + apply (succeed ()) (f state) + + +succeed : a -> Eval a +succeed res = + Eval <| + \state -> + ( state, EvalOk res ) + + +io : Cmd Msg -> (IO -> Eval a) -> Eval a +io cmd cont = + Eval <| + \state -> + ( state, EvalIO cmd cont ) + + +map : (a -> b) -> Eval a -> Eval b +map f e = + Eval <| + \state -> + case apply e state of + ( state, EvalOk res ) -> + ( state, EvalOk (f res) ) + + ( state, EvalErr msg ) -> + ( state, EvalErr msg ) + + ( state, EvalIO cmd cont ) -> + ( state, EvalIO cmd (cont >> map f) ) + + +andThen : (a -> Eval b) -> Eval a -> Eval b +andThen f e = + Eval <| + \state -> + case apply e state of + ( state, EvalOk res ) -> + apply (f res) state + + ( state, EvalErr msg ) -> + ( state, EvalErr msg ) + + ( state, EvalIO cmd cont ) -> + ( state, EvalIO cmd (cont >> andThen f) ) + + + +-- Debug.log "wrapping EvalIO" ( state, EvalIO cmd cont ) + + +fail : String -> Eval a +fail msg = + Eval <| + \state -> + ( state, EvalErr msg ) diff --git a/elm/IO.elm b/elm/IO.elm new file mode 100644 index 0000000000..5afd3d7d27 --- /dev/null +++ b/elm/IO.elm @@ -0,0 +1,53 @@ +port module IO + exposing + ( IO(..) + , writeLine + , readLine + , input + , decodeIO + ) + +import Json.Decode exposing (..) + + +{-| Output a string to stdout +-} +port writeLine : String -> Cmd msg + + +{-| Read a line from the stdin +-} +port readLine : String -> Cmd msg + + +{-| Received a response for a command. +-} +port input : (Value -> msg) -> Sub msg + + +type IO + = LineRead (Maybe String) + | LineWritten + + +decodeIO : Decoder IO +decodeIO = + field "tag" string + |> andThen decodeTag + + +decodeTag : String -> Decoder IO +decodeTag tag = + case tag of + "lineRead" -> + field "line" (nullable string) + |> map LineRead + + "lineWritten" -> + succeed LineWritten + + _ -> + fail <| + "Trying to decode IO, but tag " + ++ tag + ++ " is not supported." diff --git a/elm/Makefile b/elm/Makefile index 05b4f13786..cfee1eec08 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,10 +1,10 @@ -SOURCES_BASE = #reader.ls printer.ls env.ls core.ls utils.ls -SOURCES_STEPS = step0_repl.elm step1_read_print.elm step2_eval.elm \ - step3_env.elm # \ - step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ - step8_macros.ls step9_try.ls stepA_mal.ls +SOURCES_BASE = Reader.elm Printer.elm Utils.elm Types.elm Env.elm \ + Core.elm Eval.elm IO.elm +SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm #step1_read_print.elm step2_eval.elm \ + step3_env.elm step4_if_fn_do.elm #step5_tco.ls step6_file.ls \ + step7_quote.ls step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls -SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) +SOURCES = $(SOURCES_STEPS) BINS = $(SOURCES:%.elm=%.js) @@ -22,9 +22,9 @@ elm_packages: $(ELM) make $(@:%.js=%.elm) --output $@ step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm -step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm -step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm -# step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js +#step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm +#step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm +step4_if_fn_do.js: $(SOURCES_BASE) # step5_tco.js: utils.js reader.js printer.js env.js core.js # step6_file.js: utils.js reader.js printer.js env.js core.js # step7_quote.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/Types.elm b/elm/Types.elm index 32c002ccbd..5687ff22d4 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -1,7 +1,42 @@ -module Types exposing (MalExpr(..), keywordPrefix) +module Types exposing (..) import Array exposing (Array) import Dict exposing (Dict) +import IO exposing (IO) + + +type Msg + = Input (Result String IO) + + +type Env + = Env + { outer : Maybe Env + , data : Dict String MalExpr + } + + +type alias EvalState = + { env : Env + } + + +type EvalResult res + = EvalErr String + | EvalOk res + | EvalIO (Cmd Msg) (IO -> Eval res) + + +type alias EvalContext res = + ( EvalState, EvalResult res ) + + +type alias EvalFn res = + EvalState -> EvalContext res + + +type Eval res + = Eval (EvalFn res) type MalExpr @@ -14,7 +49,7 @@ type MalExpr | MalList (List MalExpr) | MalVector (Array MalExpr) | MalMap (Dict String MalExpr) - | MalFunction (List MalExpr -> Result String MalExpr) + | MalFunction (List MalExpr -> Eval MalExpr) {-| Keywords are prefixed by this char for usage in a MalMap. diff --git a/elm/Utils.elm b/elm/Utils.elm index 4097becff0..571e4bbcb8 100644 --- a/elm/Utils.elm +++ b/elm/Utils.elm @@ -6,6 +6,7 @@ module Utils , wrap , maybeToList , zip + , last ) import Regex exposing (replace, regex, HowMany(All)) @@ -85,3 +86,16 @@ zip a b = ( x :: xs, y :: ys ) -> ( x, y ) :: zip xs ys + + +last : List a -> Maybe a +last list = + case list of + [] -> + Nothing + + [ x ] -> + Just x + + x :: xs -> + last xs diff --git a/elm/bootstrap.js b/elm/bootstrap.js index 6ec5f3048c..e91fc5c06f 100644 --- a/elm/bootstrap.js +++ b/elm/bootstrap.js @@ -9,12 +9,13 @@ var app = mod.Main.worker({ args: args.slice(1) }); -// Hook up the output and readLine ports of the app. -app.ports.output.subscribe(function(line) { +// Hook up the writeLine and readLine ports of the app. +app.ports.writeLine.subscribe(function(line) { console.log(line); + app.ports.input.send({"tag": "lineWritten"}); }); app.ports.readLine.subscribe(function(prompt) { var line = readline.readline(prompt); - app.ports.input.send(line); + app.ports.input.send({"tag": "lineRead", "line": line}); }); diff --git a/elm/step0_repl.elm b/elm/step0_repl.elm index b7960c8dda..41596b429a 100644 --- a/elm/step0_repl.elm +++ b/elm/step0_repl.elm @@ -1,16 +1,8 @@ port module Main exposing (..) +import IO exposing (..) +import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) -import Json.Decode - - -port output : String -> Cmd msg - - -port readLine : String -> Cmd msg - - -port input : (Maybe String -> msg) -> Sub msg main : Program Flags Model Msg @@ -18,7 +10,8 @@ main = programWithFlags { init = init , update = update - , subscriptions = \model -> input Input + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) } @@ -33,7 +26,7 @@ type alias Model = type Msg - = Input (Maybe String) + = Input (Result String IO) init : Flags -> ( Model, Cmd Msg ) @@ -44,17 +37,18 @@ init flags = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of - Input (Just line) -> - ( model - , Cmd.batch - [ output (rep line) - , readLine prompt - ] - ) - - Input Nothing -> + Input (Ok (LineRead (Just line))) -> + ( model, writeLine (rep line) ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + prompt : String prompt = diff --git a/elm/step1_read_print.elm b/elm/step1_read_print.elm index 285d447525..ff7c09a6a8 100644 --- a/elm/step1_read_print.elm +++ b/elm/step1_read_print.elm @@ -1,10 +1,7 @@ port module Main exposing (..) -{-| Your IDE might complain that the Json.Decode import -is not used, but it is. Without it you'll get a runtime exception. --} - -import Json.Decode +import IO exposing (..) +import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) import Types exposing (MalExpr(..)) import Reader exposing (readString) @@ -12,27 +9,13 @@ import Printer exposing (printString) import Utils exposing (maybeToList) -{-| Output a string to stdout --} -port output : String -> Cmd msg - - -{-| Read a line from the stdin --} -port readLine : String -> Cmd msg - - -{-| Received a line from the stdin (in response to readLine). --} -port input : (Maybe String -> msg) -> Sub msg - - main : Program Flags Model Msg main = programWithFlags { init = init , update = update - , subscriptions = \model -> input Input + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) } @@ -47,7 +30,7 @@ type alias Model = type Msg - = Input (Maybe String) + = Input (Result String IO) init : Flags -> ( Model, Cmd Msg ) @@ -58,22 +41,23 @@ init flags = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of - Input (Just line) -> - let - outputCmd = - rep line |> Maybe.map output - - -- Don't print output when 'rep' returns Nothing. - cmds = - maybeToList outputCmd ++ [ readLine prompt ] - in - ( model - , Cmd.batch cmds - ) - - Input Nothing -> + Input (Ok (LineRead (Just line))) -> + case rep line of + Just out -> + ( model, writeLine out ) + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + prompt : String prompt = diff --git a/elm/step2_eval.elm b/elm/step2_eval.elm index b12a93f81f..25d83fd7c5 100644 --- a/elm/step2_eval.elm +++ b/elm/step2_eval.elm @@ -1,10 +1,7 @@ port module Main exposing (..) -{-| Your IDE might complain that the Json.Decode import -is not used, but it is. Without it you'll get a runtime exception. --} - -import Json.Decode +import IO exposing (..) +import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) import Types exposing (MalExpr(..)) import Reader exposing (readString) @@ -15,27 +12,13 @@ import Tuple exposing (mapFirst) import Array -{-| Output a string to stdout --} -port output : String -> Cmd msg - - -{-| Read a line from the stdin --} -port readLine : String -> Cmd msg - - -{-| Received a line from the stdin (in response to readLine). --} -port input : (Maybe String -> msg) -> Sub msg - - main : Program Flags Model Msg main = programWithFlags { init = init , update = update - , subscriptions = \model -> input Input + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) } @@ -55,7 +38,7 @@ type alias Model = type Msg - = Input (Maybe String) + = Input (Result String IO) init : Flags -> ( Model, Cmd Msg ) @@ -85,32 +68,32 @@ initReplEnv = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of - Input (Just line) -> + Input (Ok (LineRead (Just line))) -> case rep model.env line of Nothing -> ( model, readLine prompt ) Just ( result, newEnv ) -> - ( { model | env = newEnv } - , Cmd.batch - [ makeOutput result - , readLine prompt - ] - ) + ( { model | env = newEnv }, writeLine (makeOutput result) ) - Input Nothing -> + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + -makeOutput : Result String String -> Cmd msg +makeOutput : Result String String -> String makeOutput result = - output <| - case result of - Ok str -> - str + case result of + Ok str -> + str - Err msg -> - "ERR:" ++ msg + Err msg -> + "ERR:" ++ msg prompt : String diff --git a/elm/step3_env.elm b/elm/step3_env.elm index 99958dc097..1f5c44ba5f 100644 --- a/elm/step3_env.elm +++ b/elm/step3_env.elm @@ -1,10 +1,7 @@ port module Main exposing (..) -{-| Your IDE might complain that the Json.Decode import -is not used, but it is. Without it you'll get a runtime exception. --} - -import Json.Decode +import IO exposing (..) +import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) import Types exposing (MalExpr(..)) import Reader exposing (readString) @@ -16,27 +13,12 @@ import Array import Env exposing (Env) -{-| Output a string to stdout --} -port output : String -> Cmd msg - - -{-| Read a line from the stdin --} -port readLine : String -> Cmd msg - - -{-| Received a line from the stdin (in response to readLine). --} -port input : (Maybe String -> msg) -> Sub msg - - main : Program Flags Model Msg main = programWithFlags { init = init , update = update - , subscriptions = \model -> input Input + , subscriptions = \model -> input (decodeValue decodeIO >> Input) } @@ -52,7 +34,7 @@ type alias Model = type Msg - = Input (Maybe String) + = Input (Result String IO) init : Flags -> ( Model, Cmd Msg ) @@ -81,32 +63,32 @@ initReplEnv = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of - Input (Just line) -> + Input (Ok (LineRead (Just line))) -> case rep model.env line of Nothing -> ( model, readLine prompt ) Just ( result, newEnv ) -> - ( { model | env = newEnv } - , Cmd.batch - [ makeOutput result - , readLine prompt - ] - ) + ( { model | env = newEnv }, writeLine (makeOutput result) ) - Input Nothing -> + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + -makeOutput : Result String String -> Cmd msg +makeOutput : Result String String -> String makeOutput result = - output <| - case result of - Ok str -> - str + case result of + Ok str -> + str - Err msg -> - "ERR:" ++ msg + Err msg -> + "ERR:" ++ msg prompt : String diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm new file mode 100644 index 0000000000..db67ae16c0 --- /dev/null +++ b/elm/step4_if_fn_do.elm @@ -0,0 +1,395 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + , env : Env + , cont : Maybe (IO -> Eval MalExpr) + } + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + ( { args = args + , env = Core.ns + , cont = Nothing + } + , readLine prompt + ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model.cont of + Nothing -> + normalUpdate msg model + + Just cont -> + case msg of + Input (Ok io) -> + run { model | cont = Nothing } (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +normalUpdate : Msg -> Model -> ( Model, Cmd Msg ) +normalUpdate msg model = + case msg of + Input (Ok (LineRead (Just line))) -> + rep line + |> Maybe.map (run model) + |> Maybe.withDefault (( model, readLine prompt )) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + ( model, Cmd.none ) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +run : Model -> Eval MalExpr -> ( Model, Cmd Msg ) +run model e = + case Eval.run { env = model.env } e of + ( { env }, EvalOk expr ) -> + ( { model | env = env }, writeLine (print expr) ) + + ( { env }, EvalErr msg ) -> + ( { model | env = env }, writeLine ("ERR:" ++ msg) ) + + ( { env }, EvalIO cmd cont ) -> + ( { model | cont = Just cont }, cmd ) + + +makeOutput : Result String String -> String +makeOutput result = + case result of + Ok str -> + str + + Err msg -> + "ERR:" ++ msg + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : MalExpr -> Eval MalExpr +eval ast = + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction fn) :: args -> + fn args + + fn :: _ -> + Eval.fail ((printString True fn) ++ " is not a function") + ) + + _ -> + evalAst ast + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withState + (\state -> + case Env.get sym state.env of + Ok val -> + Eval.succeed val + + Err msg -> + Eval.fail msg + ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyState + (\state -> + { state | env = Env.set name value state.env } + ) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyState (\state -> { state | env = Env.set name value state.env }) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyState (\state -> { state | env = Env.make (Just state.env) }) + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> eval body) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + let + returnLast list = + case last list of + Just value -> + Eval.succeed value + + Nothing -> + Eval.fail "do expected at least one arg" + in + evalList args + |> Eval.andThen returnLast + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + eval + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + extractSymbols list acc = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + extractSymbols rest (name :: acc) + + _ -> + Err "all binds in fn* must be a symbol" + + bindArgs env pairs = + case pairs of + [] -> + env + + ( bind, arg ) :: rest -> + bindArgs (Env.set bind arg env) rest + + makeEnv binds args env = + zip binds args + |> bindArgs (Env.make (Just env)) + in + case args of + [ MalList bindsList, body ] -> + case extractSymbols bindsList [] of + Ok binds -> + let + fn args = + if List.length args /= List.length binds then + Eval.fail <| + "function expected " + ++ (toString (List.length binds)) + ++ " arguments, got " + ++ (toString (List.length binds)) + else + -- TODO: push state and pop afterwards! + -- TODO or temporary change state? + Eval.withState + (\state -> + Eval.putState ({ state | env = makeEnv binds args state.env }) + |> Eval.andThen (\_ -> eval body) + |> Eval.andThen (\res -> Eval.putState state |> Eval.map (\_ -> res)) + ) + in + Eval.succeed (MalFunction fn) + + -- TODO explicitly pass current env + Err msg -> + Eval.fail msg + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : MalExpr -> String +print = + printString True + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just From 86fcd61dfaebb95d93a5c5396cc57004103b411b Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 11 Jun 2017 22:44:49 +0200 Subject: [PATCH 0031/1998] Elm: step 4 - fns defined in mal + var args --- elm/Core.elm | 13 +- elm/Env.elm | 184 +++++++++++++++++++++++++--- elm/Eval.elm | 20 ++-- elm/Types.elm | 20 ++-- elm/Utils.elm | 14 +++ elm/step4_if_fn_do.elm | 263 +++++++++++++++++++++++++++-------------- 6 files changed, 386 insertions(+), 128 deletions(-) diff --git a/elm/Core.elm b/elm/Core.elm index b24c3549b1..491b6b48a2 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -47,6 +47,9 @@ ns = {- count -} count args = case args of + [ MalNil ] -> + Eval.succeed (MalInt 0) + [ MalList list ] -> Eval.succeed <| MalInt (List.length list) @@ -101,7 +104,7 @@ ns = >> String.join " " >> writeLine in - Env.make Nothing + Env.global |> Env.set "+" (MalFunction <| binaryOp (+) MalInt) |> Env.set "-" (MalFunction <| binaryOp (-) MalInt) |> Env.set "*" (MalFunction <| binaryOp (*) MalInt) @@ -119,3 +122,11 @@ ns = |> Env.set "str" (MalFunction str) |> Env.set "prn" (MalFunction prn) |> Env.set "println" (MalFunction println) + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + ] diff --git a/elm/Env.elm b/elm/Env.elm index 6240c837dc..c67c2a7bed 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -1,26 +1,178 @@ -module Env exposing (make, set, get) +module Env exposing (global, push, pop, enter, leave, ref, get, set) -import Types exposing (MalExpr(..), Env(..)) +import Types exposing (MalExpr, Frame, Env) import Dict exposing (Dict) -make : Maybe Env -> Env -make outer = - Env { outer = outer, data = Dict.empty } +global : Env +global = + { frames = Dict.singleton 0 (emptyFrame Nothing) + , nextFrameId = 1 + , currentFrameId = 0 + } + + +push : Env -> Env +push env = + let + frameId = + env.nextFrameId + + newFrame = + emptyFrame (Just env.currentFrameId) + in + { currentFrameId = frameId + , frames = Dict.insert frameId newFrame env.frames + , nextFrameId = env.nextFrameId + 1 + } + + + +-- TODO Dont' return result, Debug.crash instead. + + +pop : Env -> Result String Env +pop env = + let + frameId = + env.currentFrameId + in + case Dict.get frameId env.frames of + Just currentFrame -> + case currentFrame.outerId of + Just outerId -> + Ok + { env + | currentFrameId = outerId + , frames = Dict.update frameId deref env.frames + } + + Nothing -> + Err "tried to pop global frame" + + Nothing -> + Err ("current frame " ++ (toString frameId) ++ " doesn't exist") + + +setBinds : List ( String, MalExpr ) -> Frame -> Frame +setBinds binds frame = + case binds of + [] -> + frame + + ( name, expr ) :: rest -> + setBinds rest + { frame | data = Dict.insert name expr frame.data } + + +enter : Int -> List ( String, MalExpr ) -> Env -> Env +enter parentFrameId binds env = + let + frameId = + env.nextFrameId + + newFrame = + setBinds binds (emptyFrame (Just parentFrameId)) + in + { currentFrameId = frameId + , frames = Dict.insert frameId newFrame env.frames + , nextFrameId = env.nextFrameId + 1 + } + + +leave : Int -> Env -> Env +leave orgFrameId env = + let + frameId = + env.currentFrameId + in + { env + | currentFrameId = orgFrameId + , frames = Dict.update frameId deref env.frames + } + + +{-| Increase refCnt for the current frame +-} +ref : Env -> Env +ref env = + let + incRef = + Maybe.map + (\frame -> + { frame | refCnt = frame.refCnt + 1 } + ) + + newFrames = + Dict.update env.currentFrameId incRef env.frames + in + { env | frames = newFrames } + + + +-- TODO: when disposing, deref all function's frames? +-- TODO: is that enough instead of a GC? + + +deref : Maybe Frame -> Maybe Frame +deref = + Maybe.andThen + (\frame -> + if frame.refCnt == 1 then + Nothing + else + Just { frame | refCnt = frame.refCnt - 1 } + ) + + + +-- TODO need a GC. +-- given a Env, see which frames are not reachable. +-- in MalFunction need to refer to the frameId. + + +emptyFrame : Maybe Int -> Frame +emptyFrame outerId = + { outerId = outerId + , data = Dict.empty + , refCnt = 1 + } set : String -> MalExpr -> Env -> Env -set name expr (Env env) = - Env { env | data = Dict.insert name expr env.data } +set name expr env = + let + updateFrame = + Maybe.map + (\frame -> + { frame | data = Dict.insert name expr frame.data } + ) + + frameId = + env.currentFrameId + + newFrames = + Dict.update frameId updateFrame env.frames + in + { env | frames = newFrames } get : String -> Env -> Result String MalExpr -get name ((Env { outer, data }) as env) = - case Dict.get name data of - Just val -> - Ok val - - Nothing -> - outer - |> Maybe.map (get name) - |> Maybe.withDefault (Err "symbol not found") +get name env = + let + go frameId = + case Dict.get frameId env.frames of + Nothing -> + Err "frame not found" + + Just frame -> + case Dict.get name frame.data of + Just value -> + Ok value + + Nothing -> + frame.outerId + |> Maybe.map go + |> Maybe.withDefault (Err "symbol not found") + in + go env.currentFrameId diff --git a/elm/Eval.elm b/elm/Eval.elm index 8ade773a1f..c4e043700b 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -4,32 +4,32 @@ import Types exposing (..) import IO exposing (IO) -apply : Eval a -> EvalState -> EvalContext a +apply : Eval a -> Env -> EvalContext a apply (Eval f) state = f state -run : EvalState -> Eval a -> EvalContext a +run : Env -> Eval a -> EvalContext a run state e = apply e state -withState : (EvalState -> Eval a) -> Eval a -withState f = +withEnv : (Env -> Eval a) -> Eval a +withEnv f = Eval <| \state -> apply (f state) state -putState : EvalState -> Eval () -putState state = +setEnv : Env -> Eval () +setEnv state = Eval <| \_ -> apply (succeed ()) state -modifyState : (EvalState -> EvalState) -> Eval () -modifyState f = +modifyEnv : (Env -> Env) -> Eval () +modifyEnv f = Eval <| \state -> apply (succeed ()) (f state) @@ -79,10 +79,6 @@ andThen f e = ( state, EvalIO cmd (cont >> andThen f) ) - --- Debug.log "wrapping EvalIO" ( state, EvalIO cmd cont ) - - fail : String -> Eval a fail msg = Eval <| diff --git a/elm/Types.elm b/elm/Types.elm index 5687ff22d4..04b78e5166 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -9,15 +9,17 @@ type Msg = Input (Result String IO) -type Env - = Env - { outer : Maybe Env - , data : Dict String MalExpr - } +type alias Frame = + { outerId : Maybe Int + , data : Dict String MalExpr + , refCnt : Int + } -type alias EvalState = - { env : Env +type alias Env = + { frames : Dict Int Frame + , nextFrameId : Int + , currentFrameId : Int } @@ -28,11 +30,11 @@ type EvalResult res type alias EvalContext res = - ( EvalState, EvalResult res ) + ( Env, EvalResult res ) type alias EvalFn res = - EvalState -> EvalContext res + Env -> EvalContext res type Eval res diff --git a/elm/Utils.elm b/elm/Utils.elm index 571e4bbcb8..bd226d4dc6 100644 --- a/elm/Utils.elm +++ b/elm/Utils.elm @@ -7,6 +7,7 @@ module Utils , maybeToList , zip , last + , justValues ) import Regex exposing (replace, regex, HowMany(All)) @@ -99,3 +100,16 @@ last list = x :: xs -> last xs + + +justValues : List (Maybe a) -> List a +justValues list = + case list of + [] -> + [] + + (Just x) :: rest -> + x :: (justValues rest) + + Nothing :: rest -> + justValues rest diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index db67ae16c0..35de9ca653 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -8,7 +8,7 @@ import Platform exposing (programWithFlags) import Types exposing (..) import Reader exposing (readString) import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last) +import Utils exposing (maybeToList, zip, last, justValues) import Env import Core import Eval @@ -29,77 +29,101 @@ type alias Flags = } -type alias Model = - { args : List String - , env : Env - , cont : Maybe (IO -> Eval MalExpr) - } +type Model + = InitIO Env (IO -> Eval MalExpr) + | InitError String + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) init : Flags -> ( Model, Cmd Msg ) init { args } = - ( { args = args - , env = Core.ns - , cont = Nothing - } - , readLine prompt - ) + let + initEnv = + Core.ns + + evalMalInit = + Core.malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit initEnv evalMalInit update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = - case model.cont of - Nothing -> - normalUpdate msg model + case model of + InitError _ -> + -- ignore all + ( model, Cmd.none ) - Just cont -> + InitIO env cont -> case msg of Input (Ok io) -> - run { model | cont = Nothing } (cont io) + runInit env (cont io) Input (Err msg) -> Debug.crash msg ( model, Cmd.none ) + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr -normalUpdate : Msg -> Model -> ( Model, Cmd Msg ) -normalUpdate msg model = - case msg of - Input (Ok (LineRead (Just line))) -> - rep line - |> Maybe.map (run model) - |> Maybe.withDefault (( model, readLine prompt )) + Nothing -> + ( model, readLine prompt ) - Input (Ok LineWritten) -> - ( model, readLine prompt ) + Input (Ok LineWritten) -> + ( model, readLine prompt ) - Input (Ok (LineRead Nothing)) -> - ( model, Cmd.none ) + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) -run : Model -> Eval MalExpr -> ( Model, Cmd Msg ) -run model e = - case Eval.run { env = model.env } e of - ( { env }, EvalOk expr ) -> - ( { model | env = env }, writeLine (print expr) ) + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) - ( { env }, EvalErr msg ) -> - ( { model | env = env }, writeLine ("ERR:" ++ msg) ) - ( { env }, EvalIO cmd cont ) -> - ( { model | cont = Just cont }, cmd ) +runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay, start REPL. + ( ReplActive env, readLine prompt ) + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( InitError msg, writeLine ("ERR:" ++ msg) ) -makeOutput : Result String String -> String -makeOutput result = - case result of - Ok str -> - str + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO env cont, cmd ) - Err msg -> - "ERR:" ++ msg + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) prompt : String @@ -164,9 +188,9 @@ evalAst ast = case ast of MalSymbol sym -> -- Lookup symbol in env and return value or raise error if not found. - Eval.withState - (\state -> - case Env.get sym state.env of + Eval.withEnv + (\env -> + case Env.get sym env of Ok val -> Eval.succeed val @@ -220,10 +244,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyState - (\state -> - { state | env = Env.set name value state.env } - ) + Eval.modifyEnv (Env.set name value) |> Eval.andThen (\_ -> Eval.succeed value) ) @@ -240,7 +261,7 @@ evalLet args = eval expr |> Eval.andThen (\value -> - Eval.modifyState (\state -> { state | env = Env.set name value state.env }) + Eval.modifyEnv (Env.set name value) |> Eval.andThen (\_ -> if List.isEmpty rest then @@ -254,9 +275,21 @@ evalLet args = Eval.fail "let* expected an even number of binds (symbol expr ..)" go binds body = - Eval.modifyState (\state -> { state | env = Env.make (Just state.env) }) + Eval.modifyEnv Env.push |> Eval.andThen (\_ -> evalBinds binds) |> Eval.andThen (\_ -> eval body) + |> Eval.andThen + (\res -> + Eval.withEnv + (\env -> + case Env.pop env of + Ok env -> + Eval.setEnv env |> Eval.map (\_ -> res) + + Err msg -> + Eval.fail msg + ) + ) in case args of [ MalList binds, body ] -> @@ -317,56 +350,106 @@ evalIf args = evalFn : List MalExpr -> Eval MalExpr evalFn args = let - extractSymbols list acc = + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = case list of [] -> Ok (List.reverse acc) (MalSymbol name) :: rest -> - extractSymbols rest (name :: acc) + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest _ -> Err "all binds in fn* must be a symbol" - bindArgs env pairs = - case pairs of - [] -> - env + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var - ( bind, arg ) :: rest -> - bindArgs (Env.set bind arg env) rest + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body args = + case binder args of + Ok bound -> + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> eval body) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.leave env.currentFrameId) + |> Eval.map (\_ -> res) + ) + ) + + Err msg -> + Eval.fail msg + + go bindsList body = + case extractAndParse bindsList of + Ok binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (MalFunction + (makeFn env.currentFrameId binder body) + ) + ) + ) - makeEnv binds args env = - zip binds args - |> bindArgs (Env.make (Just env)) + Err msg -> + Eval.fail msg in case args of [ MalList bindsList, body ] -> - case extractSymbols bindsList [] of - Ok binds -> - let - fn args = - if List.length args /= List.length binds then - Eval.fail <| - "function expected " - ++ (toString (List.length binds)) - ++ " arguments, got " - ++ (toString (List.length binds)) - else - -- TODO: push state and pop afterwards! - -- TODO or temporary change state? - Eval.withState - (\state -> - Eval.putState ({ state | env = makeEnv binds args state.env }) - |> Eval.andThen (\_ -> eval body) - |> Eval.andThen (\res -> Eval.putState state |> Eval.map (\_ -> res)) - ) - in - Eval.succeed (MalFunction fn) + go bindsList body - -- TODO explicitly pass current env - Err msg -> - Eval.fail msg + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body _ -> Eval.fail "fn* expected two args: binds list and body" From 0bac0757af4f15c8bc07f8ef04b0875fdd206478 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Wed, 14 Jun 2017 15:49:27 +0200 Subject: [PATCH 0032/1998] Elm: step5 - TCO the theory --- elm/Core.elm | 165 ++++++++++++-- elm/Env.elm | 172 +++++++++++--- elm/Eval.elm | 16 ++ elm/IO.elm | 16 ++ elm/Makefile | 6 +- elm/Printer.elm | 41 +++- elm/Types.elm | 27 ++- elm/bootstrap.js | 11 + elm/step4_if_fn_do.elm | 109 +++++---- elm/step5_tco.elm | 505 +++++++++++++++++++++++++++++++++++++++++ 10 files changed, 959 insertions(+), 109 deletions(-) create mode 100644 elm/step5_tco.elm diff --git a/elm/Core.elm b/elm/Core.elm index 491b6b48a2..06362e6deb 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -1,16 +1,20 @@ module Core exposing (..) -import Types exposing (MalExpr(..), Eval, Env) +import Types exposing (MalExpr(..), MalFunction(..), Eval, Env) import Env import Eval import Printer exposing (printString) import Array import IO exposing (IO(..)) +import Reader ns : Env ns = let + makeFn = + CoreFunc >> MalFunction + binaryOp fn retType args = case args of [ MalInt x, MalInt y ] -> @@ -82,12 +86,12 @@ ns = >> MalString >> Eval.succeed + {- helper function to write a string to stdout -} writeLine str = Eval.io (IO.writeLine str) (\msg -> case msg of LineWritten -> - -- TODO need caller continuation here... Eval.succeed MalNil _ -> @@ -103,25 +107,148 @@ ns = List.map (printString False) >> String.join " " >> writeLine + + printEnv args = + case args of + [] -> + Eval.withEnv (Printer.printEnv >> writeLine) + + _ -> + Eval.fail "unsupported arguments" + + readString args = + case args of + [ MalString str ] -> + case Reader.readString str of + Ok Nothing -> + Eval.succeed MalNil + + Ok (Just ast) -> + Eval.succeed ast + + Err msg -> + Eval.fail msg + + _ -> + Eval.fail "unsupported arguments" + + slurp args = + case args of + [ MalString filename ] -> + Eval.io (IO.readFile filename) + (\msg -> + case msg of + FileRead contents -> + Eval.succeed <| MalString contents + + Exception msg -> + Eval.fail msg + + _ -> + Eval.fail "wrong IO, expected FileRead" + ) + + _ -> + Eval.fail "unsupported arguments" + + atom args = + case args of + [ value ] -> + Eval.withEnv + (\env -> + case Env.newAtom value env of + ( newEnv, atomId ) -> + Eval.setEnv newEnv + |> Eval.map (\_ -> MalAtom atomId) + ) + + _ -> + Eval.fail "unsupported arguments" + + isAtom args = + case args of + [ MalAtom _ ] -> + Eval.succeed <| MalBool True + + _ -> + Eval.succeed <| MalBool False + + deref args = + case args of + [ MalAtom atomId ] -> + Eval.withEnv (Env.getAtom atomId >> Eval.succeed) + + _ -> + Eval.fail "unsupported arguments" + + reset args = + case args of + [ MalAtom atomId, value ] -> + Eval.modifyEnv (Env.setAtom atomId value) + |> Eval.map (always value) + + _ -> + Eval.fail "unsupported arguments" + + {- helper function for calling a core or user function -} + callFn func args = + case func of + CoreFunc fn -> + fn args + + UserFunc { fn } -> + fn args + + swap args = + case args of + (MalAtom atomId) :: (MalFunction func) :: args -> + Eval.withEnv + (\env -> + let + value = + Env.getAtom atomId env + in + callFn func (value :: args) + ) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.setAtom atomId res) + |> Eval.map (always res) + ) + + _ -> + Eval.fail "unsupported arguments" + + gc args = + Eval.withEnv (Env.gc >> Printer.printEnv >> writeLine) in Env.global - |> Env.set "+" (MalFunction <| binaryOp (+) MalInt) - |> Env.set "-" (MalFunction <| binaryOp (-) MalInt) - |> Env.set "*" (MalFunction <| binaryOp (*) MalInt) - |> Env.set "/" (MalFunction <| binaryOp (//) MalInt) - |> Env.set "<" (MalFunction <| binaryOp (<) MalBool) - |> Env.set ">" (MalFunction <| binaryOp (>) MalBool) - |> Env.set "<=" (MalFunction <| binaryOp (<=) MalBool) - |> Env.set ">=" (MalFunction <| binaryOp (>=) MalBool) - |> Env.set "list" (MalFunction list) - |> Env.set "list?" (MalFunction isList) - |> Env.set "empty?" (MalFunction isEmpty) - |> Env.set "count" (MalFunction count) - |> Env.set "=" (MalFunction equals) - |> Env.set "pr-str" (MalFunction prStr) - |> Env.set "str" (MalFunction str) - |> Env.set "prn" (MalFunction prn) - |> Env.set "println" (MalFunction println) + |> Env.set "+" (makeFn <| binaryOp (+) MalInt) + |> Env.set "-" (makeFn <| binaryOp (-) MalInt) + |> Env.set "*" (makeFn <| binaryOp (*) MalInt) + |> Env.set "/" (makeFn <| binaryOp (//) MalInt) + |> Env.set "<" (makeFn <| binaryOp (<) MalBool) + |> Env.set ">" (makeFn <| binaryOp (>) MalBool) + |> Env.set "<=" (makeFn <| binaryOp (<=) MalBool) + |> Env.set ">=" (makeFn <| binaryOp (>=) MalBool) + |> Env.set "list" (makeFn list) + |> Env.set "list?" (makeFn isList) + |> Env.set "empty?" (makeFn isEmpty) + |> Env.set "count" (makeFn count) + |> Env.set "=" (makeFn equals) + |> Env.set "pr-str" (makeFn prStr) + |> Env.set "str" (makeFn str) + |> Env.set "prn" (makeFn prn) + |> Env.set "println" (makeFn println) + |> Env.set "pr-env" (makeFn printEnv) + |> Env.set "read-string" (makeFn readString) + |> Env.set "slurp" (makeFn slurp) + |> Env.set "atom" (makeFn atom) + |> Env.set "atom?" (makeFn isAtom) + |> Env.set "deref" (makeFn deref) + |> Env.set "reset!" (makeFn reset) + |> Env.set "swap!" (makeFn swap) + |> Env.set "gc" (makeFn gc) malInit : List String diff --git a/elm/Env.elm b/elm/Env.elm index c67c2a7bed..19158e8c35 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -1,14 +1,37 @@ -module Env exposing (global, push, pop, enter, leave, ref, get, set) +module Env + exposing + ( global + , push + , pop + , enter + , leave + , ref + , get + , set + , newAtom + , getAtom + , setAtom + , gc + ) + +import Types exposing (MalExpr(..), MalFunction(..), Frame, Env) +import Dict +import Array +import Set + -import Types exposing (MalExpr, Frame, Env) -import Dict exposing (Dict) +globalFrameId : Int +globalFrameId = + 0 global : Env global = - { frames = Dict.singleton 0 (emptyFrame Nothing) - , nextFrameId = 1 - , currentFrameId = 0 + { frames = Dict.singleton globalFrameId (emptyFrame Nothing) + , nextFrameId = globalFrameId + 1 + , currentFrameId = globalFrameId + , atoms = Dict.empty + , nextAtomId = 0 } @@ -21,17 +44,14 @@ push env = newFrame = emptyFrame (Just env.currentFrameId) in - { currentFrameId = frameId - , frames = Dict.insert frameId newFrame env.frames - , nextFrameId = env.nextFrameId + 1 + { env + | currentFrameId = frameId + , frames = Dict.insert frameId newFrame env.frames + , nextFrameId = env.nextFrameId + 1 } - --- TODO Dont' return result, Debug.crash instead. - - -pop : Env -> Result String Env +pop : Env -> Env pop env = let frameId = @@ -41,17 +61,19 @@ pop env = Just currentFrame -> case currentFrame.outerId of Just outerId -> - Ok - { env - | currentFrameId = outerId - , frames = Dict.update frameId deref env.frames - } + { env + | currentFrameId = outerId + , frames = Dict.update frameId deref env.frames + } - Nothing -> - Err "tried to pop global frame" + _ -> + Debug.crash "tried to pop global frame" Nothing -> - Err ("current frame " ++ (toString frameId) ++ " doesn't exist") + Debug.crash <| + "current frame " + ++ (toString frameId) + ++ " doesn't exist" setBinds : List ( String, MalExpr ) -> Frame -> Frame @@ -69,14 +91,16 @@ enter : Int -> List ( String, MalExpr ) -> Env -> Env enter parentFrameId binds env = let frameId = - env.nextFrameId + Debug.log "enter #" + env.nextFrameId newFrame = setBinds binds (emptyFrame (Just parentFrameId)) in - { currentFrameId = frameId - , frames = Dict.insert frameId newFrame env.frames - , nextFrameId = env.nextFrameId + 1 + { env + | currentFrameId = frameId + , frames = Dict.insert frameId newFrame env.frames + , nextFrameId = env.nextFrameId + 1 } @@ -84,7 +108,8 @@ leave : Int -> Env -> Env leave orgFrameId env = let frameId = - env.currentFrameId + Debug.log "leave #" + env.currentFrameId in { env | currentFrameId = orgFrameId @@ -111,7 +136,8 @@ ref env = -- TODO: when disposing, deref all function's frames? --- TODO: is that enough instead of a GC? +-- TODO: is that enough instead of a GC? no: don't know how often the function is referenced. +-- TODO: consideration: keep refCnt for MalFunction, or implement a light GC. deref : Maybe Frame -> Maybe Frame @@ -131,6 +157,62 @@ deref = -- in MalFunction need to refer to the frameId. +{-| Given an Env see which frames are not reachable from the +global frame. Return a new Env without the unreachable frames. +-} +gc : Env -> Env +gc env = + let + countList acc = + List.foldl countRefs acc + + countFrame acc { data } = + data |> Dict.values |> countList acc + + countRefs expr acc = + Debug.log (toString expr) <| + case expr of + MalFunction (UserFunc { frameId }) -> + if not (Set.member frameId acc) then + Debug.log "counting" <| + case Dict.get frameId env.frames of + Just frame -> + countFrame (Set.insert frameId acc) frame + + Nothing -> + Debug.crash ("frame " ++ (toString frameId) ++ " not found in GC") + else + acc + + MalList list -> + countList acc list + + MalVector vec -> + countList acc (Array.toList vec) + + MalMap map -> + countList acc (Dict.values map) + + _ -> + acc + + initSet = + Set.fromList [ globalFrameId, env.currentFrameId ] + in + case Dict.get globalFrameId env.frames of + Nothing -> + Debug.crash "global frame not found" + + Just globalFrame -> + countFrame initSet globalFrame + |> Set.toList + |> Debug.log "used frames" + |> List.map (\frameId -> ( frameId, emptyFrame Nothing )) + |> Dict.fromList + |> Dict.intersect (Debug.log "cur frames" env.frames) + |> (\frames -> { env | frames = frames }) + + emptyFrame : Maybe Int -> Frame emptyFrame outerId = { outerId = outerId @@ -163,7 +245,7 @@ get name env = go frameId = case Dict.get frameId env.frames of Nothing -> - Err "frame not found" + Err <| "frame " ++ (toString frameId) ++ " not found" Just frame -> case Dict.get name frame.data of @@ -176,3 +258,35 @@ get name env = |> Maybe.withDefault (Err "symbol not found") in go env.currentFrameId + + +newAtom : MalExpr -> Env -> ( Env, Int ) +newAtom value env = + let + atomId = + env.nextAtomId + + newEnv = + { env + | atoms = Dict.insert atomId value env.atoms + , nextAtomId = atomId + 1 + } + in + ( newEnv, atomId ) + + +getAtom : Int -> Env -> MalExpr +getAtom atomId env = + case Dict.get atomId env.atoms of + Just value -> + value + + Nothing -> + Debug.crash <| "atom " ++ (toString atomId) ++ " not found" + + +setAtom : Int -> MalExpr -> Env -> Env +setAtom atomId value env = + { env + | atoms = Dict.insert atomId value env.atoms + } diff --git a/elm/Eval.elm b/elm/Eval.elm index c4e043700b..1756a40afe 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -2,6 +2,8 @@ module Eval exposing (..) import Types exposing (..) import IO exposing (IO) +import Env +import Printer apply : Eval a -> Env -> EvalContext a @@ -84,3 +86,17 @@ fail msg = Eval <| \state -> ( state, EvalErr msg ) + + +enter : Int -> List ( String, MalExpr ) -> Eval a -> Eval a +enter frameId bound body = + withEnv + (\env -> + modifyEnv (Env.enter frameId bound) + |> andThen (\_ -> body) + |> andThen + (\res -> + modifyEnv (Env.leave env.currentFrameId) + |> map (\_ -> res) + ) + ) diff --git a/elm/IO.elm b/elm/IO.elm index 5afd3d7d27..48ff9c439c 100644 --- a/elm/IO.elm +++ b/elm/IO.elm @@ -3,6 +3,7 @@ port module IO ( IO(..) , writeLine , readLine + , readFile , input , decodeIO ) @@ -20,6 +21,11 @@ port writeLine : String -> Cmd msg port readLine : String -> Cmd msg +{-| Read the contents of a file +-} +port readFile : String -> Cmd msg + + {-| Received a response for a command. -} port input : (Value -> msg) -> Sub msg @@ -28,6 +34,8 @@ port input : (Value -> msg) -> Sub msg type IO = LineRead (Maybe String) | LineWritten + | FileRead String + | Exception String decodeIO : Decoder IO @@ -46,6 +54,14 @@ decodeTag tag = "lineWritten" -> succeed LineWritten + "fileRead" -> + field "contents" string + |> map FileRead + + "exception" -> + field "message" string + |> map Exception + _ -> fail <| "Trying to decode IO, but tag " diff --git a/elm/Makefile b/elm/Makefile index cfee1eec08..8e0a7a1945 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,7 +1,7 @@ SOURCES_BASE = Reader.elm Printer.elm Utils.elm Types.elm Env.elm \ Core.elm Eval.elm IO.elm -SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm #step1_read_print.elm step2_eval.elm \ - step3_env.elm step4_if_fn_do.elm #step5_tco.ls step6_file.ls \ +SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm #step1_read_print.elm step2_eval.elm \ + step3_env.elm #step6_file.ls \ step7_quote.ls step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_STEPS) @@ -25,7 +25,7 @@ step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm #step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm #step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm step4_if_fn_do.js: $(SOURCES_BASE) -# step5_tco.js: utils.js reader.js printer.js env.js core.js +step5_tco.js: $(SOURCES_BASE) # step6_file.js: utils.js reader.js printer.js env.js core.js # step7_quote.js: utils.js reader.js printer.js env.js core.js # step8_macros.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/Printer.elm b/elm/Printer.elm index 4d7f8fe01b..e23d0fd992 100644 --- a/elm/Printer.elm +++ b/elm/Printer.elm @@ -2,7 +2,7 @@ module Printer exposing (..) import Array exposing (Array) import Dict exposing (Dict) -import Types exposing (MalExpr(..), keywordPrefix) +import Types exposing (Env, MalExpr(..), keywordPrefix) import Utils exposing (encodeString, wrap) @@ -42,6 +42,12 @@ printString readably ast = MalFunction _ -> "#" + MalAtom atomId -> + "#" + + MalApply _ -> + "#" + printRawString : Bool -> String -> String printRawString readably str = @@ -88,3 +94,36 @@ printMap readably = >> List.map printEntry >> String.join " " >> wrap "{" "}" + + +printEnv : Env -> String +printEnv env = + let + printOuterId = + Maybe.map toString >> Maybe.withDefault "nil" + + printHeader frameId { outerId, refCnt } = + "#" + ++ (toString frameId) + ++ " outer=" + ++ printOuterId outerId + ++ " refCnt=" + ++ (toString refCnt) + + printFrame frameId frame = + String.join "\n" + ((printHeader frameId frame) + :: (Dict.foldr printDatum [] frame.data) + ) + + printFrameAcc k v acc = + printFrame k v :: acc + + printDatum k v acc = + (k ++ " = " ++ (printString True v)) :: acc + in + "--- Environment ---\n" + ++ "Current frame: #" + ++ (toString env.currentFrameId) + ++ "\n\n" + ++ String.join "\n\n" (Dict.foldr printFrameAcc [] env.frames) diff --git a/elm/Types.elm b/elm/Types.elm index 04b78e5166..fbd0beb75a 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -20,6 +20,8 @@ type alias Env = { frames : Dict Int Frame , nextFrameId : Int , currentFrameId : Int + , atoms : Dict Int MalExpr + , nextAtomId : Int } @@ -29,6 +31,10 @@ type EvalResult res | EvalIO (Cmd Msg) (IO -> Eval res) + +-- TODO EvalTCO Env -> Eval MalExpr (?) + + type alias EvalContext res = ( Env, EvalResult res ) @@ -41,6 +47,23 @@ type Eval res = Eval (EvalFn res) +type alias MalFn = + List MalExpr -> Eval MalExpr + + +type MalFunction + = CoreFunc MalFn + | UserFunc { frameId : Int, fn : MalFn } + + +type alias TcoFn = + () -> Eval MalExpr + + +type alias Bound = + List ( String, MalExpr ) + + type MalExpr = MalNil | MalBool Bool @@ -51,7 +74,9 @@ type MalExpr | MalList (List MalExpr) | MalVector (Array MalExpr) | MalMap (Dict String MalExpr) - | MalFunction (List MalExpr -> Eval MalExpr) + | MalFunction MalFunction + | MalApply { frameId : Int, bound : Bound, body : MalExpr } + | MalAtom Int {-| Keywords are prefixed by this char for usage in a MalMap. diff --git a/elm/bootstrap.js b/elm/bootstrap.js index e91fc5c06f..59d3230105 100644 --- a/elm/bootstrap.js +++ b/elm/bootstrap.js @@ -1,4 +1,5 @@ var readline = require('./node_readline'); +var fs = require('fs'); // The first two arguments are: 'node' and 'bootstrap.js' // The third argument is the name of the Elm module to load. @@ -19,3 +20,13 @@ app.ports.readLine.subscribe(function(prompt) { var line = readline.readline(prompt); app.ports.input.send({"tag": "lineRead", "line": line}); }); + +// Read the contents of a file. +app.ports.readFile.subscribe(function(filename) { + try { + var contents = fs.readFileSync(filename, 'utf8'); + app.ports.input.send({"tag": "fileRead", "contents": contents}); + } catch (e) { + app.ports.input.send({"tag": "exception", "message": e.message}); + } +}); \ No newline at end of file diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index 35de9ca653..466ac1865b 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -66,7 +66,7 @@ update msg model = runInit env (cont io) Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) + Debug.crash msg ReplActive env -> case msg of @@ -85,8 +85,11 @@ update msg model = -- Ctrl+D = The End. ( model, Cmd.none ) + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) + Debug.crash msg ReplIO env cont -> case msg of @@ -145,42 +148,48 @@ read = eval : MalExpr -> Eval MalExpr eval ast = - case ast of - MalList [] -> - Eval.succeed ast + Debug.log "eval " (printString True ast) + |> (\_ -> + case ast of + MalList [] -> + Eval.succeed ast - MalList ((MalSymbol "def!") :: args) -> - evalDef args + MalList ((MalSymbol "def!") :: args) -> + evalDef args - MalList ((MalSymbol "let*") :: args) -> - evalLet args + MalList ((MalSymbol "let*") :: args) -> + evalLet args - MalList ((MalSymbol "do") :: args) -> - evalDo args + MalList ((MalSymbol "do") :: args) -> + evalDo args - MalList ((MalSymbol "if") :: args) -> - evalIf args + MalList ((MalSymbol "if") :: args) -> + evalIf args - MalList ((MalSymbol "fn*") :: args) -> - evalFn args + MalList ((MalSymbol "fn*") :: args) -> + evalFn args - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" - (MalFunction fn) :: args -> - fn args + (MalFunction (CoreFunc fn)) :: args -> + fn args - fn :: _ -> - Eval.fail ((printString True fn) ++ " is not a function") - ) + (MalFunction (UserFunc { fn })) :: args -> + fn args - _ -> - evalAst ast + fn :: _ -> + Eval.fail ((printString True fn) ++ " is not a function") + ) + + _ -> + evalAst ast + ) evalAst : MalExpr -> Eval MalExpr @@ -280,15 +289,8 @@ evalLet args = |> Eval.andThen (\_ -> eval body) |> Eval.andThen (\res -> - Eval.withEnv - (\env -> - case Env.pop env of - Ok env -> - Eval.setEnv env |> Eval.map (\_ -> res) - - Err msg -> - Eval.fail msg - ) + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) ) in case args of @@ -408,22 +410,19 @@ evalFn args = else Ok <| zip binds args ++ [ ( var, varArgs ) ] - makeFn frameId binder body args = - case binder args of - Ok bound -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> eval body) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.leave env.currentFrameId) - |> Eval.map (\_ -> res) - ) - ) + makeFn frameId binder body = + MalFunction <| + UserFunc + { frameId = frameId + , fn = + \args -> + case binder args of + Ok bound -> + Eval.enter frameId bound (eval body) - Err msg -> - Eval.fail msg + Err msg -> + Eval.fail msg + } go bindsList body = case extractAndParse bindsList of @@ -435,9 +434,7 @@ evalFn args = Eval.withEnv (\env -> Eval.succeed - (MalFunction - (makeFn env.currentFrameId binder body) - ) + (makeFn env.currentFrameId binder body) ) ) diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm new file mode 100644 index 0000000000..d48c50e52c --- /dev/null +++ b/elm/step5_tco.elm @@ -0,0 +1,505 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type Model + = InitIO Env (IO -> Eval MalExpr) + | InitError String + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + initEnv = + Core.ns + + evalMalInit = + Core.malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit initEnv evalMalInit + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + InitError _ -> + -- ignore all + ( model, Cmd.none ) + + InitIO env cont -> + case msg of + Input (Ok io) -> + runInit env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay, start REPL. + ( ReplActive env, readLine prompt ) + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( InitError msg, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : MalExpr -> Eval MalExpr +eval ast = + Debug.log "eval " (printString True ast) + |> (\_ -> + evalNoApply ast + |> Eval.andThen + (\ast -> + case ast of + MalApply { frameId, bound, body } -> + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.leave env.currentFrameId) + |> Eval.map (\_ -> res) + ) + ) + |> Eval.andThen eval + + _ -> + Eval.succeed ast + ) + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + Debug.log "evalNoApply " (printString True ast) + |> (\_ -> + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { fn })) :: args -> + fn args + + fn :: _ -> + Eval.fail ((printString True fn) ++ " is not a function") + ) + + _ -> + evalAst ast + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv + (\env -> + case Env.get sym env of + Ok val -> + Eval.succeed val + + Err msg -> + Eval.fail msg + ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) + ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + UserFunc + { frameId = frameId + , fn = + \args -> + case binder args of + Ok bound -> + Eval.succeed <| + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + + Err msg -> + Eval.fail msg + } + + go bindsList body = + case extractAndParse bindsList of + Ok binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + + Err msg -> + Eval.fail msg + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : MalExpr -> String +print = + printString True + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just From 16586ba573e3739ca69c759bb9f1a5a3ba367f75 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Thu, 15 Jun 2017 21:06:49 +0200 Subject: [PATCH 0033/1998] Elm step 5: cleaning up a bit, add debug mode. --- elm/Core.elm | 16 ++++++ elm/Env.elm | 44 +++++++++-------- elm/Eval.elm | 110 ++++++++++++++++++++++------------------- elm/Types.elm | 22 +++++---- elm/step5_tco.elm | 123 ++++++++++++++++++++++++++-------------------- 5 files changed, 179 insertions(+), 136 deletions(-) diff --git a/elm/Core.elm b/elm/Core.elm index 06362e6deb..559f0ecf12 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -221,6 +221,21 @@ ns = gc args = Eval.withEnv (Env.gc >> Printer.printEnv >> writeLine) + + setDebug enabled = + Eval.modifyEnv + (\env -> + { env | debug = enabled } + ) + |> Eval.andThen (\_ -> Eval.succeed MalNil) + + debug args = + case args of + [ MalBool True ] -> + setDebug True + + _ -> + setDebug False in Env.global |> Env.set "+" (makeFn <| binaryOp (+) MalInt) @@ -249,6 +264,7 @@ ns = |> Env.set "reset!" (makeFn reset) |> Env.set "swap!" (makeFn swap) |> Env.set "gc" (makeFn gc) + |> Env.set "debug!" (makeFn debug) malInit : List String diff --git a/elm/Env.elm b/elm/Env.elm index 19158e8c35..5efb7ad2e6 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -1,6 +1,7 @@ module Env exposing - ( global + ( debug + , global , push , pop , enter @@ -20,6 +21,14 @@ import Array import Set +debug : Env -> String -> a -> a +debug env msg value = + if env.debug then + Debug.log msg value + else + value + + globalFrameId : Int globalFrameId = 0 @@ -32,6 +41,7 @@ global = , currentFrameId = globalFrameId , atoms = Dict.empty , nextAtomId = 0 + , debug = True } @@ -91,8 +101,7 @@ enter : Int -> List ( String, MalExpr ) -> Env -> Env enter parentFrameId binds env = let frameId = - Debug.log "enter #" - env.nextFrameId + debug env "enter #" env.nextFrameId newFrame = setBinds binds (emptyFrame (Just parentFrameId)) @@ -108,8 +117,7 @@ leave : Int -> Env -> Env leave orgFrameId env = let frameId = - Debug.log "leave #" - env.currentFrameId + debug env "leave #" env.currentFrameId in { env | currentFrameId = orgFrameId @@ -134,12 +142,6 @@ ref env = { env | frames = newFrames } - --- TODO: when disposing, deref all function's frames? --- TODO: is that enough instead of a GC? no: don't know how often the function is referenced. --- TODO: consideration: keep refCnt for MalFunction, or implement a light GC. - - deref : Maybe Frame -> Maybe Frame deref = Maybe.andThen @@ -151,12 +153,6 @@ deref = ) - --- TODO need a GC. --- given a Env, see which frames are not reachable. --- in MalFunction need to refer to the frameId. - - {-| Given an Env see which frames are not reachable from the global frame. Return a new Env without the unreachable frames. -} @@ -170,11 +166,11 @@ gc env = data |> Dict.values |> countList acc countRefs expr acc = - Debug.log (toString expr) <| + debug env ("gc-visit " ++ (toString expr)) <| case expr of MalFunction (UserFunc { frameId }) -> if not (Set.member frameId acc) then - Debug.log "counting" <| + debug env "gc-counting" <| case Dict.get frameId env.frames of Just frame -> countFrame (Set.insert frameId acc) frame @@ -198,6 +194,11 @@ gc env = initSet = Set.fromList [ globalFrameId, env.currentFrameId ] + + reportUnused frames used = + Dict.diff frames used + |> debug env "unused frames" + |> (\_ -> frames) in case Dict.get globalFrameId env.frames of Nothing -> @@ -206,10 +207,11 @@ gc env = Just globalFrame -> countFrame initSet globalFrame |> Set.toList - |> Debug.log "used frames" + |> debug env "used frames" |> List.map (\frameId -> ( frameId, emptyFrame Nothing )) |> Dict.fromList - |> Dict.intersect (Debug.log "cur frames" env.frames) + |> reportUnused env.frames + |> Dict.intersect env.frames |> (\frames -> { env | frames = frames }) diff --git a/elm/Eval.elm b/elm/Eval.elm index 1756a40afe..daa1472506 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -3,89 +3,72 @@ module Eval exposing (..) import Types exposing (..) import IO exposing (IO) import Env -import Printer apply : Eval a -> Env -> EvalContext a -apply (Eval f) state = - f state +apply f env = + f env run : Env -> Eval a -> EvalContext a -run state e = - apply e state +run env e = + apply e env withEnv : (Env -> Eval a) -> Eval a -withEnv f = - Eval <| - \state -> - apply (f state) state +withEnv f env = + apply (f env) env setEnv : Env -> Eval () -setEnv state = - Eval <| - \_ -> - apply (succeed ()) state +setEnv env _ = + apply (succeed ()) env modifyEnv : (Env -> Env) -> Eval () -modifyEnv f = - Eval <| - \state -> - apply (succeed ()) (f state) +modifyEnv f env = + apply (succeed ()) (f env) succeed : a -> Eval a -succeed res = - Eval <| - \state -> - ( state, EvalOk res ) +succeed res env = + ( env, EvalOk res ) io : Cmd Msg -> (IO -> Eval a) -> Eval a -io cmd cont = - Eval <| - \state -> - ( state, EvalIO cmd cont ) +io cmd cont env = + ( env, EvalIO cmd cont ) map : (a -> b) -> Eval a -> Eval b -map f e = - Eval <| - \state -> - case apply e state of - ( state, EvalOk res ) -> - ( state, EvalOk (f res) ) +map f e env = + case apply e env of + ( env, EvalOk res ) -> + ( env, EvalOk (f res) ) - ( state, EvalErr msg ) -> - ( state, EvalErr msg ) + ( env, EvalErr msg ) -> + ( env, EvalErr msg ) - ( state, EvalIO cmd cont ) -> - ( state, EvalIO cmd (cont >> map f) ) + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> map f) ) andThen : (a -> Eval b) -> Eval a -> Eval b -andThen f e = - Eval <| - \state -> - case apply e state of - ( state, EvalOk res ) -> - apply (f res) state +andThen f e env = + case apply e env of + ( env, EvalOk res ) -> + apply (f res) env - ( state, EvalErr msg ) -> - ( state, EvalErr msg ) + ( env, EvalErr msg ) -> + ( env, EvalErr msg ) - ( state, EvalIO cmd cont ) -> - ( state, EvalIO cmd (cont >> andThen f) ) + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> andThen f) ) fail : String -> Eval a -fail msg = - Eval <| - \state -> - ( state, EvalErr msg ) +fail msg env = + ( env, EvalErr msg ) enter : Int -> List ( String, MalExpr ) -> Eval a -> Eval a @@ -93,10 +76,35 @@ enter frameId bound body = withEnv (\env -> modifyEnv (Env.enter frameId bound) - |> andThen (\_ -> body) + |> andThen (always body) |> andThen (\res -> modifyEnv (Env.leave env.currentFrameId) - |> map (\_ -> res) + |> map (always res) ) ) + + +{-| Apply f to expr repeatedly. +Continues iterating if f returns (Left eval). +Stops if f returns (Right expr). + +Tail call optimized. + +-} +runLoop : (MalExpr -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr +runLoop f expr env = + case f expr of + Left e -> + case apply e env of + ( env, EvalOk expr ) -> + runLoop f expr env + + ( env, EvalErr msg ) -> + ( env, EvalErr msg ) + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> andThen (runLoop f)) ) + + Right expr -> + ( env, EvalOk expr ) diff --git a/elm/Types.elm b/elm/Types.elm index fbd0beb75a..a3ef598f9c 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -5,6 +5,11 @@ import Dict exposing (Dict) import IO exposing (IO) +type Either a b + = Left a + | Right b + + type Msg = Input (Result String IO) @@ -22,6 +27,7 @@ type alias Env = , currentFrameId : Int , atoms : Dict Int MalExpr , nextAtomId : Int + , debug : Bool } @@ -31,22 +37,14 @@ type EvalResult res | EvalIO (Cmd Msg) (IO -> Eval res) - --- TODO EvalTCO Env -> Eval MalExpr (?) - - type alias EvalContext res = ( Env, EvalResult res ) -type alias EvalFn res = +type alias Eval res = Env -> EvalContext res -type Eval res - = Eval (EvalFn res) - - type alias MalFn = List MalExpr -> Eval MalExpr @@ -56,6 +54,10 @@ type MalFunction | UserFunc { frameId : Int, fn : MalFn } +type alias ApplyRec = + { frameId : Int, bound : Bound, body : MalExpr } + + type alias TcoFn = () -> Eval MalExpr @@ -75,7 +77,7 @@ type MalExpr | MalVector (Array MalExpr) | MalMap (Dict String MalExpr) | MalFunction MalFunction - | MalApply { frameId : Int, bound : Bound, body : MalExpr } + | MalApply ApplyRec | MalAtom Int diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index d48c50e52c..6591c3a22a 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -146,77 +146,92 @@ read = readString +debug : String -> a -> Eval b -> Eval b +debug msg value e = + Eval.withEnv + (\env -> + Env.debug env msg value + |> always e + ) + + eval : MalExpr -> Eval MalExpr eval ast = - Debug.log "eval " (printString True ast) - |> (\_ -> - evalNoApply ast - |> Eval.andThen - (\ast -> - case ast of - MalApply { frameId, bound, body } -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.leave env.currentFrameId) - |> Eval.map (\_ -> res) - ) - ) - |> Eval.andThen eval - - _ -> - Eval.succeed ast + let + apply expr = + case expr of + MalApply app -> + Left + (debug "evalApply" + (printString True expr) + (evalApply app) ) - ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.leave env.currentFrameId) + |> Eval.map (\_ -> res) + ) + ) evalNoApply : MalExpr -> Eval MalExpr evalNoApply ast = - Debug.log "evalNoApply " (printString True ast) - |> (\_ -> - case ast of - MalList [] -> - Eval.succeed ast + debug "evalNoApply" + (printString True ast) + (case ast of + MalList [] -> + Eval.succeed ast - MalList ((MalSymbol "def!") :: args) -> - evalDef args + MalList ((MalSymbol "def!") :: args) -> + evalDef args - MalList ((MalSymbol "let*") :: args) -> - evalLet args + MalList ((MalSymbol "let*") :: args) -> + evalLet args - MalList ((MalSymbol "do") :: args) -> - evalDo args + MalList ((MalSymbol "do") :: args) -> + evalDo args - MalList ((MalSymbol "if") :: args) -> - evalIf args + MalList ((MalSymbol "if") :: args) -> + evalIf args - MalList ((MalSymbol "fn*") :: args) -> - evalFn args + MalList ((MalSymbol "fn*") :: args) -> + evalFn args - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" - (MalFunction (CoreFunc fn)) :: args -> - fn args + (MalFunction (CoreFunc fn)) :: args -> + fn args - (MalFunction (UserFunc { fn })) :: args -> - fn args + (MalFunction (UserFunc { fn })) :: args -> + fn args - fn :: _ -> - Eval.fail ((printString True fn) ++ " is not a function") - ) + fn :: _ -> + Eval.fail ((printString True fn) ++ " is not a function") + ) - _ -> - evalAst ast - ) + _ -> + evalAst ast + ) evalAst : MalExpr -> Eval MalExpr From c03ae85fcde448971c2acd8e444e9981a40d59a6 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Thu, 15 Jun 2017 21:07:37 +0200 Subject: [PATCH 0034/1998] Elm step 5: tests passed. --- elm/Env.elm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elm/Env.elm b/elm/Env.elm index 5efb7ad2e6..c26fb58a21 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -41,7 +41,7 @@ global = , currentFrameId = globalFrameId , atoms = Dict.empty , nextAtomId = 0 - , debug = True + , debug = False } From a83904ea9273a5e94b65b676ba23abee92b1e80f Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Thu, 15 Jun 2017 21:23:37 +0200 Subject: [PATCH 0035/1998] Elm step 6: fix bug: def! always writes in global frame. --- elm/Core.elm | 4 + elm/Env.elm | 18 +- elm/Makefile | 6 +- elm/step1_read_print.elm | 3 + elm/step2_eval.elm | 13 +- elm/step4_if_fn_do.elm | 63 +++-- elm/step5_tco.elm | 2 +- elm/step6_file.elm | 534 +++++++++++++++++++++++++++++++++++++++ 8 files changed, 596 insertions(+), 47 deletions(-) create mode 100644 elm/step6_file.elm diff --git a/elm/Core.elm b/elm/Core.elm index 559f0ecf12..315f8d07ed 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -272,4 +272,8 @@ malInit = [ """(def! not (fn* (a) (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) ")")))))""" ] diff --git a/elm/Env.elm b/elm/Env.elm index c26fb58a21..e6a9bf7b91 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -9,6 +9,7 @@ module Env , ref , get , set + , def , newAtom , getAtom , setAtom @@ -223,8 +224,8 @@ emptyFrame outerId = } -set : String -> MalExpr -> Env -> Env -set name expr env = +setInFrame : Int -> String -> MalExpr -> Env -> Env +setInFrame frameId name expr env = let updateFrame = Maybe.map @@ -232,15 +233,22 @@ set name expr env = { frame | data = Dict.insert name expr frame.data } ) - frameId = - env.currentFrameId - newFrames = Dict.update frameId updateFrame env.frames in { env | frames = newFrames } +set : String -> MalExpr -> Env -> Env +set name expr env = + setInFrame env.currentFrameId name expr env + + +def : String -> MalExpr -> Env -> Env +def = + setInFrame globalFrameId + + get : String -> Env -> Result String MalExpr get name env = let diff --git a/elm/Makefile b/elm/Makefile index 8e0a7a1945..37c90f10ff 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,7 +1,7 @@ SOURCES_BASE = Reader.elm Printer.elm Utils.elm Types.elm Env.elm \ Core.elm Eval.elm IO.elm -SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm #step1_read_print.elm step2_eval.elm \ - step3_env.elm #step6_file.ls \ +SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm step1_read_print.elm #step2_eval.elm \ + #step3_env.elm \ step7_quote.ls step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_STEPS) @@ -26,7 +26,7 @@ step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm #step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm step4_if_fn_do.js: $(SOURCES_BASE) step5_tco.js: $(SOURCES_BASE) -# step6_file.js: utils.js reader.js printer.js env.js core.js +step6_file.js: $(SOURCES_BASE) # step7_quote.js: utils.js reader.js printer.js env.js core.js # step8_macros.js: utils.js reader.js printer.js env.js core.js # step9_try.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/step1_read_print.elm b/elm/step1_read_print.elm index ff7c09a6a8..cff0e9a6bc 100644 --- a/elm/step1_read_print.elm +++ b/elm/step1_read_print.elm @@ -55,6 +55,9 @@ update msg model = Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + Input (Err msg) -> Debug.crash msg ( model, Cmd.none ) diff --git a/elm/step2_eval.elm b/elm/step2_eval.elm index 25d83fd7c5..7f7b85c8f5 100644 --- a/elm/step2_eval.elm +++ b/elm/step2_eval.elm @@ -3,7 +3,7 @@ port module Main exposing (..) import IO exposing (..) import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) -import Types exposing (MalExpr(..)) +import Types exposing (MalExpr(..), MalFunction(..)) import Reader exposing (readString) import Printer exposing (printString) import Utils exposing (maybeToList, zip) @@ -49,6 +49,9 @@ init { args } = initReplEnv : ReplEnv initReplEnv = let + makeFn = + CoreFunc >> MalFunction + binaryOp fn args = case args of [ MalInt x, MalInt y ] -> @@ -58,10 +61,10 @@ initReplEnv = Err "unsupported arguments" in Dict.fromList - [ ( "+", MalFunction <| binaryOp (+) ) - , ( "-", MalFunction <| binaryOp (-) ) - , ( "*", MalFunction <| binaryOp (*) ) - , ( "/", MalFunction <| binaryOp (//) ) + [ ( "+", makeFn <| binaryOp (+) ) + , ( "-", makeFn <| binaryOp (-) ) + , ( "*", makeFn <| binaryOp (*) ) + , ( "/", makeFn <| binaryOp (//) ) ] diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index 466ac1865b..e6c31954da 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -148,48 +148,45 @@ read = eval : MalExpr -> Eval MalExpr eval ast = - Debug.log "eval " (printString True ast) - |> (\_ -> - case ast of - MalList [] -> - Eval.succeed ast + case ast of + MalList [] -> + Eval.succeed ast - MalList ((MalSymbol "def!") :: args) -> - evalDef args + MalList ((MalSymbol "def!") :: args) -> + evalDef args - MalList ((MalSymbol "let*") :: args) -> - evalLet args + MalList ((MalSymbol "let*") :: args) -> + evalLet args - MalList ((MalSymbol "do") :: args) -> - evalDo args + MalList ((MalSymbol "do") :: args) -> + evalDo args - MalList ((MalSymbol "if") :: args) -> - evalIf args + MalList ((MalSymbol "if") :: args) -> + evalIf args - MalList ((MalSymbol "fn*") :: args) -> - evalFn args + MalList ((MalSymbol "fn*") :: args) -> + evalFn args - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" - (MalFunction (CoreFunc fn)) :: args -> - fn args + (MalFunction (CoreFunc fn)) :: args -> + fn args - (MalFunction (UserFunc { fn })) :: args -> - fn args + (MalFunction (UserFunc { fn })) :: args -> + fn args - fn :: _ -> - Eval.fail ((printString True fn) ++ " is not a function") - ) + fn :: _ -> + Eval.fail ((printString True fn) ++ " is not a function") + ) - _ -> - evalAst ast - ) + _ -> + evalAst ast evalAst : MalExpr -> Eval MalExpr @@ -253,7 +250,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.set name value) + Eval.modifyEnv (Env.def name value) |> Eval.andThen (\_ -> Eval.succeed value) ) diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index 6591c3a22a..1ae5dcf574 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -295,7 +295,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.set name value) + Eval.modifyEnv (Env.def name value) |> Eval.andThen (\_ -> Eval.succeed value) ) diff --git a/elm/step6_file.elm b/elm/step6_file.elm new file mode 100644 index 0000000000..789f7ee7d9 --- /dev/null +++ b/elm/step6_file.elm @@ -0,0 +1,534 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type Model + = InitIO Env (IO -> Eval MalExpr) + | InitError String + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + + evalMalInit = + Core.malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit initEnv evalMalInit + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + InitError _ -> + -- ignore all + ( model, Cmd.none ) + + InitIO env cont -> + case msg of + Input (Ok io) -> + runInit env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay, start REPL. + ( ReplActive env, readLine prompt ) + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( InitError msg, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> a -> Eval b -> Eval b +debug msg value e = + Eval.withEnv + (\env -> + Env.debug env msg value + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr = + case expr of + MalApply app -> + Left + (debug "evalApply" + (printString True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + eval expr + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.leave env.currentFrameId) + |> Eval.map (\_ -> res) + ) + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (printString True ast) + (case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { fn })) :: args -> + fn args + + fn :: _ -> + Eval.fail ((printString True fn) ++ " is not a function") + ) + + _ -> + evalAst ast + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv + (\env -> + case Env.get sym env of + Ok val -> + Eval.succeed val + + Err msg -> + Eval.fail msg + ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) + ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + UserFunc + { frameId = frameId + , fn = + \args -> + case binder args of + Ok bound -> + Eval.succeed <| + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + + Err msg -> + Eval.fail msg + } + + go bindsList body = + case extractAndParse bindsList of + Ok binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + + Err msg -> + Eval.fail msg + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : MalExpr -> String +print = + printString True + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just From fe50dd7a4950e80968b1d03e0a819ef8092b2db1 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 18 Jun 2017 21:38:48 +0200 Subject: [PATCH 0036/1998] Elm: Step 4-6 tests succeed --- elm/Core.elm | 165 +++++++++-- elm/Eval.elm | 10 + elm/Printer.elm | 47 ++-- elm/Types.elm | 7 +- elm/step1_read_print.elm | 4 +- elm/step4_if_fn_do.elm | 44 +-- elm/step5_tco.elm | 66 +++-- elm/step6_file.elm | 148 +++++++--- elm/step7_quote.elm | 583 +++++++++++++++++++++++++++++++++++++++ 9 files changed, 934 insertions(+), 140 deletions(-) create mode 100644 elm/step7_quote.elm diff --git a/elm/Core.elm b/elm/Core.elm index 315f8d07ed..a4038e4682 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -5,8 +5,10 @@ import Env import Eval import Printer exposing (printString) import Array +import Dict import IO exposing (IO(..)) import Reader +import Utils exposing (zip) ns : Env @@ -63,28 +65,101 @@ ns = _ -> Eval.fail "unsupported arguments" + equalLists a b = + case ( a, b ) of + ( [], [] ) -> + True + + ( x :: xs, y :: ys ) -> + if deepEquals x y then + equalLists xs ys + else + False + + _ -> + False + + compareListTo list other = + case other of + MalList otherList -> + equalLists list otherList + + MalVector vec -> + equalLists list (Array.toList vec) + + _ -> + False + + equalMaps a b = + if Dict.keys a /= Dict.keys b then + False + else + zip (Dict.values a) (Dict.values b) + |> List.map (uncurry deepEquals) + |> List.all identity + + deepEquals a b = + case ( a, b ) of + ( MalList list, MalList otherList ) -> + equalLists list otherList + + ( MalList list, MalVector vec ) -> + equalLists list (Array.toList vec) + + ( MalList _, _ ) -> + False + + ( MalVector vec, MalList list ) -> + equalLists (Array.toList vec) list + + ( MalVector vec, MalVector otherVec ) -> + equalLists (Array.toList vec) (Array.toList otherVec) + + ( MalVector _, _ ) -> + False + + ( MalMap map, MalMap otherMap ) -> + equalMaps map otherMap + + ( MalMap _, _ ) -> + False + + ( _, MalMap _ ) -> + False + + _ -> + a == b + {- = -} equals args = case args of [ a, b ] -> - Eval.succeed <| MalBool (a == b) + Eval.succeed <| MalBool (deepEquals a b) _ -> Eval.fail "unsupported arguments" {- pr-str -} - prStr = - List.map (printString True) - >> String.join " " - >> MalString - >> Eval.succeed + prStr args = + Eval.withEnv + (\env -> + args + |> List.map (printString env True) + |> String.join " " + |> MalString + |> Eval.succeed + ) {- str -} - str = - List.map (printString False) - >> String.join "" - >> MalString - >> Eval.succeed + str args = + Eval.withEnv + (\env -> + args + |> List.map (printString env False) + |> String.join "" + |> MalString + |> Eval.succeed + ) {- helper function to write a string to stdout -} writeLine str = @@ -98,15 +173,23 @@ ns = Eval.fail "wrong IO, expected LineWritten" ) - prn = - List.map (printString True) - >> String.join " " - >> writeLine + prn args = + Eval.withEnv + (\env -> + args + |> List.map (printString env True) + |> String.join " " + |> writeLine + ) - println = - List.map (printString False) - >> String.join " " - >> writeLine + println args = + Eval.withEnv + (\env -> + args + |> List.map (printString env False) + |> String.join " " + |> writeLine + ) printEnv args = case args of @@ -196,12 +279,13 @@ ns = CoreFunc fn -> fn args - UserFunc { fn } -> - fn args + UserFunc { eagerFn } -> + eagerFn args swap args = case args of (MalAtom atomId) :: (MalFunction func) :: args -> + -- TODO eval apply here! Eval.withEnv (\env -> let @@ -236,6 +320,44 @@ ns = _ -> setDebug False + + typeof args = + case args of + [ MalInt _ ] -> + Eval.succeed <| MalSymbol "int" + + [ MalBool _ ] -> + Eval.succeed <| MalSymbol "bool" + + [ MalString _ ] -> + Eval.succeed <| MalSymbol "string" + + [ MalKeyword _ ] -> + Eval.succeed <| MalSymbol "keyword" + + [ MalSymbol _ ] -> + Eval.succeed <| MalSymbol "symbol" + + [ MalNil ] -> + Eval.succeed <| MalSymbol "nil" + + [ MalList _ ] -> + Eval.succeed <| MalSymbol "vector" + + [ MalVector _ ] -> + Eval.succeed <| MalSymbol "vector" + + [ MalMap _ ] -> + Eval.succeed <| MalSymbol "vector" + + [ MalFunction _ ] -> + Eval.succeed <| MalSymbol "function" + + [ MalAtom _ ] -> + Eval.succeed <| MalSymbol "atom" + + _ -> + Eval.fail "unsupported arguments" in Env.global |> Env.set "+" (makeFn <| binaryOp (+) MalInt) @@ -265,6 +387,7 @@ ns = |> Env.set "swap!" (makeFn swap) |> Env.set "gc" (makeFn gc) |> Env.set "debug!" (makeFn debug) + |> Env.set "typeof" (makeFn typeof) malInit : List String diff --git a/elm/Eval.elm b/elm/Eval.elm index daa1472506..4c581084ac 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -108,3 +108,13 @@ runLoop f expr env = Right expr -> ( env, EvalOk expr ) + + +fromResult : Result String a -> Eval a +fromResult res = + case res of + Ok val -> + succeed val + + Err msg -> + fail msg diff --git a/elm/Printer.elm b/elm/Printer.elm index e23d0fd992..0da4e2dda7 100644 --- a/elm/Printer.elm +++ b/elm/Printer.elm @@ -4,10 +4,11 @@ import Array exposing (Array) import Dict exposing (Dict) import Types exposing (Env, MalExpr(..), keywordPrefix) import Utils exposing (encodeString, wrap) +import Env -printString : Bool -> MalExpr -> String -printString readably ast = +printString : Env -> Bool -> MalExpr -> String +printString env readably ast = case ast of MalNil -> "nil" @@ -22,7 +23,7 @@ printString readably ast = toString int MalString str -> - printRawString readably str + printRawString env readably str MalSymbol sym -> sym @@ -31,49 +32,53 @@ printString readably ast = kw MalList list -> - printList readably list + printList env readably list MalVector vec -> - printVector readably vec + printVector env readably vec MalMap map -> - printMap readably map + printMap env readably map MalFunction _ -> "#" MalAtom atomId -> - "#" + let + value = + Env.getAtom atomId env + in + "(atom " ++ (printString env True value) ++ ")" MalApply _ -> "#" -printRawString : Bool -> String -> String -printRawString readably str = +printRawString : Env -> Bool -> String -> String +printRawString env readably str = if readably then encodeString str else str -printList : Bool -> List MalExpr -> String -printList readably = - List.map (printString readably) +printList : Env -> Bool -> List MalExpr -> String +printList env readably = + List.map (printString env readably) >> String.join " " >> wrap "(" ")" -printVector : Bool -> Array MalExpr -> String -printVector readably = - Array.map (printString readably) +printVector : Env -> Bool -> Array MalExpr -> String +printVector env readably = + Array.map (printString env readably) >> Array.toList >> String.join " " >> wrap "[" "]" -printMap : Bool -> Dict String MalExpr -> String -printMap readably = +printMap : Env -> Bool -> Dict String MalExpr -> String +printMap env readably = let -- Strip off the keyword prefix if it is there. printKey k = @@ -82,13 +87,13 @@ printMap readably = if prefix == keywordPrefix then rest else - printRawString readably k + printRawString env readably k _ -> - printRawString readably k + printRawString env readably k printEntry ( k, v ) = - (printKey k) ++ " " ++ (printString readably v) + (printKey k) ++ " " ++ (printString env readably v) in Dict.toList >> List.map printEntry @@ -120,7 +125,7 @@ printEnv env = printFrame k v :: acc printDatum k v acc = - (k ++ " = " ++ (printString True v)) :: acc + (k ++ " = " ++ (printString env True v)) :: acc in "--- Environment ---\n" ++ "Current frame: #" diff --git a/elm/Types.elm b/elm/Types.elm index a3ef598f9c..d7393f814c 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -31,10 +31,13 @@ type alias Env = } +type alias EvalCont a = IO -> Eval a + + type EvalResult res = EvalErr String | EvalOk res - | EvalIO (Cmd Msg) (IO -> Eval res) + | EvalIO (Cmd Msg) (EvalCont res) type alias EvalContext res = @@ -51,7 +54,7 @@ type alias MalFn = type MalFunction = CoreFunc MalFn - | UserFunc { frameId : Int, fn : MalFn } + | UserFunc { frameId : Int, lazyFn : MalFn, eagerFn : MalFn } type alias ApplyRec = diff --git a/elm/step1_read_print.elm b/elm/step1_read_print.elm index cff0e9a6bc..c0653c81b2 100644 --- a/elm/step1_read_print.elm +++ b/elm/step1_read_print.elm @@ -6,7 +6,7 @@ import Platform exposing (programWithFlags) import Types exposing (MalExpr(..)) import Reader exposing (readString) import Printer exposing (printString) -import Utils exposing (maybeToList) +import Env main : Program Flags Model Msg @@ -86,7 +86,7 @@ eval ast = print : MalExpr -> String print = - printString True + printString Env.global True {-| Read-Eval-Print diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index e6c31954da..be30d08aa5 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -120,7 +120,7 @@ run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) run env expr = case Eval.run env expr of ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print expr) ) + ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> ( ReplActive env, writeLine ("ERR:" ++ msg) ) @@ -178,11 +178,14 @@ eval ast = (MalFunction (CoreFunc fn)) :: args -> fn args - (MalFunction (UserFunc { fn })) :: args -> - fn args + (MalFunction (UserFunc { eagerFn })) :: args -> + eagerFn args fn :: _ -> - Eval.fail ((printString True fn) ++ " is not a function") + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) ) _ -> @@ -408,18 +411,21 @@ evalFn args = Ok <| zip binds args ++ [ ( var, varArgs ) ] makeFn frameId binder body = - MalFunction <| - UserFunc - { frameId = frameId - , fn = - \args -> - case binder args of - Ok bound -> - Eval.enter frameId bound (eval body) - - Err msg -> - Eval.fail msg - } + let + fn args = + case binder args of + Ok bound -> + Eval.enter frameId bound (eval body) + + Err msg -> + Eval.fail msg + in + MalFunction <| + UserFunc + { frameId = frameId + , lazyFn = fn + , eagerFn = fn + } go bindsList body = case extractAndParse bindsList of @@ -449,9 +455,9 @@ evalFn args = Eval.fail "fn* expected two args: binds list and body" -print : MalExpr -> String -print = - printString True +print : Env -> MalExpr -> String +print env = + printString env True {-| Read-Eval-Print. diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index 1ae5dcf574..da7b9c437f 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -120,7 +120,7 @@ run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) run env expr = case Eval.run env expr of ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print expr) ) + ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> ( ReplActive env, writeLine ("ERR:" ++ msg) ) @@ -146,11 +146,11 @@ read = readString -debug : String -> a -> Eval b -> Eval b -debug msg value e = +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = Eval.withEnv (\env -> - Env.debug env msg value + Env.debug env msg (f env) |> always e ) @@ -163,7 +163,7 @@ eval ast = MalApply app -> Left (debug "evalApply" - (printString True expr) + (\env -> printString env True expr) (evalApply app) ) @@ -191,7 +191,7 @@ evalApply { frameId, bound, body } = evalNoApply : MalExpr -> Eval MalExpr evalNoApply ast = debug "evalNoApply" - (printString True ast) + (\env -> printString env True ast) (case ast of MalList [] -> Eval.succeed ast @@ -222,11 +222,14 @@ evalNoApply ast = (MalFunction (CoreFunc fn)) :: args -> fn args - (MalFunction (UserFunc { fn })) :: args -> - fn args + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args fn :: _ -> - Eval.fail ((printString True fn) ++ " is not a function") + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) ) _ -> @@ -450,24 +453,27 @@ evalFn args = makeFn frameId binder body = MalFunction <| - UserFunc - { frameId = frameId - , fn = - \args -> - case binder args of - Ok bound -> - Eval.succeed <| - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. - MalApply - { frameId = frameId - , bound = bound - , body = body - } - - Err msg -> - Eval.fail msg - } + let + lazyFn args = + case binder args of + Ok bound -> + Eval.succeed <| + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + + Err msg -> + Eval.fail msg + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + } go bindsList body = case extractAndParse bindsList of @@ -497,9 +503,9 @@ evalFn args = Eval.fail "fn* expected two args: binds list and body" -print : MalExpr -> String -print = - printString True +print : Env -> MalExpr -> String +print env = + printString env True {-| Read-Eval-Print. diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 789f7ee7d9..c5f4edd3d0 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -24,16 +24,21 @@ main = } +type alias Args = + List String + + type alias Flags = - { args : List String + { args : Args } type Model - = InitIO Env (IO -> Eval MalExpr) - | InitError String + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) | ReplActive Env | ReplIO Env (IO -> Eval MalExpr) + | Stopped init : Flags -> ( Model, Cmd Msg ) @@ -45,6 +50,7 @@ init { args } = initEnv = Core.ns |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) evalMalInit = Core.malInit @@ -54,20 +60,27 @@ init { args } = (\b a -> a |> Eval.andThen (\_ -> b)) (Eval.succeed MalNil) in - runInit initEnv evalMalInit + runInit args initEnv evalMalInit update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of - InitError _ -> - -- ignore all + Stopped -> ( model, Cmd.none ) - InitIO env cont -> + InitIO args env cont -> case msg of Input (Ok io) -> - runInit env (cont io) + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) Input (Err msg) -> Debug.crash msg @@ -104,27 +117,66 @@ update msg model = Debug.crash msg ( model, Cmd.none ) -runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit env expr = +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = case Eval.run env expr of ( env, EvalOk expr ) -> - -- Init went okay, start REPL. - ( ReplActive env, readLine prompt ) + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( InitError msg, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine ("ERR:" ++ msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. - ( InitIO env cont, cmd ) + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) run env expr = case Eval.run env expr of ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print expr) ) + ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> ( ReplActive env, writeLine ("ERR:" ++ msg) ) @@ -150,11 +202,11 @@ read = readString -debug : String -> a -> Eval b -> Eval b -debug msg value e = +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = Eval.withEnv (\env -> - Env.debug env msg value + Env.debug env msg (f env) |> always e ) @@ -167,7 +219,7 @@ eval ast = MalApply app -> Left (debug "evalApply" - (printString True expr) + (\env -> printString env True expr) (evalApply app) ) @@ -205,7 +257,7 @@ evalApply { frameId, bound, body } = evalNoApply : MalExpr -> Eval MalExpr evalNoApply ast = debug "evalNoApply" - (printString True ast) + (\env -> printString env True ast) (case ast of MalList [] -> Eval.succeed ast @@ -236,11 +288,14 @@ evalNoApply ast = (MalFunction (CoreFunc fn)) :: args -> fn args - (MalFunction (UserFunc { fn })) :: args -> - fn args + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args fn :: _ -> - Eval.fail ((printString True fn) ++ " is not a function") + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) ) _ -> @@ -309,7 +364,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.set name value) + Eval.modifyEnv (Env.def name value) |> Eval.andThen (\_ -> Eval.succeed value) ) @@ -464,24 +519,27 @@ evalFn args = makeFn frameId binder body = MalFunction <| - UserFunc - { frameId = frameId - , fn = - \args -> - case binder args of - Ok bound -> - Eval.succeed <| - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. - MalApply - { frameId = frameId - , bound = bound - , body = body - } - - Err msg -> - Eval.fail msg - } + let + lazyFn args = + case binder args of + Ok bound -> + Eval.succeed <| + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + + Err msg -> + Eval.fail msg + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + } go bindsList body = case extractAndParse bindsList of @@ -511,9 +569,9 @@ evalFn args = Eval.fail "fn* expected two args: binds list and body" -print : MalExpr -> String -print = - printString True +print : Env -> MalExpr -> String +print env = + printString env True {-| Read-Eval-Print. diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm new file mode 100644 index 0000000000..71be893dca --- /dev/null +++ b/elm/step7_quote.elm @@ -0,0 +1,583 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + Core.malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + eval expr + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.leave env.currentFrameId) + |> Eval.map (\_ -> res) + ) + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (\env -> printString env True ast) + (case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.def name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) + ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + |> Eval.andThen + (\binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just From 071ce8a8ed0c71204bbe6cd07a46d2aedae27ac5 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 18 Jun 2017 21:48:31 +0200 Subject: [PATCH 0037/1998] Elm: step 6 fixed eval/def --- elm/Env.elm | 13 +++++++------ elm/step4_if_fn_do.elm | 2 +- elm/step5_tco.elm | 2 +- elm/step6_file.elm | 13 +++++++++++-- elm/step7_quote.elm | 2 +- 5 files changed, 21 insertions(+), 11 deletions(-) diff --git a/elm/Env.elm b/elm/Env.elm index e6a9bf7b91..f9ccb9306b 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -1,15 +1,16 @@ module Env exposing ( debug + , globalFrameId , global , push , pop + , jump , enter , leave , ref , get , set - , def , newAtom , getAtom , setAtom @@ -46,6 +47,11 @@ global = } +jump : Int -> Env -> Env +jump frameId env = + { env | currentFrameId = frameId } + + push : Env -> Env push env = let @@ -244,11 +250,6 @@ set name expr env = setInFrame env.currentFrameId name expr env -def : String -> MalExpr -> Env -> Env -def = - setInFrame globalFrameId - - get : String -> Env -> Result String MalExpr get name env = let diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index be30d08aa5..97b650f7db 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -253,7 +253,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.def name value) + Eval.modifyEnv (Env.set name value) |> Eval.andThen (\_ -> Eval.succeed value) ) diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index da7b9c437f..b8f205bdca 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -298,7 +298,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.def name value) + Eval.modifyEnv (Env.set name value) |> Eval.andThen (\_ -> Eval.succeed value) ) diff --git a/elm/step6_file.elm b/elm/step6_file.elm index c5f4edd3d0..6cf7b6db5e 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -234,7 +234,16 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - eval expr + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.jump Env.globalFrameId) + |> Eval.andThen (\_ -> eval expr) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.jump env.currentFrameId) + |> Eval.andThen (\_ -> Eval.succeed res) + ) + ) _ -> Eval.fail "unsupported arguments" @@ -364,7 +373,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.def name value) + Eval.modifyEnv (Env.set name value) |> Eval.andThen (\_ -> Eval.succeed value) ) diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 71be893dca..5c5fd136cb 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -356,7 +356,7 @@ evalDef args = eval uneValue |> Eval.andThen (\value -> - Eval.modifyEnv (Env.def name value) + Eval.modifyEnv (Env.set name value) |> Eval.andThen (\_ -> Eval.succeed value) ) From 496726894d8812048c9a0a3dbd9f1e2cacc64775 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 18 Jun 2017 22:21:25 +0200 Subject: [PATCH 0038/1998] Elm step 7: cons and concat --- elm/Core.elm | 26 ++++++++++++++++++++++++++ elm/Eval.elm | 12 ++++++++++++ elm/Makefile | 8 ++++---- elm/step7_quote.elm | 29 +++++++++-------------------- 4 files changed, 51 insertions(+), 24 deletions(-) diff --git a/elm/Core.elm b/elm/Core.elm index a4038e4682..d7f2cbc952 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -358,6 +358,30 @@ ns = _ -> Eval.fail "unsupported arguments" + + cons args = + case args of + [ e, MalList list ] -> + Eval.succeed <| MalList (e :: list) + + _ -> + Eval.fail "unsupported arguments" + + concat args = + let + go arg acc = + case arg of + MalList list -> + Eval.succeed (acc ++ list) + + MalVector vec -> + Eval.succeed (acc ++ Array.toList vec) + + _ -> + Eval.fail "unsupported arguments" + in + List.foldl (go >> Eval.andThen) (Eval.succeed []) args + |> Eval.map MalList in Env.global |> Env.set "+" (makeFn <| binaryOp (+) MalInt) @@ -388,6 +412,8 @@ ns = |> Env.set "gc" (makeFn gc) |> Env.set "debug!" (makeFn debug) |> Env.set "typeof" (makeFn typeof) + |> Env.set "cons" (makeFn cons) + |> Env.set "concat" (makeFn concat) malInit : List String diff --git a/elm/Eval.elm b/elm/Eval.elm index 4c581084ac..fec2d7fbd6 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -118,3 +118,15 @@ fromResult res = Err msg -> fail msg + + +{-| Chain the left and right Eval but ignore the right's result. +-} +ignore : Eval b -> Eval a -> Eval a +ignore right left = + left + |> andThen + (\res -> + right + |> andThen (\_ -> succeed res) + ) diff --git a/elm/Makefile b/elm/Makefile index 37c90f10ff..17e52a2c18 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,8 +1,8 @@ SOURCES_BASE = Reader.elm Printer.elm Utils.elm Types.elm Env.elm \ Core.elm Eval.elm IO.elm -SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm step1_read_print.elm #step2_eval.elm \ - #step3_env.elm \ - step7_quote.ls step8_macros.ls step9_try.ls stepA_mal.ls +SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm step1_read_print.elm step7_quote.elm + #step2_eval.elm step3_env.elm \ + step8_macros.ls step9_try.ls stepA_mal.ls SOURCES_LISP = #env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_STEPS) @@ -27,7 +27,7 @@ step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm step4_if_fn_do.js: $(SOURCES_BASE) step5_tco.js: $(SOURCES_BASE) step6_file.js: $(SOURCES_BASE) -# step7_quote.js: utils.js reader.js printer.js env.js core.js +step7_quote.js: $(SOURCES_BASE) # step8_macros.js: utils.js reader.js printer.js env.js core.js # step9_try.js: utils.js reader.js printer.js env.js core.js # stepA_mal.js: utils.js reader.js printer.js env.js core.js diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 5c5fd136cb..72bff9a8cb 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -246,11 +246,7 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.leave env.currentFrameId) - |> Eval.map (\_ -> res) - ) + |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) ) @@ -390,11 +386,7 @@ evalLet args = Eval.modifyEnv Env.push |> Eval.andThen (\_ -> evalBinds binds) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv Env.pop - |> Eval.map (\_ -> res) - ) + |> Eval.ignore (Eval.modifyEnv Env.pop) in case args of [ MalList binds, body ] -> @@ -535,18 +527,15 @@ evalFn args = go bindsList body = extractAndParse bindsList |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) |> Eval.andThen (\binder -> - Eval.modifyEnv Env.ref - -- reference the current frame. - |> Eval.andThen - (\_ -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) ) in case args of From 16fbc20a27d08e3e946304015efbc44567c10f42 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Tue, 20 Jun 2017 17:23:00 +0200 Subject: [PATCH 0039/1998] Elm step 7-9 --- elm/Core.elm | 360 +++++++++++++++++++- elm/Eval.elm | 17 +- elm/Makefile | 31 +- elm/Types.elm | 10 +- elm/step0_repl.elm | 3 + elm/step4_if_fn_do.elm | 11 +- elm/step5_tco.elm | 13 +- elm/step6_file.elm | 17 +- elm/step7_quote.elm | 86 ++++- elm/step8_macros.elm | 727 +++++++++++++++++++++++++++++++++++++++ elm/step9_try.elm | 749 +++++++++++++++++++++++++++++++++++++++++ 11 files changed, 1983 insertions(+), 41 deletions(-) create mode 100644 elm/step8_macros.elm create mode 100644 elm/step9_try.elm diff --git a/elm/Core.elm b/elm/Core.elm index d7f2cbc952..751077c6e8 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -1,6 +1,6 @@ module Core exposing (..) -import Types exposing (MalExpr(..), MalFunction(..), Eval, Env) +import Types exposing (MalExpr(..), MalFunction(..), Eval, Env, keywordPrefix) import Env import Eval import Printer exposing (printString) @@ -285,7 +285,6 @@ ns = swap args = case args of (MalAtom atomId) :: (MalFunction func) :: args -> - -- TODO eval apply here! Eval.withEnv (\env -> let @@ -364,6 +363,9 @@ ns = [ e, MalList list ] -> Eval.succeed <| MalList (e :: list) + [ e, MalVector vec ] -> + Eval.succeed <| MalList (e :: (Array.toList vec)) + _ -> Eval.fail "unsupported arguments" @@ -382,6 +384,327 @@ ns = in List.foldl (go >> Eval.andThen) (Eval.succeed []) args |> Eval.map MalList + + nth args = + let + get list index = + if index < 0 then + Nothing + else if index == 0 then + List.head list + else + case list of + [] -> + Nothing + + _ :: rest -> + get rest (index - 1) + + make res = + case res of + Just value -> + Eval.succeed value + + Nothing -> + Eval.fail "index out of bounds" + in + case args of + [ MalList list, MalInt index ] -> + make <| get list index + + [ MalVector vec, MalInt index ] -> + make <| Array.get index vec + + _ -> + Eval.fail "unsupported arguments" + + first args = + let + make = + Eval.succeed << Maybe.withDefault MalNil + in + case args of + [ MalNil ] -> + Eval.succeed MalNil + + [ MalList list ] -> + make <| List.head list + + [ MalVector vec ] -> + make <| Array.get 0 vec + + _ -> + Eval.fail "unsupported arguments" + + rest args = + case args of + [ MalNil ] -> + Eval.succeed <| MalList [] + + [ MalList [] ] -> + Eval.succeed <| MalList [] + + [ MalList (head :: tail) ] -> + Eval.succeed <| MalList tail + + [ MalVector vec ] -> + Array.toList vec + |> List.tail + |> Maybe.withDefault [] + |> MalList + |> Eval.succeed + + _ -> + Eval.fail "unsupported arguments" + + throw args = + case args of + [ MalString msg ] -> + Eval.fail msg + + _ -> + Eval.fail "undefined exception" + + apply args = + case args of + (MalFunction func) :: rest -> + callFn func rest + + _ -> + Eval.fail "unsupported arguments" + + map args = + let + go func list acc = + case list of + [] -> + Eval.succeed <| MalList <| List.reverse acc + + inv :: rest -> + callFn func [ inv ] + |> Eval.andThen + (\outv -> + go func rest (outv :: acc) + ) + in + case args of + [ MalFunction func, MalList list ] -> + go func list [] + + [ MalFunction func, MalVector vec ] -> + go func (Array.toList vec) [] + + _ -> + Eval.fail "unsupported arguments" + + isNil args = + Eval.succeed <| + MalBool <| + case args of + MalNil :: _ -> + True + + _ -> + False + + isTrue args = + Eval.succeed <| + MalBool <| + case args of + (MalBool True) :: _ -> + True + + _ -> + False + + isFalse args = + Eval.succeed <| + MalBool <| + case args of + (MalBool False) :: _ -> + True + + _ -> + False + + isSymbol args = + Eval.succeed <| + MalBool <| + case args of + (MalSymbol _) :: _ -> + True + + _ -> + False + + isKeyword args = + Eval.succeed <| + MalBool <| + case args of + (MalKeyword _) :: _ -> + True + + _ -> + False + + isVector args = + Eval.succeed <| + MalBool <| + case args of + (MalVector _) :: _ -> + True + + _ -> + False + + isMap args = + Eval.succeed <| + MalBool <| + case args of + (MalMap _) :: _ -> + True + + _ -> + False + + symbol args = + case args of + [ MalString str ] -> + Eval.succeed <| MalSymbol str + + _ -> + Eval.fail "unsupported arguments" + + keyword args = + case args of + [ MalString str ] -> + Eval.succeed <| MalKeyword (String.cons ':' str) + + _ -> + Eval.fail "unsupported arguments" + + vector args = + Eval.succeed <| MalVector <| Array.fromList args + + parseKey key = + case key of + MalString str -> + Ok str + + MalKeyword keyword -> + Ok <| String.cons keywordPrefix keyword + + _ -> + Err "map key must be a symbol or keyword" + + buildMap list acc = + case list of + [] -> + Eval.succeed <| MalMap acc + + key :: value :: rest -> + parseKey key + |> Eval.fromResult + |> Eval.andThen + (\key -> + buildMap rest (Dict.insert key value acc) + ) + + _ -> + Eval.fail "expected an even number of key-value pairs" + + hashMap args = + buildMap args Dict.empty + + assoc args = + case args of + (MalMap dict) :: rest -> + buildMap rest dict + + _ -> + Eval.fail "unsupported arguments" + + dissoc args = + let + go keys acc = + case keys of + [] -> + Eval.succeed <| MalMap acc + + key :: rest -> + parseKey key + |> Eval.fromResult + |> Eval.andThen + (\key -> + go rest (Dict.remove key acc) + ) + in + case args of + (MalMap dict) :: keys -> + go keys dict + + _ -> + Eval.fail "unsupported arguments" + + get args = + case args of + [ MalNil, key ] -> + Eval.succeed MalNil + + [ MalMap dict, key ] -> + parseKey key + |> Eval.fromResult + |> Eval.map + (\key -> + Dict.get key dict + |> Maybe.withDefault MalNil + ) + + _ -> + Eval.fail "unsupported arguments" + + contains args = + case args of + [ MalMap dict, key ] -> + parseKey key + |> Eval.fromResult + |> Eval.map (\key -> Dict.member key dict) + |> Eval.map MalBool + + _ -> + Eval.fail "unsupported arguments" + + unparseKey key = + case String.uncons key of + Just ( prefix, rest ) -> + if prefix == keywordPrefix then + MalKeyword rest + else + MalString key + + _ -> + MalString key + + keys args = + case args of + [ MalMap dict ] -> + Dict.keys dict + |> List.map unparseKey + |> MalList + |> Eval.succeed + + _ -> + Eval.fail "unsupported arguments" + + vals args = + case args of + [ MalMap dict ] -> + Dict.values dict + |> MalList + |> Eval.succeed + + _ -> + Eval.fail "unsupported arguments" in Env.global |> Env.set "+" (makeFn <| binaryOp (+) MalInt) @@ -414,15 +737,24 @@ ns = |> Env.set "typeof" (makeFn typeof) |> Env.set "cons" (makeFn cons) |> Env.set "concat" (makeFn concat) - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - , """(def! load-file - (fn* (f) - (eval (read-string - (str "(do " (slurp f) ")")))))""" - ] + |> Env.set "nth" (makeFn nth) + |> Env.set "first" (makeFn first) + |> Env.set "rest" (makeFn rest) + |> Env.set "throw" (makeFn throw) + |> Env.set "nil?" (makeFn isNil) + |> Env.set "true?" (makeFn isTrue) + |> Env.set "false?" (makeFn isFalse) + |> Env.set "symbol?" (makeFn isSymbol) + |> Env.set "keyword?" (makeFn isKeyword) + |> Env.set "vector?" (makeFn isVector) + |> Env.set "map?" (makeFn isMap) + |> Env.set "symbol" (makeFn symbol) + |> Env.set "keyword" (makeFn keyword) + |> Env.set "vector" (makeFn vector) + |> Env.set "hash-map" (makeFn hashMap) + |> Env.set "assoc" (makeFn assoc) + |> Env.set "dissoc" (makeFn dissoc) + |> Env.set "get" (makeFn get) + |> Env.set "contains?" (makeFn contains) + |> Env.set "keys" (makeFn keys) + |> Env.set "vals" (makeFn vals) diff --git a/elm/Eval.elm b/elm/Eval.elm index fec2d7fbd6..3fc4cf7942 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -66,6 +66,19 @@ andThen f e env = ( env, EvalIO cmd (cont >> andThen f) ) +catchError : (String -> Eval a) -> Eval a -> Eval a +catchError f e env = + case apply e env of + ( env, EvalOk res ) -> + ( env, EvalOk res ) + + ( env, EvalErr msg ) -> + apply (f msg) env + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> catchError f) ) + + fail : String -> Eval a fail msg env = ( env, EvalErr msg ) @@ -92,9 +105,9 @@ Stops if f returns (Right expr). Tail call optimized. -} -runLoop : (MalExpr -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr +runLoop : (MalExpr -> Env -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr runLoop f expr env = - case f expr of + case f expr env of Left e -> case apply e env of ( env, EvalOk expr ) -> diff --git a/elm/Makefile b/elm/Makefile index 17e52a2c18..83de99987b 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,10 +1,7 @@ -SOURCES_BASE = Reader.elm Printer.elm Utils.elm Types.elm Env.elm \ - Core.elm Eval.elm IO.elm -SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm step1_read_print.elm step7_quote.elm - #step2_eval.elm step3_env.elm \ - step8_macros.ls step9_try.ls stepA_mal.ls -SOURCES_LISP = #env.ls core.ls stepA_mal.ls -SOURCES = $(SOURCES_STEPS) +SOURCES = step0_repl.elm step1_read_print.elm \ + step4_if_fn_do.elm step5_tco.elm step6_file.elm step7_quote.elm \ + step8_macros.elm step9_try.elm # stepA_mal.ls \ + #step2_eval.elm step3_env.elm BINS = $(SOURCES:%.elm=%.js) @@ -21,15 +18,21 @@ elm_packages: %.js: %.elm node_modules $(ELM) make $(@:%.js=%.elm) --output $@ -step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm +STEP0_SOURCES = IO.elm +STEP1_SOURCES = $(STEP0_SOURCES) Reader.elm Printer.elm Utils.elm Types.elm Env.elm +STEP2_SOURCES = $(STEP1_SOURCES) +STEP3_SOURCES = $(STEP2_SOURCES) +STEP4_SOURCES = $(STEP3_SOURCES) Core.elm Eval.elm + +step1_read_print.js: $(STEP1_SOURCES) #step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm #step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm -step4_if_fn_do.js: $(SOURCES_BASE) -step5_tco.js: $(SOURCES_BASE) -step6_file.js: $(SOURCES_BASE) -step7_quote.js: $(SOURCES_BASE) -# step8_macros.js: utils.js reader.js printer.js env.js core.js -# step9_try.js: utils.js reader.js printer.js env.js core.js +step4_if_fn_do.js: $(STEP4_SOURCES) +step5_tco.js: $(STEP4_SOURCES) +step6_file.js: $(STEP4_SOURCES) +step7_quote.js: $(STEP4_SOURCES) +step8_macros.js: $(STEP4_SOURCES) +step9_try.js: $(STEP4_SOURCES) # stepA_mal.js: utils.js reader.js printer.js env.js core.js clean: diff --git a/elm/Types.elm b/elm/Types.elm index d7393f814c..81e62d02b3 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -31,7 +31,8 @@ type alias Env = } -type alias EvalCont a = IO -> Eval a +type alias EvalCont a = + IO -> Eval a type EvalResult res @@ -54,7 +55,12 @@ type alias MalFn = type MalFunction = CoreFunc MalFn - | UserFunc { frameId : Int, lazyFn : MalFn, eagerFn : MalFn } + | UserFunc + { frameId : Int + , lazyFn : MalFn + , eagerFn : MalFn + , isMacro : Bool + } type alias ApplyRec = diff --git a/elm/step0_repl.elm b/elm/step0_repl.elm index 41596b429a..972d8d6843 100644 --- a/elm/step0_repl.elm +++ b/elm/step0_repl.elm @@ -46,6 +46,9 @@ update msg model = Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Ok _) -> + ( model, Cmd.none ) + Input (Err msg) -> Debug.crash msg ( model, Cmd.none ) diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index 97b650f7db..c8e349b637 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -43,7 +43,7 @@ init { args } = Core.ns evalMalInit = - Core.malInit + malInit |> List.map rep |> justValues |> List.foldl @@ -53,6 +53,14 @@ init { args } = runInit initEnv evalMalInit +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + ] + + update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of @@ -425,6 +433,7 @@ evalFn args = { frameId = frameId , lazyFn = fn , eagerFn = fn + , isMacro = False } go bindsList body = diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index b8f205bdca..34409fb266 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -43,7 +43,7 @@ init { args } = Core.ns evalMalInit = - Core.malInit + malInit |> List.map rep |> justValues |> List.foldl @@ -53,6 +53,14 @@ init { args } = runInit initEnv evalMalInit +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + ] + + update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of @@ -158,7 +166,7 @@ debug msg f e = eval : MalExpr -> Eval MalExpr eval ast = let - apply expr = + apply expr env = case expr of MalApply app -> Left @@ -473,6 +481,7 @@ evalFn args = { frameId = frameId , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False } go bindsList body = diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 6cf7b6db5e..46dc256276 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -53,7 +53,7 @@ init { args } = |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) evalMalInit = - Core.malInit + malInit |> List.map rep |> justValues |> List.foldl @@ -63,6 +63,18 @@ init { args } = runInit args initEnv evalMalInit +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) ")")))))""" + ] + + update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of @@ -214,7 +226,7 @@ debug msg f e = eval : MalExpr -> Eval MalExpr eval ast = let - apply expr = + apply expr env = case expr of MalApply app -> Left @@ -548,6 +560,7 @@ evalFn args = { frameId = frameId , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False } go bindsList body = diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 72bff9a8cb..776741fa19 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -8,7 +8,7 @@ import Platform exposing (programWithFlags) import Types exposing (..) import Reader exposing (readString) import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) import Env import Core import Eval @@ -53,7 +53,7 @@ init { args } = |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) evalMalInit = - Core.malInit + malInit |> List.map rep |> justValues |> List.foldl @@ -63,6 +63,18 @@ init { args } = runInit args initEnv evalMalInit +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) ")")))))""" + ] + + update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of @@ -214,7 +226,7 @@ debug msg f e = eval : MalExpr -> Eval MalExpr eval ast = let - apply expr = + apply expr env = case expr of MalApply app -> Left @@ -234,7 +246,16 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - eval expr + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.jump Env.globalFrameId) + |> Eval.andThen (\_ -> eval expr) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.jump env.currentFrameId) + |> Eval.andThen (\_ -> Eval.succeed res) + ) + ) _ -> Eval.fail "unsupported arguments" @@ -273,6 +294,18 @@ evalNoApply ast = MalList ((MalSymbol "fn*") :: args) -> evalFn args + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + MalList list -> evalList list |> Eval.andThen @@ -522,6 +555,7 @@ evalFn args = { frameId = frameId , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False } go bindsList body = @@ -549,6 +583,50 @@ evalFn args = Eval.fail "fn* expected two args: binds list and body" +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + apply list empty = + case list of + [ MalSymbol "unquote", ast ] -> + ast + + (MalList [ MalSymbol "splice-unquote", ast ]) :: rest -> + makeCall "concat" + [ ast + , evalQuasiQuote (MalList rest) + ] + + ast :: rest -> + makeCall "cons" + [ evalQuasiQuote ast + , evalQuasiQuote (MalList rest) + ] + + _ -> + makeCall "quote" [ empty ] + in + case expr of + MalList list -> + apply list (MalList []) + + MalVector vec -> + apply (Array.toList vec) (MalVector Array.empty) + + ast -> + makeCall "quote" [ ast ] + + print : Env -> MalExpr -> String print env = printString env True diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm new file mode 100644 index 0000000000..70b48cbe1b --- /dev/null +++ b/elm/step8_macros.elm @@ -0,0 +1,727 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) ")")))))""" + , """(defmacro! cond + (fn* (& xs) + (if (> (count xs) 0) + (list 'if (first xs) + (if (> (count xs) 1) + (nth xs 1) + (throw "odd number of forms to cond")) + (cons 'cond (rest (rest xs)))))))""" + , """(defmacro! or + (fn* (& xs) + (if (empty? xs) + nil + (if (= 1 (count xs)) + (first xs) + `(let* (or_FIXME ~(first xs)) + (if or_FIXME or_FIXME (or ~@(rest xs))))))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.jump Env.globalFrameId) + |> Eval.andThen (\_ -> eval expr) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.jump env.currentFrameId) + |> Eval.andThen (\_ -> Eval.succeed res) + ) + ) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (\env -> printString env True ast) + (macroexpand ast + |> Eval.andThen + (\ast -> + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "defmacro!") :: args) -> + evalDefMacro args + + MalList ((MalSymbol "macroexpand") :: args) -> + case args of + [ expr ] -> + macroexpand expr + + _ -> + Eval.fail "unsupported arguments" + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + ) + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalDefMacro : List MalExpr -> Eval MalExpr +evalDefMacro args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + case value of + MalFunction (UserFunc fn) -> + let + macroFn = + MalFunction (UserFunc { fn | isMacro = True }) + in + Eval.modifyEnv (Env.set name macroFn) + |> Eval.andThen (\_ -> Eval.succeed macroFn) + + _ -> + Eval.fail "defmacro! is only supported on a user function" + ) + + _ -> + Eval.fail "defmacro! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.ignore (Eval.modifyEnv Env.pop) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + apply list empty = + case list of + [ MalSymbol "unquote", ast ] -> + ast + + (MalList [ MalSymbol "splice-unquote", ast ]) :: rest -> + makeCall "concat" + [ ast + , evalQuasiQuote (MalList rest) + ] + + ast :: rest -> + makeCall "cons" + [ evalQuasiQuote ast + , evalQuasiQuote (MalList rest) + ] + + _ -> + makeCall "quote" [ empty ] + in + case expr of + MalList list -> + apply list (MalList []) + + MalVector vec -> + apply (Array.toList vec) (MalVector Array.empty) + + ast -> + makeCall "quote" [ ast ] + + +macroexpand : MalExpr -> Eval MalExpr +macroexpand expr = + let + expand expr env = + case expr of + MalList ((MalSymbol name) :: args) -> + case Env.get name env of + Ok (MalFunction (UserFunc fn)) -> + if fn.isMacro then + Left <| fn.eagerFn args + else + Right expr + + _ -> + Right expr + + _ -> + Right expr + in + Eval.runLoop expand expr + + +print : Env -> MalExpr -> String +print env = + printString env True + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/elm/step9_try.elm b/elm/step9_try.elm new file mode 100644 index 0000000000..7d1bc30aa9 --- /dev/null +++ b/elm/step9_try.elm @@ -0,0 +1,749 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) ")")))))""" + , """(defmacro! cond + (fn* (& xs) + (if (> (count xs) 0) + (list 'if (first xs) + (if (> (count xs) 1) + (nth xs 1) + (throw "odd number of forms to cond")) + (cons 'cond (rest (rest xs)))))))""" + , """(defmacro! or + (fn* (& xs) + (if (empty? xs) + nil + (if (= 1 (count xs)) + (first xs) + `(let* (or_FIXME ~(first xs)) + (if or_FIXME or_FIXME (or ~@(rest xs))))))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine ("ERR:" ++ msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.jump Env.globalFrameId) + |> Eval.andThen (\_ -> eval expr) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.jump env.currentFrameId) + |> Eval.andThen (\_ -> Eval.succeed res) + ) + ) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + let + go ast = + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "defmacro!") :: args) -> + evalDefMacro args + + MalList ((MalSymbol "macroexpand") :: args) -> + case args of + [ expr ] -> + macroexpand expr + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "try*") :: args) -> + evalTry args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + in + debug "evalNoApply" + (\env -> printString env True ast) + (macroexpand ast |> Eval.andThen go) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalDefMacro : List MalExpr -> Eval MalExpr +evalDefMacro args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + case value of + MalFunction (UserFunc fn) -> + let + macroFn = + MalFunction (UserFunc { fn | isMacro = True }) + in + Eval.modifyEnv (Env.set name macroFn) + |> Eval.andThen (\_ -> Eval.succeed macroFn) + + _ -> + Eval.fail "defmacro! is only supported on a user function" + ) + + _ -> + Eval.fail "defmacro! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.ignore (Eval.modifyEnv Env.pop) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + apply list empty = + case list of + [ MalSymbol "unquote", ast ] -> + ast + + (MalList [ MalSymbol "splice-unquote", ast ]) :: rest -> + makeCall "concat" + [ ast + , evalQuasiQuote (MalList rest) + ] + + ast :: rest -> + makeCall "cons" + [ evalQuasiQuote ast + , evalQuasiQuote (MalList rest) + ] + + _ -> + makeCall "quote" [ empty ] + in + case expr of + MalList list -> + apply list (MalList []) + + MalVector vec -> + apply (Array.toList vec) (MalVector Array.empty) + + ast -> + makeCall "quote" [ ast ] + + +macroexpand : MalExpr -> Eval MalExpr +macroexpand expr = + let + expand expr env = + case expr of + MalList ((MalSymbol name) :: args) -> + case Env.get name env of + Ok (MalFunction (UserFunc fn)) -> + if fn.isMacro then + Left <| fn.eagerFn args + else + Right expr + + _ -> + Right expr + + _ -> + Right expr + in + Eval.runLoop expand expr + + +evalTry : List MalExpr -> Eval MalExpr +evalTry args = + case args of + [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> + eval body + |> Eval.catchError + (\msg -> + Eval.modifyEnv Env.push + |> Eval.andThen + (\_ -> + Eval.modifyEnv (Env.set sym (MalString msg)) + ) + |> Eval.andThen (\_ -> evalNoApply handler) + |> Eval.ignore (Eval.modifyEnv Env.pop) + ) + + _ -> + Eval.fail "try* expected a body a catch block" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just From c9c948de84395bffa5ae7177a57ce80230b7890e Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Fri, 23 Jun 2017 16:56:04 +0200 Subject: [PATCH 0040/1998] Elm step A --- elm/Core.elm | 161 ++++++++- elm/Env.elm | 2 +- elm/Eval.elm | 9 +- elm/IO.elm | 2 + elm/Makefile | 4 +- elm/Reader.elm | 48 ++- elm/Types.elm | 3 +- elm/step4_if_fn_do.elm | 14 +- elm/step5_tco.elm | 14 +- elm/step6_file.elm | 12 +- elm/step7_quote.elm | 12 +- elm/step8_macros.elm | 12 +- elm/step9_try.elm | 16 +- elm/stepA_mal.elm | 765 +++++++++++++++++++++++++++++++++++++++++ 14 files changed, 1017 insertions(+), 57 deletions(-) create mode 100644 elm/stepA_mal.elm diff --git a/elm/Core.elm b/elm/Core.elm index 751077c6e8..ffda42b575 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -1,6 +1,6 @@ module Core exposing (..) -import Types exposing (MalExpr(..), MalFunction(..), Eval, Env, keywordPrefix) +import Types exposing (..) import Env import Eval import Printer exposing (printString) @@ -9,6 +9,8 @@ import Dict import IO exposing (IO(..)) import Reader import Utils exposing (zip) +import Time +import Task ns : Env @@ -459,8 +461,8 @@ ns = throw args = case args of - [ MalString msg ] -> - Eval.fail msg + ex :: _ -> + Eval.throw ex _ -> Eval.fail "undefined exception" @@ -468,7 +470,18 @@ ns = apply args = case args of (MalFunction func) :: rest -> - callFn func rest + case List.reverse rest of + (MalList last) :: middle -> + callFn func ((List.reverse middle) ++ last) + + (MalVector last) :: middle -> + callFn func + ((List.reverse middle) + ++ (Array.toList last) + ) + + _ -> + Eval.fail "apply expected the last argument to be a list or vector" _ -> Eval.fail "unsupported arguments" @@ -567,6 +580,29 @@ ns = _ -> False + isString args = + Eval.succeed <| + MalBool <| + case args of + (MalString _) :: _ -> + True + + _ -> + False + + isSequential args = + Eval.succeed <| + MalBool <| + case args of + (MalList _) :: _ -> + True + + (MalVector _) :: _ -> + True + + _ -> + False + symbol args = case args of [ MalString str ] -> @@ -705,6 +741,113 @@ ns = _ -> Eval.fail "unsupported arguments" + + readLine args = + case args of + [ MalString prompt ] -> + Eval.io (IO.readLine prompt) + (\msg -> + case msg of + LineRead (Just line) -> + Eval.succeed (MalString line) + + LineRead Nothing -> + Eval.succeed MalNil + + _ -> + Eval.fail "wrong IO, expected LineRead" + ) + + _ -> + Eval.fail "unsupported arguments" + + withMeta args = + case args of + [ MalFunction (UserFunc func), meta ] -> + Eval.succeed <| MalFunction <| UserFunc { func | meta = Just meta } + + _ -> + Eval.fail "with-meta expected a user function and a map" + + meta args = + case args of + [ MalFunction (UserFunc { meta }) ] -> + Eval.succeed (Maybe.withDefault MalNil meta) + + _ -> + Eval.succeed MalNil + + conj args = + case args of + (MalList list) :: rest -> + Eval.succeed <| + MalList <| + (List.reverse rest) + ++ list + + (MalVector vec) :: rest -> + Eval.succeed <| + MalVector <| + Array.append + vec + (Array.fromList rest) + + _ -> + Eval.fail "unsupported arguments" + + seq args = + case args of + [ MalNil ] -> + Eval.succeed MalNil + + [ MalList [] ] -> + Eval.succeed MalNil + + [ MalString "" ] -> + Eval.succeed MalNil + + [ (MalList _) as list ] -> + Eval.succeed list + + [ MalVector vec ] -> + Eval.succeed <| + if Array.isEmpty vec then + MalNil + else + MalList <| Array.toList vec + + [ MalString str ] -> + Eval.succeed <| + MalList <| + (String.toList str + |> List.map String.fromChar + |> List.map MalString + ) + + _ -> + Eval.fail "unsupported arguments" + + requestTime = + Task.perform (GotTime >> Ok >> Input) Time.now + + timeMs args = + case args of + [] -> + Eval.io requestTime + (\msg -> + case msg of + GotTime time -> + Time.inMilliseconds time + |> truncate + |> MalInt + |> Eval.succeed + + _ -> + Eval.fail "wrong IO, expected GotTime" + ) + + _ -> + Eval.fail "time-ms takes no arguments" in Env.global |> Env.set "+" (makeFn <| binaryOp (+) MalInt) @@ -741,6 +884,8 @@ ns = |> Env.set "first" (makeFn first) |> Env.set "rest" (makeFn rest) |> Env.set "throw" (makeFn throw) + |> Env.set "apply" (makeFn apply) + |> Env.set "map" (makeFn map) |> Env.set "nil?" (makeFn isNil) |> Env.set "true?" (makeFn isTrue) |> Env.set "false?" (makeFn isFalse) @@ -748,6 +893,8 @@ ns = |> Env.set "keyword?" (makeFn isKeyword) |> Env.set "vector?" (makeFn isVector) |> Env.set "map?" (makeFn isMap) + |> Env.set "string?" (makeFn isString) + |> Env.set "sequential?" (makeFn isSequential) |> Env.set "symbol" (makeFn symbol) |> Env.set "keyword" (makeFn keyword) |> Env.set "vector" (makeFn vector) @@ -758,3 +905,9 @@ ns = |> Env.set "contains?" (makeFn contains) |> Env.set "keys" (makeFn keys) |> Env.set "vals" (makeFn vals) + |> Env.set "readline" (makeFn readLine) + |> Env.set "with-meta" (makeFn withMeta) + |> Env.set "meta" (makeFn meta) + |> Env.set "conj" (makeFn conj) + |> Env.set "seq" (makeFn seq) + |> Env.set "time-ms" (makeFn timeMs) diff --git a/elm/Env.elm b/elm/Env.elm index f9ccb9306b..658ee1a553 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -266,7 +266,7 @@ get name env = Nothing -> frame.outerId |> Maybe.map go - |> Maybe.withDefault (Err "symbol not found") + |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") in go env.currentFrameId diff --git a/elm/Eval.elm b/elm/Eval.elm index 3fc4cf7942..ddead03182 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -66,7 +66,7 @@ andThen f e env = ( env, EvalIO cmd (cont >> andThen f) ) -catchError : (String -> Eval a) -> Eval a -> Eval a +catchError : (MalExpr -> Eval a) -> Eval a -> Eval a catchError f e env = case apply e env of ( env, EvalOk res ) -> @@ -81,7 +81,12 @@ catchError f e env = fail : String -> Eval a fail msg env = - ( env, EvalErr msg ) + ( env, EvalErr <| MalString msg ) + + +throw : MalExpr -> Eval a +throw ex env = + ( env, EvalErr ex ) enter : Int -> List ( String, MalExpr ) -> Eval a -> Eval a diff --git a/elm/IO.elm b/elm/IO.elm index 48ff9c439c..a67f151984 100644 --- a/elm/IO.elm +++ b/elm/IO.elm @@ -9,6 +9,7 @@ port module IO ) import Json.Decode exposing (..) +import Time exposing (Time) {-| Output a string to stdout @@ -36,6 +37,7 @@ type IO | LineWritten | FileRead String | Exception String + | GotTime Time decodeIO : Decoder IO diff --git a/elm/Makefile b/elm/Makefile index 83de99987b..40ac7eff71 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,6 +1,6 @@ SOURCES = step0_repl.elm step1_read_print.elm \ step4_if_fn_do.elm step5_tco.elm step6_file.elm step7_quote.elm \ - step8_macros.elm step9_try.elm # stepA_mal.ls \ + step8_macros.elm step9_try.elm stepA_mal.elm #step2_eval.elm step3_env.elm BINS = $(SOURCES:%.elm=%.js) @@ -33,7 +33,7 @@ step6_file.js: $(STEP4_SOURCES) step7_quote.js: $(STEP4_SOURCES) step8_macros.js: $(STEP4_SOURCES) step9_try.js: $(STEP4_SOURCES) -# stepA_mal.js: utils.js reader.js printer.js env.js core.js +stepA_mal.js: $(STEP4_SOURCES) clean: rm -f $(BINS) diff --git a/elm/Reader.elm b/elm/Reader.elm index 11c4e5cf4e..c770460171 100644 --- a/elm/Reader.elm +++ b/elm/Reader.elm @@ -18,36 +18,36 @@ ws = many (comment <|> string "," <|> whitespace) -nil : Parser s MalExpr -nil = - MalNil <$ string "nil" "nil" - - int : Parser s MalExpr int = MalInt <$> Combine.Num.int "int" -bool : Parser s MalExpr -bool = - MalBool - <$> choice - [ True <$ string "true" - , False <$ string "false" - ] - "bool" - - symbolString : Parser s String symbolString = regex "[^\\s\\[\\]{}('\"`,;)]+" -symbol : Parser s MalExpr -symbol = - MalSymbol - <$> symbolString - "symbol" +symbolOrConst : Parser s MalExpr +symbolOrConst = + let + make sym = + case sym of + "nil" -> + MalNil + + "true" -> + MalBool True + + "false" -> + MalBool False + + _ -> + MalSymbol sym + in + make + <$> symbolString + "symbol" keywordString : Parser s String @@ -112,11 +112,9 @@ atom : Parser s MalExpr atom = choice [ int - , bool - , str - , nil , keyword - , symbol + , symbolOrConst + , str ] "atom" @@ -159,7 +157,7 @@ withMeta = makeCall "with-meta" [ expr, meta ] in make - <$> (string "^" *> map) + <$> (string "^" *> form) <*> form "with-meta" diff --git a/elm/Types.elm b/elm/Types.elm index 81e62d02b3..2fb55ec910 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -36,7 +36,7 @@ type alias EvalCont a = type EvalResult res - = EvalErr String + = EvalErr MalExpr | EvalOk res | EvalIO (Cmd Msg) (EvalCont res) @@ -60,6 +60,7 @@ type MalFunction , lazyFn : MalFn , eagerFn : MalFn , isMacro : Bool + , meta : Maybe MalExpr } diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index c8e349b637..e524426b44 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -31,7 +31,7 @@ type alias Flags = type Model = InitIO Env (IO -> Eval MalExpr) - | InitError String + | InitError | ReplActive Env | ReplIO Env (IO -> Eval MalExpr) @@ -64,7 +64,7 @@ malInit = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of - InitError _ -> + InitError -> -- ignore all ( model, Cmd.none ) @@ -117,7 +117,7 @@ runInit env expr = ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( InitError msg, writeLine ("ERR:" ++ msg) ) + ( InitError, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. @@ -131,7 +131,7 @@ run env expr = ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> - ( ReplActive env, writeLine ("ERR:" ++ msg) ) + ( ReplActive env, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ReplIO env cont, cmd ) @@ -434,6 +434,7 @@ evalFn args = , lazyFn = fn , eagerFn = fn , isMacro = False + , meta = Nothing } go bindsList body = @@ -469,6 +470,11 @@ print env = printString env True +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + {-| Read-Eval-Print. Doesn't actually run the Eval but returns the monad. diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index 34409fb266..7938325eae 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -31,7 +31,7 @@ type alias Flags = type Model = InitIO Env (IO -> Eval MalExpr) - | InitError String + | InitError | ReplActive Env | ReplIO Env (IO -> Eval MalExpr) @@ -64,7 +64,7 @@ malInit = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case model of - InitError _ -> + InitError -> -- ignore all ( model, Cmd.none ) @@ -117,7 +117,7 @@ runInit env expr = ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( InitError msg, writeLine ("ERR:" ++ msg) ) + ( InitError, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. @@ -131,7 +131,7 @@ run env expr = ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> - ( ReplActive env, writeLine ("ERR:" ++ msg) ) + ( ReplActive env, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ReplIO env cont, cmd ) @@ -482,6 +482,7 @@ evalFn args = , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False + , meta = Nothing } go bindsList body = @@ -517,6 +518,11 @@ print env = printString env True +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + {-| Read-Eval-Print. Doesn't actually run the Eval but returns the monad. diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 46dc256276..5c7013d357 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -146,7 +146,7 @@ runInit args env expr = ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. @@ -178,7 +178,7 @@ runScriptLoop env expr = ( Stopped, Cmd.none ) ( env, EvalErr msg ) -> - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ScriptIO env cont, cmd ) @@ -191,7 +191,7 @@ run env expr = ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> - ( ReplActive env, writeLine ("ERR:" ++ msg) ) + ( ReplActive env, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ReplIO env cont, cmd ) @@ -561,6 +561,7 @@ evalFn args = , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False + , meta = Nothing } go bindsList body = @@ -596,6 +597,11 @@ print env = printString env True +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + {-| Read-Eval-Print. Doesn't actually run the Eval but returns the monad. diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 776741fa19..330c2ffdfe 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -146,7 +146,7 @@ runInit args env expr = ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. @@ -178,7 +178,7 @@ runScriptLoop env expr = ( Stopped, Cmd.none ) ( env, EvalErr msg ) -> - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ScriptIO env cont, cmd ) @@ -191,7 +191,7 @@ run env expr = ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> - ( ReplActive env, writeLine ("ERR:" ++ msg) ) + ( ReplActive env, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ReplIO env cont, cmd ) @@ -556,6 +556,7 @@ evalFn args = , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False + , meta = Nothing } go bindsList body = @@ -632,6 +633,11 @@ print env = printString env True +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + {-| Read-Eval-Print. Doesn't actually run the Eval but returns the monad. diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm index 70b48cbe1b..9ca040b6ad 100644 --- a/elm/step8_macros.elm +++ b/elm/step8_macros.elm @@ -162,7 +162,7 @@ runInit args env expr = ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. @@ -194,7 +194,7 @@ runScriptLoop env expr = ( Stopped, Cmd.none ) ( env, EvalErr msg ) -> - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ScriptIO env cont, cmd ) @@ -207,7 +207,7 @@ run env expr = ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> - ( ReplActive env, writeLine ("ERR:" ++ msg) ) + ( ReplActive env, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ReplIO env cont, cmd ) @@ -611,6 +611,7 @@ evalFn args = , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False + , meta = Nothing } go bindsList body = @@ -709,6 +710,11 @@ print env = printString env True +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + {-| Read-Eval-Print. Doesn't actually run the Eval but returns the monad. diff --git a/elm/step9_try.elm b/elm/step9_try.elm index 7d1bc30aa9..699843757b 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -162,7 +162,7 @@ runInit args env expr = ( env, EvalErr msg ) -> -- Init failed, don't start REPL. - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> -- IO in init. @@ -194,7 +194,7 @@ runScriptLoop env expr = ( Stopped, Cmd.none ) ( env, EvalErr msg ) -> - ( Stopped, writeLine ("ERR:" ++ msg) ) + ( Stopped, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ScriptIO env cont, cmd ) @@ -207,7 +207,7 @@ run env expr = ( ReplActive env, writeLine (print env expr) ) ( env, EvalErr msg ) -> - ( ReplActive env, writeLine ("ERR:" ++ msg) ) + ( ReplActive env, writeLine (printError env msg) ) ( env, EvalIO cmd cont ) -> ( ReplIO env cont, cmd ) @@ -613,6 +613,7 @@ evalFn args = , lazyFn = lazyFn , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False + , meta = Nothing } go bindsList body = @@ -712,11 +713,11 @@ evalTry args = [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> eval body |> Eval.catchError - (\msg -> + (\ex -> Eval.modifyEnv Env.push |> Eval.andThen (\_ -> - Eval.modifyEnv (Env.set sym (MalString msg)) + Eval.modifyEnv (Env.set sym ex) ) |> Eval.andThen (\_ -> evalNoApply handler) |> Eval.ignore (Eval.modifyEnv Env.pop) @@ -731,6 +732,11 @@ print env = printString env True +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + {-| Read-Eval-Print. Doesn't actually run the Eval but returns the monad. diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm new file mode 100644 index 0000000000..4186852057 --- /dev/null +++ b/elm/stepA_mal.elm @@ -0,0 +1,765 @@ +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + |> Env.set "*host-language*" (MalString "elm") + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) ")")))))""" + , """(defmacro! cond + (fn* (& xs) + (if (> (count xs) 0) + (list 'if (first xs) + (if (> (count xs) 1) + (nth xs 1) + (throw "odd number of forms to cond")) + (cons 'cond (rest (rest xs)))))))""" + , """(def! *gensym-counter* (atom 0))""" + , """(def! gensym + (fn* [] (symbol + (str "G__" + (swap! *gensym-counter* + (fn* [x] (+ 1 x)))))))""" + , """(defmacro! or + (fn* (& xs) + (if (empty? xs) + nil + (if (= 1 (count xs)) + (first xs) + (let* (condvar (gensym)) + `(let* (~condvar ~(first xs)) + (if ~condvar + ~condvar + (or ~@(rest xs)))))))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.jump Env.globalFrameId) + |> Eval.andThen (\_ -> eval expr) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.jump env.currentFrameId) + |> Eval.andThen (\_ -> Eval.succeed res) + ) + ) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + let + go ast = + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "defmacro!") :: args) -> + evalDefMacro args + + MalList ((MalSymbol "macroexpand") :: args) -> + case args of + [ expr ] -> + macroexpand expr + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "try*") :: args) -> + evalTry args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + in + debug "evalNoApply" + (\env -> printString env True ast) + (macroexpand ast |> Eval.andThen go) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalDefMacro : List MalExpr -> Eval MalExpr +evalDefMacro args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + case value of + MalFunction (UserFunc fn) -> + let + macroFn = + MalFunction (UserFunc { fn | isMacro = True }) + in + Eval.modifyEnv (Env.set name macroFn) + |> Eval.andThen (\_ -> Eval.succeed macroFn) + + _ -> + Eval.fail "defmacro! is only supported on a user function" + ) + + _ -> + Eval.fail "defmacro! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.ignore (Eval.modifyEnv Env.pop) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + -- TODO : choice Env.enter prematurely? + -- I think it is needed by the garbage collect.. + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + apply list empty = + case list of + [ MalSymbol "unquote", ast ] -> + ast + + (MalList [ MalSymbol "splice-unquote", ast ]) :: rest -> + makeCall "concat" + [ ast + , evalQuasiQuote (MalList rest) + ] + + ast :: rest -> + makeCall "cons" + [ evalQuasiQuote ast + , evalQuasiQuote (MalList rest) + ] + + _ -> + makeCall "quote" [ empty ] + in + case expr of + MalList list -> + apply list (MalList []) + + MalVector vec -> + apply (Array.toList vec) (MalVector Array.empty) + + ast -> + makeCall "quote" [ ast ] + + +macroexpand : MalExpr -> Eval MalExpr +macroexpand expr = + let + expand expr env = + case expr of + MalList ((MalSymbol name) :: args) -> + case Env.get name env of + Ok (MalFunction (UserFunc fn)) -> + if fn.isMacro then + Left <| fn.eagerFn args + else + Right expr + + _ -> + Right expr + + _ -> + Right expr + in + Eval.runLoop expand expr + + +evalTry : List MalExpr -> Eval MalExpr +evalTry args = + case args of + [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> + eval body + |> Eval.catchError + (\ex -> + Eval.modifyEnv Env.push + |> Eval.andThen + (\_ -> + Eval.modifyEnv (Env.set sym ex) + ) + |> Eval.andThen (\_ -> evalNoApply handler) + |> Eval.ignore (Eval.modifyEnv Env.pop) + ) + + _ -> + Eval.fail "try* expected a body a catch block" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "ERR:" ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just From ac9c71d69ec19ab5aa502a197e71f0c34a0ac6f1 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Fri, 23 Jun 2017 17:05:53 +0200 Subject: [PATCH 0041/1998] Elm step A: fix time-ms --- elm/Core.elm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elm/Core.elm b/elm/Core.elm index ffda42b575..02dc946853 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -838,7 +838,7 @@ ns = case msg of GotTime time -> Time.inMilliseconds time - |> truncate + |> floor |> MalInt |> Eval.succeed From 74547df6e4e2feab74fe1cd9a5665e71ca1ee9f2 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 25 Jun 2017 10:59:09 +0200 Subject: [PATCH 0042/1998] Elm: fix step 2 and 3 --- elm/Makefile | 12 ++++++------ elm/step2_eval.elm | 29 ++++++++++++++++++++-------- elm/step3_env.elm | 48 ++++++++++++++++++++++++++++++---------------- 3 files changed, 59 insertions(+), 30 deletions(-) diff --git a/elm/Makefile b/elm/Makefile index 40ac7eff71..d9724a99f6 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,7 +1,6 @@ -SOURCES = step0_repl.elm step1_read_print.elm \ - step4_if_fn_do.elm step5_tco.elm step6_file.elm step7_quote.elm \ - step8_macros.elm step9_try.elm stepA_mal.elm - #step2_eval.elm step3_env.elm +SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ + step3_env.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm \ + step7_quote.elm step8_macros.elm step9_try.elm stepA_mal.elm BINS = $(SOURCES:%.elm=%.js) @@ -24,9 +23,10 @@ STEP2_SOURCES = $(STEP1_SOURCES) STEP3_SOURCES = $(STEP2_SOURCES) STEP4_SOURCES = $(STEP3_SOURCES) Core.elm Eval.elm +step0_repl.js: $(STEP0_SOURCES) step1_read_print.js: $(STEP1_SOURCES) -#step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm -#step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm +step2_eval.js: $(STEP2_SOURCES) +step3_env.js: $(STEP3_SOURCES) step4_if_fn_do.js: $(STEP4_SOURCES) step5_tco.js: $(STEP4_SOURCES) step6_file.js: $(STEP4_SOURCES) diff --git a/elm/step2_eval.elm b/elm/step2_eval.elm index 7f7b85c8f5..39ebf8a751 100644 --- a/elm/step2_eval.elm +++ b/elm/step2_eval.elm @@ -3,13 +3,15 @@ port module Main exposing (..) import IO exposing (..) import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) -import Types exposing (MalExpr(..), MalFunction(..)) +import Types exposing (..) import Reader exposing (readString) import Printer exposing (printString) import Utils exposing (maybeToList, zip) import Dict exposing (Dict) -import Tuple exposing (mapFirst) +import Tuple exposing (mapFirst, second) import Array +import Eval +import Env main : Program Flags Model Msg @@ -55,10 +57,10 @@ initReplEnv = binaryOp fn args = case args of [ MalInt x, MalInt y ] -> - Ok <| MalInt (fn x y) + Eval.succeed <| MalInt (fn x y) _ -> - Err "unsupported arguments" + Eval.fail "unsupported arguments" in Dict.fromList [ ( "+", makeFn <| binaryOp (+) ) @@ -85,6 +87,9 @@ update msg model = Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + Input (Err msg) -> Debug.crash msg ( model, Cmd.none ) @@ -129,11 +134,19 @@ eval env ast = [] -> ( Err "can't happen", newEnv ) - (MalFunction fn) :: args -> - ( fn args, newEnv ) + (MalFunction (CoreFunc fn)) :: args -> + case second <| Eval.run Env.global (fn args) of + EvalOk res -> + ( Ok res, newEnv ) + + EvalErr msg -> + ( Err (print msg), newEnv ) + + _ -> + Debug.crash "can't happen" fn :: _ -> - ( Err ((printString True fn) ++ " is not a function"), newEnv ) + ( Err ((print fn) ++ " is not a function"), newEnv ) ( Err msg, newEnv ) -> ( Err msg, newEnv ) @@ -219,7 +232,7 @@ tryMapList fn list = print : MalExpr -> String print = - printString True + printString Env.global True {-| Read-Eval-Print. rep returns: diff --git a/elm/step3_env.elm b/elm/step3_env.elm index 1f5c44ba5f..ddcb858f55 100644 --- a/elm/step3_env.elm +++ b/elm/step3_env.elm @@ -3,14 +3,15 @@ port module Main exposing (..) import IO exposing (..) import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) -import Types exposing (MalExpr(..)) +import Types exposing (..) import Reader exposing (readString) import Printer exposing (printString) import Utils exposing (maybeToList, zip) import Dict exposing (Dict) -import Tuple exposing (mapFirst, mapSecond) +import Tuple exposing (mapFirst, mapSecond, second) import Array -import Env exposing (Env) +import Env +import Eval main : Program Flags Model Msg @@ -45,19 +46,22 @@ init { args } = initReplEnv : Env initReplEnv = let + makeFn = + CoreFunc >> MalFunction + binaryOp fn args = case args of [ MalInt x, MalInt y ] -> - Ok <| MalInt (fn x y) + Eval.succeed <| MalInt (fn x y) _ -> - Err "unsupported arguments" + Eval.fail "unsupported arguments" in - Env.make Nothing - |> Env.set "+" (MalFunction <| binaryOp (+)) - |> Env.set "-" (MalFunction <| binaryOp (-)) - |> Env.set "*" (MalFunction <| binaryOp (*)) - |> Env.set "/" (MalFunction <| binaryOp (//)) + Env.global + |> Env.set "+" (makeFn <| binaryOp (+)) + |> Env.set "-" (makeFn <| binaryOp (-)) + |> Env.set "*" (makeFn <| binaryOp (*)) + |> Env.set "/" (makeFn <| binaryOp (//)) update : Msg -> Model -> ( Model, Cmd Msg ) @@ -77,6 +81,9 @@ update msg model = Input (Ok (LineRead Nothing)) -> ( model, Cmd.none ) + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + Input (Err msg) -> Debug.crash msg ( model, Cmd.none ) @@ -127,11 +134,19 @@ eval env ast = [] -> ( Err "can't happen", newEnv ) - (MalFunction fn) :: args -> - ( fn args, newEnv ) + (MalFunction (CoreFunc fn)) :: args -> + case second <| Eval.run Env.global (fn args) of + EvalOk res -> + ( Ok res, newEnv ) + + EvalErr msg -> + ( Err (print msg), newEnv ) + + _ -> + Debug.crash "can't happen" fn :: _ -> - ( Err ((printString True fn) ++ " is not a function"), newEnv ) + ( Err ((print fn) ++ " is not a function"), newEnv ) ( Err msg, newEnv ) -> ( Err msg, newEnv ) @@ -229,9 +244,10 @@ evalLet env args = Err "let* expected an even number of binds (symbol expr ..)" go binds body = - case evalBinds (Env.make (Just env)) binds of + case evalBinds (Env.push env) binds of Ok newEnv -> - mapSecond (\_ -> env) (eval newEnv body) + eval newEnv body + |> mapSecond (\_ -> Env.pop newEnv) Err msg -> ( Err msg, env ) @@ -274,7 +290,7 @@ tryMapList fn list = print : MalExpr -> String print = - printString True + printString Env.global True {-| Read-Eval-Print. rep returns: From 908bb61f763938a9a23b0657ae58e64effa294b0 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Thu, 29 Jun 2017 00:59:18 +0200 Subject: [PATCH 0043/1998] Implement step 0 --- Makefile | 3 ++- gst/Makefile | 17 +++++++++++++++++ gst/readline.st | 20 ++++++++++++++++++++ gst/run | 2 ++ gst/step0_repl.st | 34 ++++++++++++++++++++++++++++++++++ 5 files changed, 75 insertions(+), 1 deletion(-) create mode 100644 gst/Makefile create mode 100644 gst/readline.st create mode 100755 gst/run create mode 100644 gst/step0_repl.st diff --git a/Makefile b/Makefile index ab2b4fd058..cc8e49eb98 100644 --- a/Makefile +++ b/Makefile @@ -78,7 +78,7 @@ DOCKERIZE = # IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs dart \ - erlang elisp elixir es6 factor forth fsharp go groovy guile haskell \ + erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ python r racket rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ @@ -175,6 +175,7 @@ forth_STEP_TO_PROG = forth/$($(1)).fs fsharp_STEP_TO_PROG = fsharp/$($(1)).exe go_STEP_TO_PROG = go/$($(1)) groovy_STEP_TO_PROG = groovy/$($(1)).groovy +gst_STEP_TO_PROG = gst/$($(1)).st java_STEP_TO_PROG = java/target/classes/mal/$($(1)).class haskell_STEP_TO_PROG = haskell/$($(1)) haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(HAXE_MODE)) diff --git a/gst/Makefile b/gst/Makefile new file mode 100644 index 0000000000..f6c19c8d68 --- /dev/null +++ b/gst/Makefile @@ -0,0 +1,17 @@ +SOURCES_BASE = readline.st reader.st printer.st types.st +SOURCES_LISP = env.st func.st core.st stepA_mal.st +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + +clean: + +.PHONY: stats tests $(TESTS) + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" + diff --git a/gst/readline.st b/gst/readline.st new file mode 100644 index 0000000000..2dca73c7b6 --- /dev/null +++ b/gst/readline.st @@ -0,0 +1,20 @@ +DLD addLibrary: 'libreadline'. +DLD addLibrary: 'libhistory'. + +Object subclass: ReadLine [ + ReadLine class >> readLine: prompt [ + + ] + + ReadLine class >> addHistory: item [ + + ] + + ReadLine class >> readHistory: filePath [ + + ] + + ReadLine class >> writeHistory: filePath [ + + ] +] diff --git a/gst/run b/gst/run new file mode 100755 index 0000000000..4d413ea72d --- /dev/null +++ b/gst/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec gst -f $(dirname $0)/${STEP:-stepA_mal}.st "${@}" diff --git a/gst/step0_repl.st b/gst/step0_repl.st new file mode 100644 index 0000000000..982d89db02 --- /dev/null +++ b/gst/step0_repl.st @@ -0,0 +1,34 @@ +FileStream fileIn: 'readline.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^input + ] + + MAL class >> EVAL: sexp [ + ^sexp + ] + + MAL class >> PRINT: sexp [ + ^sexp + ] + + MAL class >> rep: input [ + ^self PRINT: (self EVAL: (self READ: input)) + ] +] + +| input historyFile | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + (MAL rep: input) displayNl. + ] +] + +'' displayNl. From 34aa5ced023ae3b6dc58de82e6c84fba6b8b2b8f Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 2 Jul 2017 14:41:36 +0200 Subject: [PATCH 0044/1998] Implement step 1 --- gst/Makefile | 2 +- gst/printer.st | 52 ++++++++++++ gst/reader.st | 173 ++++++++++++++++++++++++++++++++++++++++ gst/step1_read_print.st | 39 +++++++++ gst/types.st | 146 +++++++++++++++++++++++++++++++++ gst/util.st | 30 +++++++ 6 files changed, 441 insertions(+), 1 deletion(-) create mode 100644 gst/printer.st create mode 100644 gst/reader.st create mode 100644 gst/step1_read_print.st create mode 100644 gst/types.st create mode 100644 gst/util.st diff --git a/gst/Makefile b/gst/Makefile index f6c19c8d68..c876270e97 100644 --- a/gst/Makefile +++ b/gst/Makefile @@ -1,4 +1,4 @@ -SOURCES_BASE = readline.st reader.st printer.st types.st +SOURCES_BASE = readline.st reader.st printer.st types.st util.st SOURCES_LISP = env.st func.st core.st stepA_mal.st SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) diff --git a/gst/printer.st b/gst/printer.st new file mode 100644 index 0000000000..cfcf58ccc5 --- /dev/null +++ b/gst/printer.st @@ -0,0 +1,52 @@ +FileStream fileIn: 'types.st'. + +Object subclass: Printer [ + Printer class >> prStr: sexp printReadably: printReadably [ + sexp type = #true ifTrue: [ ^'true' ]. + sexp type = #false ifTrue: [ ^'false' ]. + sexp type = #nil ifTrue: [ ^'nil' ]. + + sexp type = #number ifTrue: [ ^sexp value asString ]. + sexp type = #symbol ifTrue: [ ^sexp value asString ]. + sexp type = #keyword ifTrue: [ ^':', sexp value ]. + + sexp type = #string ifTrue: [ + printReadably ifTrue: [ + ^sexp value repr + ] ifFalse: [ + ^sexp value + ] + ]. + + sexp type = #list ifTrue: [ + ^self prList: sexp printReadably: printReadably + starter: '(' ender: ')' + ]. + sexp type = #vector ifTrue: [ + ^self prList: sexp printReadably: printReadably + starter: '[' ender: ']' + ]. + sexp type = #map ifTrue: [ + ^self prMap: sexp printReadably: printReadably + ]. + + Error halt: 'unimplemented type' + ] + + Printer class >> prList: sexp printReadably: printReadably + starter: starter ender: ender [ + | items | + items := sexp value collect: + [ :item | self prStr: item printReadably: printReadably ]. + ^starter, (items join: ' ') , ender + ] + + Printer class >> prMap: sexp printReadably: printReadably [ + | items | + items := sexp value associations collect: + [ :item | + (self prStr: item key printReadably: printReadably), ' ', + (self prStr: item value printReadably: printReadably) ]. + ^'{', (items join: ', '), '}' + ] +] diff --git a/gst/reader.st b/gst/reader.st new file mode 100644 index 0000000000..4938b735d2 --- /dev/null +++ b/gst/reader.st @@ -0,0 +1,173 @@ +FileStream fileIn: 'types.st'. +FileStream fileIn: 'util.st'. + +Object subclass: Reader [ + | storage index | + + TokenRegex := '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}(''"`,;)]*)'. + CommentRegex := ';.*'. + NumberRegex := '-?[0-9]+(?:\.[0-9]+)?'. + + Reader class >> tokenizer: input [ + | tokens token hit pos done | + tokens := OrderedCollection new. + pos := 1. + done := false. + + [done] whileFalse: [ + hit := input searchRegex: TokenRegex startingAt: pos. + token := hit at: 1. + token size = 0 ifTrue: [ + tokens add: (input copyFrom: pos to: input size) trimSeparators. + done := true. + ]. + (token size = 0 or: [token matchRegex: CommentRegex]) ifFalse: [ + tokens add: token + ]. + pos := pos + (hit match size). + pos > input size ifTrue: [ + done := true. + ]. + ]. + ^tokens + ] + + Reader class >> readStr: input [ + | tokens reader form | + tokens := self tokenizer: input. + reader := self new: tokens. + tokens isEmpty ifTrue: [ + ^MALEmptyInput new signal + ]. + ^self readForm: reader. + ] + + Reader class >> readForm: reader [ + | token | + token := reader peek. + token = '(' ifTrue: [ + ^self readList: reader class: MALList ender: ')' + ]. + token = '[' ifTrue: [ + ^self readList: reader class: MALVector ender: ']' + ]. + token = '{' ifTrue: [ + ^self readList: reader class: MALMap ender: '}' + ]. + + (token matchRegex: '[])}]') ifTrue: [ + ^MALUnexpectedToken new signal: token + ]. + + token = '''' ifTrue: [ + ^self readSimpleMacro: reader name: #quote + ]. + token = '`' ifTrue: [ + ^self readSimpleMacro: reader name: #quasiquote + ]. + token = '~' ifTrue: [ + ^self readSimpleMacro: reader name: #unquote + ]. + token = '~@' ifTrue: [ + ^self readSimpleMacro: reader name: #'splice-unquote' + ]. + token = '@' ifTrue: [ + ^self readSimpleMacro: reader name: #deref + ]. + + token = '^' ifTrue: [ + ^self readWithMetaMacro: reader + ]. + + ^self readAtom: reader + ] + + Reader class >> readList: reader class: aClass ender: ender [ + | storage token | + storage := OrderedCollection new. + "pop opening token" + reader next. + [ token := reader peek. token isNil ] whileFalse: [ + token = ender ifTrue: [ + ender = '}' ifTrue: [ + storage := storage asDictionary. + ]. + "pop closing token" + reader next. + ^aClass new: storage + ]. + storage add: (self readForm: reader). + ]. + ^MALUnterminatedSequence new signal: ender + ] + + Reader class >> readAtom: reader [ + | token | + token := reader next. + + token = 'true' ifTrue: [ ^MALObject True ]. + token = 'false' ifTrue: [ ^MALObject False ]. + token = 'nil' ifTrue: [ ^MALObject Nil ]. + + (token first = $") ifTrue: [ + (token last = $") ifTrue: [ + ^MALString new: token parse + ] ifFalse: [ + ^MALUnterminatedSequence new signal: '"' + ] + ]. + + (token matchRegex: NumberRegex) ifTrue: [ + ^MALNumber new: token asNumber + ]. + + (token first = $:) ifTrue: [ + ^MALKeyword new: token allButFirst asSymbol + ]. + + ^MALSymbol new: token asSymbol + ] + + Reader class >> readSimpleMacro: reader name: name [ + | form list | + "pop reader macro token" + reader next. + form := self readForm: reader. + list := OrderedCollection from: { MALSymbol new: name. form }. + ^MALList new: list + ] + + Reader class >> readWithMetaMacro: reader [ + | form meta list | + "pop reader macro token" + reader next. + meta := self readForm: reader. + form := self readForm: reader. + list := OrderedCollection from: + { MALSymbol new: #'with-meta'. form. meta }. + ^MALList new: list + ] + + Reader class >> new: tokens [ + | reader | + reader := super new. + reader init: tokens. + ^reader + ] + + init: tokens [ + storage := tokens. + index := 1. + ] + + peek [ + ^storage at: index ifAbsent: [ ^nil ] + ] + + next [ + | token | + token := self peek. + index := index + 1. + ^token + ] +] diff --git a/gst/step1_read_print.st b/gst/step1_read_print.st new file mode 100644 index 0000000000..6b33705a97 --- /dev/null +++ b/gst/step1_read_print.st @@ -0,0 +1,39 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> EVAL: sexp [ + ^sexp + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input [ + ^self PRINT: (self EVAL: (self READ: input)) + ] +] + +| input historyFile | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/gst/types.st b/gst/types.st new file mode 100644 index 0000000000..f03cb74863 --- /dev/null +++ b/gst/types.st @@ -0,0 +1,146 @@ +Object subclass: MALObject [ + | type value meta | + + type [ ^type ] + value [ ^value ] + meta [ ^meta ] + + setValue: aValue [ + value := aValue. + ] + + setMeta: aMeta [ + meta := aMeta. + ] + + MALObject class >> new: type value: value meta: meta [ + | object | + object := super new. + object init: type value: value meta: meta. + ^object + ] + + init: aType value: aValue meta: aMeta [ + type := aType. + value := aValue. + meta := aMeta. + ] + + withMeta: meta [ + | object | + object := self deepCopy. + object setMeta: meta. + ^object + ] + + printOn: stream [ + stream nextPutAll: '<'; + nextPutAll: self class printString; + nextPutAll: ': '; + nextPutAll: value printString. + meta notNil ifTrue: [ + stream nextPutAll: ' | ' + nextPutAll: meta printString. + ]. + stream nextPutAll: '>'. + ] +] + +MALObject subclass: MALTrue [ + MALTrue class >> new [ + ^super new: #true value: true meta: nil. + ] +] + +MALObject subclass: MALFalse [ + MALFalse class >> new [ + ^super new: #false value: false meta: nil. + ] +] + +MALObject subclass: MALNil [ + MALNil class >> new [ + ^super new: #nil value: nil meta: nil. + ] +] + +MALObject class extend [ + True := MALTrue new. + False := MALFalse new. + Nil := MALNil new. + + True [ ^True ] + False [ ^False ] + Nil [ ^Nil ] +] + +MALObject subclass: MALNumber [ + MALNumber class >> new: value [ + ^super new: #number value: value meta: nil. + ] +] + +MALObject subclass: MALString [ + MALString class >> new: value [ + ^super new: #string value: value meta: nil. + ] +] + +MALObject subclass: MALSymbol [ + MALSymbol class >> new: value [ + ^super new: #symbol value: value meta: nil. + ] +] + +MALObject subclass: MALKeyword [ + MALKeyword class >> new: value [ + ^super new: #keyword value: value meta: nil. + ] +] + +MALObject subclass: MALList [ + MALList class >> new: value [ + ^super new: #list value: value meta: nil. + ] +] + +MALObject subclass: MALVector [ + MALVector class >> new: value [ + ^super new: #vector value: value meta: nil. + ] +] + +MALObject subclass: MALMap [ + MALMap class >> new: value [ + ^super new: #map value: value meta: nil. + ] +] + +MALObject subclass: MALAtom [ + MALAtom class >> new: value [ + ^super new: #atom value: value meta: nil. + ] +] + +Error subclass: MALError [ + description [ ^'A MAL-related error' ] + isResumable [ ^true ] +] + +MALError subclass: MALUnterminatedSequence [ + MALUnterminatedSequence class >> new [ ^super new ] + + messageText [ ^'expected ''', self basicMessageText, ''', got EOF' ] +] + +MALError subclass: MALUnexpectedToken [ + MALUnexpectedToken class >> new [ ^super new ] + + messageText [ ^'unexpected token: ''', self basicMessageText, ''''] +] + +MALError subclass: MALEmptyInput [ + MALEmptyInput class >> new [ ^super new ] + + messageText [ ^'Empty input' ] +] diff --git a/gst/util.st b/gst/util.st new file mode 100644 index 0000000000..82e64ec63f --- /dev/null +++ b/gst/util.st @@ -0,0 +1,30 @@ +OrderedCollection extend [ + asDictionary [ + | dict assoc | + dict := Dictionary new. + 1 to: self size by: 2 do: + [ :i | dict add: (self at: i) -> (self at: i + 1) ]. + ^dict + ] +] + +String extend [ + parse [ + |text| + text := self copyFrom: 2 to: self size - 1. + text := text copyReplaceAll: '\"' with: '"'. + text := text copyReplaceAll: '\n' with: ' +'. + text := text copyReplaceAll: '\\' with: '\'. + ^text + ] + + repr [ + |text| + text := self copyReplaceAll: '\' with: '\\'. + text := text copyReplaceAll: ' +' with: '\n'. + text := text copyReplaceAll: '"' with: '\"'. + ^'"', text, '"' + ] +] From 1b18f3590abddd904ca2a189c5c91c7c3a0b606e Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 2 Jul 2017 22:13:53 +0200 Subject: [PATCH 0045/1998] Implement step 2 --- gst/printer.st | 1 + gst/step2_eval.st | 82 +++++++++++++++++++++++++++++++++++++++++++++++ gst/types.st | 6 ++++ 3 files changed, 89 insertions(+) create mode 100644 gst/step2_eval.st diff --git a/gst/printer.st b/gst/printer.st index cfcf58ccc5..8cf6d6d985 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -2,6 +2,7 @@ FileStream fileIn: 'types.st'. Object subclass: Printer [ Printer class >> prStr: sexp printReadably: printReadably [ + sexp class = BlockClosure ifTrue: [ ^'#' ]. sexp type = #true ifTrue: [ ^'true' ]. sexp type = #false ifTrue: [ ^'false' ]. sexp type = #nil ifTrue: [ ^'nil' ]. diff --git a/gst/step2_eval.st b/gst/step2_eval.st new file mode 100644 index 0000000000..c105f9497b --- /dev/null +++ b/gst/step2_eval.st @@ -0,0 +1,82 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env at: sexp value ifAbsent: [ + ^MALUnknownSymbol new signal: sexp value + ]. + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: sexp env: env [ + | forms function args | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + ^function valueWithArguments: args + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Dictionary from: + { #+ -> [ :a :b | MALNumber new: a value + b value ]. + #- -> [ :a :b | MALNumber new: a value - b value ]. + #* -> [ :a :b | MALNumber new: a value * b value ]. + #/ -> [ :a :b | MALNumber new: a value // b value ] }. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/gst/types.st b/gst/types.st index f03cb74863..6bf88f48d2 100644 --- a/gst/types.st +++ b/gst/types.st @@ -144,3 +144,9 @@ MALError subclass: MALEmptyInput [ messageText [ ^'Empty input' ] ] + +MALError subclass: MALUnknownSymbol [ + MALUnknownSymbol class >> new [ ^super new ] + + messageText [ ^'''', self basicMessageText, ''' not found'] +] From 4ade8121f77b50e34c9026729fcf7604eaaed490 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 3 Jul 2017 09:29:21 +0200 Subject: [PATCH 0046/1998] Implement step 3 --- gst/env.st | 42 +++++++++++++++++++ gst/step3_env.st | 104 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 146 insertions(+) create mode 100644 gst/env.st create mode 100644 gst/step3_env.st diff --git a/gst/env.st b/gst/env.st new file mode 100644 index 0000000000..c73a828228 --- /dev/null +++ b/gst/env.st @@ -0,0 +1,42 @@ +FileStream fileIn: 'types.st'. + +Object subclass: Env [ + | data outer | + + Env class >> new: outerEnv [ + | env | + env := super new. + env init: outerEnv. + ^env + ] + + init: env [ + data := Dictionary new. + outer := env. + ] + + set: key value: value [ + data at: key put: value. + ] + + find: key [ + ^data at: key ifAbsent: [ + outer notNil ifTrue: [ + outer find: key + ] ifFalse: [ + nil + ] + ] + ] + + get: key [ + | value | + value := self find: key. + + value notNil ifTrue: [ + ^value + ] ifFalse: [ + ^MALUnknownSymbol new signal: key + ] + ] +] diff --git a/gst/step3_env.st b/gst/step3_env.st new file mode 100644 index 0000000000..bb7e8a14a7 --- /dev/null +++ b/gst/step3_env.st @@ -0,0 +1,104 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: sexp env: env [ + | ast a0_ a1_ a2 forms function args | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) env: env_) ]. + ^self EVAL: a2 env: env_ + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + ^function valueWithArguments: args + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +replEnv set: #+ value: [ :a :b | MALNumber new: a value + b value ]. +replEnv set: #- value: [ :a :b | MALNumber new: a value - b value ]. +replEnv set: #* value: [ :a :b | MALNumber new: a value * b value ]. +replEnv set: #/ value: [ :a :b | MALNumber new: a value // b value ]. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. From adb2ac7840fc004687a114462c5a647fecc2ce86 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 5 Jul 2017 09:15:41 +0200 Subject: [PATCH 0047/1998] Implement step 4 --- gst/core.st | 59 +++++++++++++++++++ gst/env.st | 17 +++++- gst/step4_if_fn_do.st | 132 ++++++++++++++++++++++++++++++++++++++++++ gst/types.st | 19 ++++++ 4 files changed, 225 insertions(+), 2 deletions(-) create mode 100644 gst/core.st create mode 100644 gst/step4_if_fn_do.st diff --git a/gst/core.st b/gst/core.st new file mode 100644 index 0000000000..f4f397f6ef --- /dev/null +++ b/gst/core.st @@ -0,0 +1,59 @@ +FileStream fileIn: 'types.st'. +FileStream fileIn: 'printer.st'. + +Object subclass: Core [ + Ns := Dictionary new. + Core class >> Ns [ ^Ns ] + + Core class >> coerce: block [ + block value ifTrue: [ ^MALObject True ] ifFalse: [ ^MALObject False ] + ] + + Core class >> printedArgs: args readable: readable sep: sep [ + | items | + items := args collect: + [ :arg | Printer prStr: arg printReadably: readable ]. + "NOTE: {} join returns the unchanged array" + items isEmpty ifTrue: [ ^'' ] ifFalse: [ ^items join: sep ] + ] +] + +Core Ns at: #+ put: + [ :args | MALNumber new: args first value + args second value ]. +Core Ns at: #- put: + [ :args | MALNumber new: args first value - args second value ]. +Core Ns at: #* put: + [ :args | MALNumber new: args first value * args second value ]. +Core Ns at: #/ put: + [ :args | MALNumber new: args first value // args second value ]. + +Core Ns at: #'pr-str' put: + [ :args | MALString new: (Core printedArgs: args readable: true sep: ' ') ]. +Core Ns at: #str put: + [ :args | MALString new: (Core printedArgs: args readable: false sep: '') ]. +Core Ns at: #prn put: + [ :args | (Core printedArgs: args readable: true sep: ' ') displayNl. + MALObject Nil ]. +Core Ns at: #println put: + [ :args | (Core printedArgs: args readable: false sep: ' ') displayNl. + MALObject Nil ]. + +Core Ns at: #list put: [ :args | MALList new: (OrderedCollection from: args) ]. +Core Ns at: #'list?' put: + [ :args | Core coerce: [ args first type = #list ] ]. +Core Ns at: #'empty?' put: + [ :args | Core coerce: [ args first value isEmpty ] ]. +Core Ns at: #count put: + [ :args | MALNumber new: args first value size ]. + +Core Ns at: #= put: + [ :args | Core coerce: [ args first = args second ] ]. + +Core Ns at: #< put: + [ :args | Core coerce: [ args first value < args second value ] ]. +Core Ns at: #<= put: + [ :args | Core coerce: [ args first value <= args second value ] ]. +Core Ns at: #> put: + [ :args | Core coerce: [ args first value > args second value ] ]. +Core Ns at: #>= put: + [ :args | Core coerce: [ args first value >= args second value ] ]. diff --git a/gst/env.st b/gst/env.st index c73a828228..ee9111cd07 100644 --- a/gst/env.st +++ b/gst/env.st @@ -4,15 +4,28 @@ Object subclass: Env [ | data outer | Env class >> new: outerEnv [ + ^self new: outerEnv binds: {} exprs: {} + ] + + Env class >> new: outerEnv binds: binds exprs: exprs [ | env | env := super new. - env init: outerEnv. + env init: outerEnv binds: binds exprs: exprs. ^env ] - init: env [ + init: env binds: binds exprs: exprs [ data := Dictionary new. outer := env. + 1 to: binds size do: + [ :i | (binds at: i) = #& ifTrue: [ + | rest | + rest := MALList new: (exprs copyFrom: i). + self set: (binds at: i + 1) value: rest. + ^nil + ] ifFalse: [ + self set: (binds at: i) value: (exprs at: i) + ] ] ] set: key value: value [ diff --git a/gst/step4_if_fn_do.st b/gst/step4_if_fn_do.st new file mode 100644 index 0000000000..138b967838 --- /dev/null +++ b/gst/step4_if_fn_do.st @@ -0,0 +1,132 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: sexp env: env [ + | ast a0_ a1 a1_ a1_n a2 a3 forms function args | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) env: env_) ]. + ^self EVAL: a2 env: env_ + ]. + + a0_ = #do ifTrue: [ + a1_n := ast allButFirst. + ^(a1_n collect: [ :item | self EVAL: item env: env]) last + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: [ condition type = #nil ]) ifTrue: [ + ^self EVAL: a3 env: env + ] ifFalse: [ + ^self EVAL: a2 env: env + ] + ]. + + a0_ = #'fn*' ifTrue: [ + | binds | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + ^[ :args | self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ] + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + ^function value: args + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/gst/types.st b/gst/types.st index 6bf88f48d2..d9015e8106 100644 --- a/gst/types.st +++ b/gst/types.st @@ -44,6 +44,15 @@ Object subclass: MALObject [ ]. stream nextPutAll: '>'. ] + + = x [ + self type ~= x type ifTrue: [ ^false ]. + ^self value = x value + ] + + hash [ + ^self value hash + ] ] MALObject subclass: MALTrue [ @@ -102,12 +111,22 @@ MALObject subclass: MALList [ MALList class >> new: value [ ^super new: #list value: value meta: nil. ] + + = x [ + (x type ~= #list and: [ x type ~= #vector ]) ifTrue: [ ^false ]. + ^self value = x value + ] ] MALObject subclass: MALVector [ MALVector class >> new: value [ ^super new: #vector value: value meta: nil. ] + + = x [ + (x type ~= #vector and: [ x type ~= #list ]) ifTrue: [ ^false ]. + ^self value = x value + ] ] MALObject subclass: MALMap [ From 6da164bde8cb5e64b56e19ccc4e809e58a7020ae Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Thu, 6 Jul 2017 22:54:34 +0200 Subject: [PATCH 0048/1998] Implement step 5 --- gst/func.st | 22 ++++++ gst/printer.st | 1 + gst/step5_tco.st | 169 +++++++++++++++++++++++++++++++++++++++++++++++ gst/util.st | 6 ++ 4 files changed, 198 insertions(+) create mode 100644 gst/func.st create mode 100644 gst/step5_tco.st diff --git a/gst/func.st b/gst/func.st new file mode 100644 index 0000000000..90ecd62063 --- /dev/null +++ b/gst/func.st @@ -0,0 +1,22 @@ +Object subclass: Func [ + | ast params env fn | + + ast [ ^ast ] + params [ ^params ] + env [ ^env ] + fn [ ^fn ] + + Func class >> new: ast params: params env: env fn: fn [ + | func | + func := super new. + func init: ast params: params env: env fn: fn. + ^func + ] + + init: anAst params: someParams env: anEnv fn: aFn [ + ast := anAst. + params := someParams. + env := anEnv. + fn := aFn. + ] +] diff --git a/gst/printer.st b/gst/printer.st index 8cf6d6d985..5543892263 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -3,6 +3,7 @@ FileStream fileIn: 'types.st'. Object subclass: Printer [ Printer class >> prStr: sexp printReadably: printReadably [ sexp class = BlockClosure ifTrue: [ ^'#' ]. + sexp class = Func ifTrue: [ ^'#' ]. sexp type = #true ifTrue: [ ^'true' ]. sexp type = #false ifTrue: [ ^'false' ]. sexp type = #nil ifTrue: [ ^'nil' ]. diff --git a/gst/step5_tco.st b/gst/step5_tco.st new file mode 100644 index 0000000000..1515f211da --- /dev/null +++ b/gst/step5_tco.st @@ -0,0 +1,169 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'func.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0_ a1 a1_ a2 a3 an forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0_ := ast first value. + + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function class = BlockClosure ifTrue: [ ^function value: args ]. + function class = Func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/gst/util.st b/gst/util.st index 82e64ec63f..4a93866f23 100644 --- a/gst/util.st +++ b/gst/util.st @@ -28,3 +28,9 @@ String extend [ ^'"', text, '"' ] ] + +BlockClosure extend [ + valueWithExit [ + ^self value: [ ^nil ] + ] +] From e3ce370c5f91f3f196bb207f40037519faf90292 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 7 Jul 2017 18:36:48 +0200 Subject: [PATCH 0049/1998] Implement step 6 --- gst/core.st | 27 +++++++ gst/func.st | 14 +++- gst/printer.st | 4 + gst/step6_file.st | 185 ++++++++++++++++++++++++++++++++++++++++++++++ gst/types.st | 6 +- 5 files changed, 232 insertions(+), 4 deletions(-) create mode 100644 gst/step6_file.st diff --git a/gst/core.st b/gst/core.st index f4f397f6ef..c8b699d6bf 100644 --- a/gst/core.st +++ b/gst/core.st @@ -1,5 +1,6 @@ FileStream fileIn: 'types.st'. FileStream fileIn: 'printer.st'. +FileStream fileIn: 'reader.st'. Object subclass: Core [ Ns := Dictionary new. @@ -57,3 +58,29 @@ Core Ns at: #> put: [ :args | Core coerce: [ args first value > args second value ] ]. Core Ns at: #>= put: [ :args | Core coerce: [ args first value >= args second value ] ]. + +Core Ns at: #'read-string' put: + [ :args | Reader readStr: args first value ]. +Core Ns at: #slurp put: + [ :args | MALString new: (File path: args first value) contents ]. + +Core Ns at: #atom put: + [ :args | MALAtom new: args first ]. +Core Ns at: #'atom?' put: + [ :args | Core coerce: [ args first type = #atom ] ]. +Core Ns at: #deref put: + [ :args | args first value ]. +Core Ns at: #'reset!' put: + [ :args | args first value: args second. args second ]. +Core Ns at: #'swap!' put: + [ :args | + | a f x xs result | + a := args first. + f := args second. + f class = Func ifTrue: [ f := f fn ]. + x := a value. + xs := args allButFirst: 2. + result := f value: (xs copyWithFirst: x). + a value: result. + result + ]. diff --git a/gst/func.st b/gst/func.st index 90ecd62063..ccff241e90 100644 --- a/gst/func.st +++ b/gst/func.st @@ -1,10 +1,15 @@ Object subclass: Func [ - | ast params env fn | + | ast params env fn meta | ast [ ^ast ] params [ ^params ] env [ ^env ] fn [ ^fn ] + meta [ ^meta ] + + meta: aMeta [ + meta := aMeta + ] Func class >> new: ast params: params env: env fn: fn [ | func | @@ -19,4 +24,11 @@ Object subclass: Func [ env := anEnv. fn := aFn. ] + + withMeta: meta [ + | func | + func := self deepCopy. + func meta: meta. + ^func + ] ] diff --git a/gst/printer.st b/gst/printer.st index 5543892263..7079a49a28 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -32,6 +32,10 @@ Object subclass: Printer [ ^self prMap: sexp printReadably: printReadably ]. + sexp type = #atom ifTrue: [ + ^'(atom ', (self prStr: sexp value printReadably: printReadably), ')' + ]. + Error halt: 'unimplemented type' ] diff --git a/gst/step6_file.st b/gst/step6_file.st new file mode 100644 index 0000000000..f7d6edb289 --- /dev/null +++ b/gst/step6_file.st @@ -0,0 +1,185 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'func.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp class = BlockClosure ifTrue: [^sexp ]. + + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a3 an forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + (sexp class = BlockClosure or: [ sexp type ~= #list ]) ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0 := ast first. + + a0 class ~= BlockClosure ifTrue: [ + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ] + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function class = BlockClosure ifTrue: [ ^function value: args ]. + function class = Func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/gst/types.st b/gst/types.st index d9015e8106..4938b1b60f 100644 --- a/gst/types.st +++ b/gst/types.st @@ -5,11 +5,11 @@ Object subclass: MALObject [ value [ ^value ] meta [ ^meta ] - setValue: aValue [ + value: aValue [ value := aValue. ] - setMeta: aMeta [ + meta: aMeta [ meta := aMeta. ] @@ -29,7 +29,7 @@ Object subclass: MALObject [ withMeta: meta [ | object | object := self deepCopy. - object setMeta: meta. + object meta: meta. ^object ] From 243c27c3b8c792e20ad5e8908d20164db020c29d Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 7 Jul 2017 20:36:14 +0200 Subject: [PATCH 0050/1998] Stylistic fixes --- gst/reader.st | 2 +- gst/step5_tco.st | 2 +- gst/step6_file.st | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gst/reader.st b/gst/reader.st index 4938b735d2..2cbeea0353 100644 --- a/gst/reader.st +++ b/gst/reader.st @@ -161,7 +161,7 @@ Object subclass: Reader [ ] peek [ - ^storage at: index ifAbsent: [ ^nil ] + ^storage at: index ifAbsent: [ nil ] ] next [ diff --git a/gst/step5_tco.st b/gst/step5_tco.st index 1515f211da..7ac7f1bbca 100644 --- a/gst/step5_tco.st +++ b/gst/step5_tco.st @@ -36,7 +36,7 @@ Object subclass: MAL [ ] MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0_ a1 a1_ a2 a3 an forms function args | + | sexp env ast a0_ a1 a1_ a2 a3 forms function args | "NOTE: redefinition of method arguments is not allowed" sexp := aSexp. diff --git a/gst/step6_file.st b/gst/step6_file.st index f7d6edb289..8040d66f80 100644 --- a/gst/step6_file.st +++ b/gst/step6_file.st @@ -38,7 +38,7 @@ Object subclass: MAL [ ] MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0 a0_ a1 a1_ a2 a3 an forms function args | + | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | "NOTE: redefinition of method arguments is not allowed" sexp := aSexp. From d586e01498e228273de6591c8d6ba0d12a447528 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 7 Jul 2017 20:36:27 +0200 Subject: [PATCH 0051/1998] Implement step 7 --- gst/core.st | 6 ++ gst/step7_quote.st | 229 +++++++++++++++++++++++++++++++++++++++++++++ gst/types.st | 5 + 3 files changed, 240 insertions(+) create mode 100644 gst/step7_quote.st diff --git a/gst/core.st b/gst/core.st index c8b699d6bf..a59f774d26 100644 --- a/gst/core.st +++ b/gst/core.st @@ -84,3 +84,9 @@ Core Ns at: #'swap!' put: a value: result. result ]. + +Core Ns at: #cons put: + [ :args | MALList new: (args second value copyWithFirst: args first) ]. +Core Ns at: #concat put: + [ :args | MALList new: (OrderedCollection join: + (args collect: [ :arg | arg value ])) ]. diff --git a/gst/step7_quote.st b/gst/step7_quote.st new file mode 100644 index 0000000000..6ca5aabac0 --- /dev/null +++ b/gst/step7_quote.st @@ -0,0 +1,229 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'func.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp class = BlockClosure ifTrue: [^sexp ]. + + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> quasiquote: ast [ + | result a a0 a0_ a0_0 a0_1 rest | + ast isPair ifFalse: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + + a := ast value. + a0 := a first. + + (a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ]. + + a0 isPair ifTrue: [ + a0_ := a0 value. + a0_0 := a0_ first. + a0_1 := a0_ second. + + (a0_0 type = #symbol and: + [ a0_0 value = #'splice-unquote' ]) ifTrue: [ + rest := MALList new: a allButFirst. + result := {MALSymbol new: #concat. a0_1. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + ]. + + rest := MALList new: a allButFirst. + result := {MALSymbol new: #cons. self quasiquote: a0. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + (sexp class = BlockClosure or: [ sexp type ~= #list ]) ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0 := ast first. + + a0 class ~= BlockClosure ifTrue: [ + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ] + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function class = BlockClosure ifTrue: [ ^function value: args ]. + function class = Func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/gst/types.st b/gst/types.st index 4938b1b60f..e40638d8e2 100644 --- a/gst/types.st +++ b/gst/types.st @@ -33,6 +33,11 @@ Object subclass: MALObject [ ^object ] + isPair [ + ^(self type = #list or: [ self type = #vector ]) and: + [ self value notEmpty ] + ] + printOn: stream [ stream nextPutAll: '<'; nextPutAll: self class printString; From cfb42291cf51742c51fc1af1ea1df43c87f26fee Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 8 Jul 2017 18:41:39 +0200 Subject: [PATCH 0052/1998] Elm step A: fixed Env ref counting, fixed unwinding of Env on error. --- elm/Env.elm | 109 ++++++++++++++++++++++++------------------- elm/Eval.elm | 18 +++++++ elm/step6_file.elm | 6 +-- elm/step7_quote.elm | 10 ++-- elm/step8_macros.elm | 10 ++-- elm/step9_try.elm | 14 ++---- elm/stepA_mal.elm | 14 ++---- 7 files changed, 97 insertions(+), 84 deletions(-) diff --git a/elm/Env.elm b/elm/Env.elm index 658ee1a553..5f083a8742 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -47,6 +47,16 @@ global = } +getFrame : Int -> Env -> Frame +getFrame frameId env = + case Dict.get frameId env.frames of + Just frame -> + frame + + Nothing -> + Debug.crash <| "frame #" ++ (toString frameId) ++ " not found" + + jump : Int -> Env -> Env jump frameId env = { env | currentFrameId = frameId } @@ -73,24 +83,19 @@ pop env = let frameId = env.currentFrameId - in - case Dict.get frameId env.frames of - Just currentFrame -> - case currentFrame.outerId of - Just outerId -> - { env - | currentFrameId = outerId - , frames = Dict.update frameId deref env.frames - } - _ -> - Debug.crash "tried to pop global frame" + frame = + getFrame frameId env + in + case frame.outerId of + Just outerId -> + { env + | currentFrameId = outerId + , frames = Dict.update frameId free env.frames + } - Nothing -> - Debug.crash <| - "current frame " - ++ (toString frameId) - ++ " doesn't exist" + _ -> + Debug.crash "tried to pop global frame" setBinds : List ( String, MalExpr ) -> Frame -> Frame @@ -128,29 +133,39 @@ leave orgFrameId env = in { env | currentFrameId = orgFrameId - , frames = Dict.update frameId deref env.frames + , frames = Dict.update frameId free env.frames } -{-| Increase refCnt for the current frame +{-| Increase refCnt for the current frame, +and all it's parent frames. -} ref : Env -> Env ref env = let - incRef = - Maybe.map - (\frame -> + go frameId env = + let + frame = + getFrame frameId env + + newFrame = { frame | refCnt = frame.refCnt + 1 } - ) - newFrames = - Dict.update env.currentFrameId incRef env.frames + newEnv = + { env | frames = Dict.insert frameId newFrame env.frames } + in + case frame.outerId of + Just outerId -> + go outerId newEnv + + Nothing -> + newEnv in - { env | frames = newFrames } + go env.currentFrameId env -deref : Maybe Frame -> Maybe Frame -deref = +free : Maybe Frame -> Maybe Frame +free = Maybe.andThen (\frame -> if frame.refCnt == 1 then @@ -162,6 +177,9 @@ deref = {-| Given an Env see which frames are not reachable from the global frame. Return a new Env without the unreachable frames. + +TODO include current expression. + -} gc : Env -> Env gc env = @@ -230,9 +248,12 @@ emptyFrame outerId = } -setInFrame : Int -> String -> MalExpr -> Env -> Env -setInFrame frameId name expr env = +set : String -> MalExpr -> Env -> Env +set name expr env = let + frameId = + env.currentFrameId + updateFrame = Maybe.map (\frame -> @@ -245,28 +266,22 @@ setInFrame frameId name expr env = { env | frames = newFrames } -set : String -> MalExpr -> Env -> Env -set name expr env = - setInFrame env.currentFrameId name expr env - - get : String -> Env -> Result String MalExpr get name env = let go frameId = - case Dict.get frameId env.frames of - Nothing -> - Err <| "frame " ++ (toString frameId) ++ " not found" - - Just frame -> - case Dict.get name frame.data of - Just value -> - Ok value - - Nothing -> - frame.outerId - |> Maybe.map go - |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") + let + frame = + getFrame frameId env + in + case Dict.get name frame.data of + Just value -> + Ok value + + Nothing -> + frame.outerId + |> Maybe.map go + |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") in go env.currentFrameId diff --git a/elm/Eval.elm b/elm/Eval.elm index ddead03182..cba0b41cde 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -53,6 +53,9 @@ map f e env = ( env, EvalIO cmd (cont >> map f) ) +{-| Chain two Eval's together. The function f takes the result from +the left eval and generates a new Eval. +-} andThen : (a -> Eval b) -> Eval a -> Eval b andThen f e env = case apply e env of @@ -66,6 +69,21 @@ andThen f e env = ( env, EvalIO cmd (cont >> andThen f) ) +{-| Apply a transformation to the Env, for a Ok and a Err. +-} +finally : (Env -> Env) -> Eval a -> Eval a +finally f e env = + case apply e env of + ( env, EvalOk res ) -> + ( f env, EvalOk res ) + + ( env, EvalErr msg ) -> + ( f env, EvalErr msg ) + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> finally f) ) + + catchError : (MalExpr -> Eval a) -> Eval a -> Eval a catchError f e env = case apply e env of diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 5c7013d357..1577b90e33 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -250,11 +250,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.jump env.currentFrameId) - |> Eval.andThen (\_ -> Eval.succeed res) - ) + |> Eval.finally (Env.jump env.currentFrameId) ) _ -> diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 330c2ffdfe..c10724df3a 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -250,11 +250,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.jump env.currentFrameId) - |> Eval.andThen (\_ -> Eval.succeed res) - ) + |> Eval.finally (Env.jump env.currentFrameId) ) _ -> @@ -267,7 +263,7 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + |> Eval.finally (Env.leave env.currentFrameId) ) @@ -419,7 +415,7 @@ evalLet args = Eval.modifyEnv Env.push |> Eval.andThen (\_ -> evalBinds binds) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv Env.pop) + |> Eval.finally Env.pop in case args of [ MalList binds, body ] -> diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm index 9ca040b6ad..f3c8cb8e80 100644 --- a/elm/step8_macros.elm +++ b/elm/step8_macros.elm @@ -266,11 +266,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.jump env.currentFrameId) - |> Eval.andThen (\_ -> Eval.succeed res) - ) + |> Eval.finally (Env.jump env.currentFrameId) ) _ -> @@ -283,7 +279,7 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + |> Eval.finally (Env.leave env.currentFrameId) ) @@ -474,7 +470,7 @@ evalLet args = Eval.modifyEnv Env.push |> Eval.andThen (\_ -> evalBinds binds) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv Env.pop) + |> Eval.finally Env.pop in case args of [ MalList binds, body ] -> diff --git a/elm/step9_try.elm b/elm/step9_try.elm index 699843757b..b67d35429b 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -266,11 +266,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.jump env.currentFrameId) - |> Eval.andThen (\_ -> Eval.succeed res) - ) + |> Eval.finally (Env.jump env.currentFrameId) ) _ -> @@ -283,7 +279,7 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + |> Eval.finally (Env.leave env.currentFrameId) ) @@ -476,7 +472,7 @@ evalLet args = Eval.modifyEnv Env.push |> Eval.andThen (\_ -> evalBinds binds) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv Env.pop) + |> Eval.finally Env.pop in case args of [ MalList binds, body ] -> @@ -719,8 +715,8 @@ evalTry args = (\_ -> Eval.modifyEnv (Env.set sym ex) ) - |> Eval.andThen (\_ -> evalNoApply handler) - |> Eval.ignore (Eval.modifyEnv Env.pop) + |> Eval.andThen (\_ -> eval handler) + |> Eval.finally Env.pop ) _ -> diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm index 4186852057..5f8675f3b4 100644 --- a/elm/stepA_mal.elm +++ b/elm/stepA_mal.elm @@ -276,11 +276,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.jump env.currentFrameId) - |> Eval.andThen (\_ -> Eval.succeed res) - ) + |> Eval.finally (Env.jump env.currentFrameId) ) _ -> @@ -293,7 +289,7 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv (Env.leave env.currentFrameId)) + |> Eval.finally (Env.leave env.currentFrameId) ) @@ -486,7 +482,7 @@ evalLet args = Eval.modifyEnv Env.push |> Eval.andThen (\_ -> evalBinds binds) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.ignore (Eval.modifyEnv Env.pop) + |> Eval.finally Env.pop in case args of [ MalList binds, body ] -> @@ -729,8 +725,8 @@ evalTry args = (\_ -> Eval.modifyEnv (Env.set sym ex) ) - |> Eval.andThen (\_ -> evalNoApply handler) - |> Eval.ignore (Eval.modifyEnv Env.pop) + |> Eval.andThen (\_ -> eval handler) + |> Eval.finally Env.pop ) _ -> From ae4600c7a5a0d0317dfdf3f74915547c14eede70 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 8 Jul 2017 19:49:09 +0200 Subject: [PATCH 0053/1998] Implement step 8 --- gst/core.st | 26 ++++ gst/func.st | 8 +- gst/step8_macros.st | 285 ++++++++++++++++++++++++++++++++++++++++++++ gst/types.st | 6 + 4 files changed, 324 insertions(+), 1 deletion(-) create mode 100644 gst/step8_macros.st diff --git a/gst/core.st b/gst/core.st index a59f774d26..13708bde3b 100644 --- a/gst/core.st +++ b/gst/core.st @@ -90,3 +90,29 @@ Core Ns at: #cons put: Core Ns at: #concat put: [ :args | MALList new: (OrderedCollection join: (args collect: [ :arg | arg value ])) ]. +Core Ns at: #nth put: + [ :args | + | items index | + items := args first value. + index := args second value + 1. + items at: index ifAbsent: [ MALOutOfBounds new signal ] + ]. +Core Ns at: #first put: + [ :args | + args first type = #nil ifTrue: [ + MALObject Nil + ] ifFalse: [ + args first value at: 1 ifAbsent: [ MALObject Nil ]. + ] + ]. +Core Ns at: #rest put: + [ :args | + | items rest | + items := args first value. + (args first type = #nil or: [ items isEmpty ]) ifTrue: [ + rest := {} + ] ifFalse: [ + rest := items allButFirst + ]. + MALList new: (OrderedCollection from: rest) + ]. diff --git a/gst/func.st b/gst/func.st index ccff241e90..76979d258a 100644 --- a/gst/func.st +++ b/gst/func.st @@ -1,12 +1,17 @@ Object subclass: Func [ - | ast params env fn meta | + | ast params env fn isMacro meta | ast [ ^ast ] params [ ^params ] env [ ^env ] fn [ ^fn ] + isMacro [ ^isMacro ] meta [ ^meta ] + isMacro: bool [ + isMacro := bool + ] + meta: aMeta [ meta := aMeta ] @@ -23,6 +28,7 @@ Object subclass: Func [ params := someParams. env := anEnv. fn := aFn. + isMacro := false ] withMeta: meta [ diff --git a/gst/step8_macros.st b/gst/step8_macros.st new file mode 100644 index 0000000000..74b9aa45a6 --- /dev/null +++ b/gst/step8_macros.st @@ -0,0 +1,285 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'func.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp class = BlockClosure ifTrue: [^sexp ]. + + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> quasiquote: ast [ + | result a a0 a0_ a0_0 a0_1 rest | + ast isPair ifFalse: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + + a := ast value. + a0 := a first. + + (a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ]. + + a0 isPair ifTrue: [ + a0_ := a0 value. + a0_0 := a0_ first. + a0_1 := a0_ second. + + (a0_0 type = #symbol and: + [ a0_0 value = #'splice-unquote' ]) ifTrue: [ + rest := MALList new: a allButFirst. + result := {MALSymbol new: #concat. a0_1. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + ]. + + rest := MALList new: a allButFirst. + result := {MALSymbol new: #cons. self quasiquote: a0. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + + MAL class >> isMacroCall: ast env: env [ + | a0 a0_ f | + ast type = #list ifTrue: [ + a0 := ast value first. + a0_ := a0 value. + a0 type = #symbol ifTrue: [ + f := env find: a0_. + (f notNil and: [ f class ~= BlockClosure ]) ifTrue: [ + ^f isMacro + ] + ] + ]. + ^false + ] + + MAL class >> macroexpand: aSexp env: env [ + | sexp | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + + [ self isMacroCall: sexp env: env ] whileTrue: [ + | ast a0_ macro rest | + ast := sexp value. + a0_ := ast first value. + macro := env find: a0_. + rest := ast allButFirst. + sexp := macro fn value: rest. + ]. + + ^sexp + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + (sexp class = BlockClosure or: [ sexp type ~= #list ]) ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + sexp := self macroexpand: sexp env: env. + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + + ast := sexp value. + a0 := ast first. + + a0 class ~= BlockClosure ifTrue: [ + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ] + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function class = BlockClosure ifTrue: [ ^function value: args ]. + function class = Func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))' env: replEnv. + +MAL rep: '(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list ''if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons ''cond (rest (rest xs)))))))' env: replEnv. +MAL rep: '(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/gst/types.st b/gst/types.st index e40638d8e2..b986887594 100644 --- a/gst/types.st +++ b/gst/types.st @@ -174,3 +174,9 @@ MALError subclass: MALUnknownSymbol [ messageText [ ^'''', self basicMessageText, ''' not found'] ] + +MALError subclass: MALOutOfBounds [ + MALOutOfBounds class >> new [ ^super new ] + + messageText [ ^'Out of bounds' ] +] From 58e44bbb33fd210071656a44488db01dc5c3e135 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 8 Jul 2017 22:55:08 +0200 Subject: [PATCH 0054/1998] Monkey-patch BlockClosure for simpler code --- gst/step6_file.st | 124 ++++++++++++++++---------------- gst/step7_quote.st | 144 ++++++++++++++++++------------------- gst/step8_macros.st | 172 ++++++++++++++++++++++---------------------- gst/util.st | 4 ++ 4 files changed, 218 insertions(+), 226 deletions(-) diff --git a/gst/step6_file.st b/gst/step6_file.st index 8040d66f80..8315042c9b 100644 --- a/gst/step6_file.st +++ b/gst/step6_file.st @@ -11,8 +11,6 @@ Object subclass: MAL [ ] MAL class >> evalAst: sexp env: env [ - sexp class = BlockClosure ifTrue: [^sexp ]. - sexp type = #symbol ifTrue: [ ^env get: sexp value ]. @@ -46,7 +44,7 @@ Object subclass: MAL [ [ [ :continue | - (sexp class = BlockClosure or: [ sexp type ~= #list ]) ifTrue: [ + sexp type ~= #list ifTrue: [ ^self evalAst: sexp env: env ]. sexp value isEmpty ifTrue: [ @@ -56,72 +54,70 @@ Object subclass: MAL [ ast := sexp value. a0 := ast first. - a0 class ~= BlockClosure ifTrue: [ - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. ]. - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ] + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn ]. forms := (self evalAst: sexp env: env) value. diff --git a/gst/step7_quote.st b/gst/step7_quote.st index 6ca5aabac0..b1aa1f8db1 100644 --- a/gst/step7_quote.st +++ b/gst/step7_quote.st @@ -11,8 +11,6 @@ Object subclass: MAL [ ] MAL class >> evalAst: sexp env: env [ - sexp class = BlockClosure ifTrue: [^sexp ]. - sexp type = #symbol ifTrue: [ ^env get: sexp value ]. @@ -78,7 +76,7 @@ Object subclass: MAL [ [ [ :continue | - (sexp class = BlockClosure or: [ sexp type ~= #list ]) ifTrue: [ + sexp type ~= #list ifTrue: [ ^self evalAst: sexp env: env ]. sexp value isEmpty ifTrue: [ @@ -88,84 +86,82 @@ Object subclass: MAL [ ast := sexp value. a0 := ast first. - a0 class ~= BlockClosure ifTrue: [ - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. ]. - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. - a0_ = #quote ifTrue: [ - a1 := ast second. - ^a1 - ]. + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. - a0_ = #quasiquote ifTrue: [ - | result | - a1 := ast second. - sexp := self quasiquote: a1. - continue value "TCO" - ]. + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ] + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn ]. forms := (self evalAst: sexp env: env) value. diff --git a/gst/step8_macros.st b/gst/step8_macros.st index 74b9aa45a6..76f612f26f 100644 --- a/gst/step8_macros.st +++ b/gst/step8_macros.st @@ -11,8 +11,6 @@ Object subclass: MAL [ ] MAL class >> evalAst: sexp env: env [ - sexp class = BlockClosure ifTrue: [^sexp ]. - sexp type = #symbol ifTrue: [ ^env get: sexp value ]. @@ -76,7 +74,7 @@ Object subclass: MAL [ a0_ := a0 value. a0 type = #symbol ifTrue: [ f := env find: a0_. - (f notNil and: [ f class ~= BlockClosure ]) ifTrue: [ + (f notNil and: [ f class = Func ]) ifTrue: [ ^f isMacro ] ] @@ -111,7 +109,7 @@ Object subclass: MAL [ [ [ :continue | - (sexp class = BlockClosure or: [ sexp type ~= #list ]) ifTrue: [ + sexp type ~= #list ifTrue: [ ^self evalAst: sexp env: env ]. sexp value isEmpty ifTrue: [ @@ -126,99 +124,97 @@ Object subclass: MAL [ ast := sexp value. a0 := ast first. - a0 class ~= BlockClosure ifTrue: [ - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. - a0_ = #'defmacro!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - result isMacro: true. - env set: a1_ value: result. - ^result - ]. + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. - a0_ = #'macroexpand' ifTrue: [ - a1 := ast second. - ^self macroexpand: a1 env: env - ]. + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. ]. - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. - a0_ = #quote ifTrue: [ - a1 := ast second. - ^a1 - ]. + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. - a0_ = #quasiquote ifTrue: [ - | result | - a1 := ast second. - sexp := self quasiquote: a1. - continue value "TCO" - ]. + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ] + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn ]. forms := (self evalAst: sexp env: env) value. diff --git a/gst/util.st b/gst/util.st index 4a93866f23..021caedf9b 100644 --- a/gst/util.st +++ b/gst/util.st @@ -33,4 +33,8 @@ BlockClosure extend [ valueWithExit [ ^self value: [ ^nil ] ] + + "HACK" + type [ ^#closure ] + value [ ^nil ] ] From d38ab263fe3884146e53f928a626868d9f6e8351 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 9 Jul 2017 10:51:56 +0200 Subject: [PATCH 0055/1998] Implement step 9 --- gst/core.st | 98 ++++++++++++++-- gst/printer.st | 2 +- gst/step9_try.st | 299 +++++++++++++++++++++++++++++++++++++++++++++++ gst/types.st | 9 ++ gst/util.st | 2 +- 5 files changed, 400 insertions(+), 10 deletions(-) create mode 100644 gst/step9_try.st diff --git a/gst/core.st b/gst/core.st index 13708bde3b..62db39cd5a 100644 --- a/gst/core.st +++ b/gst/core.st @@ -10,6 +10,14 @@ Object subclass: Core [ block value ifTrue: [ ^MALObject True ] ifFalse: [ ^MALObject False ] ] + Core class >> nilable: args else: block [ + args first type = #nil ifTrue: [ + ^MALObject Nil + ] ifFalse: [ + ^block value + ] + ] + Core class >> printedArgs: args readable: readable sep: sep [ | items | items := args collect: @@ -63,6 +71,8 @@ Core Ns at: #'read-string' put: [ :args | Reader readStr: args first value ]. Core Ns at: #slurp put: [ :args | MALString new: (File path: args first value) contents ]. +Core Ns at: #throw put: + [ :args | MALCustomError new signal: args first ]. Core Ns at: #atom put: [ :args | MALAtom new: args first ]. @@ -98,21 +108,93 @@ Core Ns at: #nth put: items at: index ifAbsent: [ MALOutOfBounds new signal ] ]. Core Ns at: #first put: - [ :args | - args first type = #nil ifTrue: [ - MALObject Nil - ] ifFalse: [ - args first value at: 1 ifAbsent: [ MALObject Nil ]. - ] - ]. + [ :args | Core nilable: args else: [ + args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]. Core Ns at: #rest put: [ :args | | items rest | items := args first value. - (args first type = #nil or: [ items isEmpty ]) ifTrue: [ + (args first type = #nil or: [ items isEmpty ]) ifTrue: [ rest := {} ] ifFalse: [ rest := items allButFirst ]. MALList new: (OrderedCollection from: rest) ]. + +Core Ns at: #apply put: + [ :args | + | f rest result | + f := args first. + f class = Func ifTrue: [ f := f fn ]. + args size < 3 ifTrue: [ + rest := {} + ] ifFalse: [ + rest := args copyFrom: 2 to: args size - 1 + ]. + rest := rest, args last value. + f value: rest + ]. +Core Ns at: #map put: + [ :args | + | items f result | + f := args first. + f class = Func ifTrue: [ f := f fn ]. + items := args second value. + result := items collect: [ :item | f value: {item} ]. + MALList new: (OrderedCollection from: result) + ]. + +Core Ns at: #'nil?' put: + [ :args | Core coerce: [ args first type = #nil ] ]. +Core Ns at: #'true?' put: + [ :args | Core coerce: [ args first type = #true ] ]. +Core Ns at: #'false?' put: + [ :args | Core coerce: [ args first type = #false ] ]. +Core Ns at: #'symbol?' put: + [ :args | Core coerce: [ args first type = #symbol ] ]. +Core Ns at: #'keyword?' put: + [ :args | Core coerce: [ args first type = #keyword ] ]. +Core Ns at: #'vector?' put: + [ :args | Core coerce: [ args first type = #vector ] ]. +Core Ns at: #'map?' put: + [ :args | Core coerce: [ args first type = #map ] ]. +Core Ns at: #'sequential?' put: + [ :args | Core coerce: [ args first type = #list or: + [ args first type = #vector ] ] ]. + +Core Ns at: #symbol put: + [ :args | MALSymbol new: args first value asSymbol ]. +Core Ns at: #keyword put: + [ :args | MALKeyword new: args first value asSymbol ]. +Core Ns at: #vector put: + [ :args | MALVector new: (OrderedCollection from: args) ]. +Core Ns at: #'hash-map' put: + [ :args | MALMap new: args asDictionary ]. + +Core Ns at: #assoc put: + [ :args | + | result keyVals | + result := Dictionary from: args first value associations. + keyVals := args allButFirst. + 1 to: keyVals size by: 2 do: + [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ]. + MALMap new: result + ]. +Core Ns at: #dissoc put: + [ :args | + | result keys | + result := Dictionary from: args first value associations. + keys := args allButFirst. + keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ]. + MALMap new: result + ]. +Core Ns at: #get put: + [ :args | Core nilable: args else: + [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]. +Core Ns at: #'contains?' put: + [ :args | Core coerce: [ args first value includesKey: args second ] ]. +Core Ns at: #keys put: + [ :args | MALList new: (OrderedCollection from: args first value keys) ]. +Core Ns at: #vals put: + [ :args | MALList new: (OrderedCollection from: args first value values) ]. diff --git a/gst/printer.st b/gst/printer.st index 7079a49a28..4bf44d41ea 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -53,6 +53,6 @@ Object subclass: Printer [ [ :item | (self prStr: item key printReadably: printReadably), ' ', (self prStr: item value printReadably: printReadably) ]. - ^'{', (items join: ', '), '}' + ^'{', (items join: ' '), '}' ] ] diff --git a/gst/step9_try.st b/gst/step9_try.st new file mode 100644 index 0000000000..7b5f65552b --- /dev/null +++ b/gst/step9_try.st @@ -0,0 +1,299 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'func.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> quasiquote: ast [ + | result a a0 a0_ a0_0 a0_1 rest | + ast isPair ifFalse: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + + a := ast value. + a0 := a first. + + (a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ]. + + a0 isPair ifTrue: [ + a0_ := a0 value. + a0_0 := a0_ first. + a0_1 := a0_ second. + + (a0_0 type = #symbol and: + [ a0_0 value = #'splice-unquote' ]) ifTrue: [ + rest := MALList new: a allButFirst. + result := {MALSymbol new: #concat. a0_1. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + ]. + + rest := MALList new: a allButFirst. + result := {MALSymbol new: #cons. self quasiquote: a0. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + + MAL class >> isMacroCall: ast env: env [ + | a0 a0_ f | + ast type = #list ifTrue: [ + a0 := ast value first. + a0_ := a0 value. + a0 type = #symbol ifTrue: [ + f := env find: a0_. + (f notNil and: [ f class = Func ]) ifTrue: [ + ^f isMacro + ] + ] + ]. + ^false + ] + + MAL class >> macroexpand: aSexp env: env [ + | sexp | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + + [ self isMacroCall: sexp env: env ] whileTrue: [ + | ast a0_ macro rest | + ast := sexp value. + a0_ := ast first value. + macro := env find: a0_. + rest := ast allButFirst. + sexp := macro fn value: rest. + ]. + + ^sexp + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + sexp := self macroexpand: sexp env: env. + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'try*' ifTrue: [ + | A B C | + A := ast second. + a2_ := ast third value. + B := a2_ second value. + C := a2_ third. + ^[ self EVAL: A env: env ] on: MALError do: + [ :err | + | data env_ result | + data := err data. + data isString ifTrue: [ + data := MALString new: data + ]. + env_ := Env new: env binds: {B} exprs: {data}. + err return: (self EVAL: C env: env_) + ] + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function class = BlockClosure ifTrue: [ ^function value: args ]. + function class = Func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))' env: replEnv. + +MAL rep: '(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list ''if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons ''cond (rest (rest xs)))))))' env: replEnv. +MAL rep: '(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/gst/types.st b/gst/types.st index b986887594..9f3b032a1c 100644 --- a/gst/types.st +++ b/gst/types.st @@ -149,6 +149,8 @@ MALObject subclass: MALAtom [ Error subclass: MALError [ description [ ^'A MAL-related error' ] isResumable [ ^true ] + + data [ ^self messageText ] ] MALError subclass: MALUnterminatedSequence [ @@ -180,3 +182,10 @@ MALError subclass: MALOutOfBounds [ messageText [ ^'Out of bounds' ] ] + +MALError subclass: MALCustomError [ + MALCustomError class >> new [ ^super new ] + + messageText [ ^Printer prStr: self basicMessageText printReadably: true ] + data [ ^self basicMessageText ] +] diff --git a/gst/util.st b/gst/util.st index 021caedf9b..03a226d09e 100644 --- a/gst/util.st +++ b/gst/util.st @@ -1,4 +1,4 @@ -OrderedCollection extend [ +SequenceableCollection extend [ asDictionary [ | dict assoc | dict := Dictionary new. From 43d8bb4e2ea28a59fb4bb546199dd2fe3b947fc9 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sun, 9 Jul 2017 12:34:58 +0200 Subject: [PATCH 0056/1998] Elm step A: implemented GC. MAL tests are failing.. --- elm/Core.elm | 11 +- elm/Env.elm | 262 ++++++++++++++++++++++++----------------- elm/Eval.elm | 34 +++--- elm/Types.elm | 2 + elm/step4_if_fn_do.elm | 7 +- elm/step5_tco.elm | 9 +- elm/step6_file.elm | 9 +- elm/step7_quote.elm | 3 +- elm/step8_macros.elm | 3 +- elm/step9_try.elm | 3 +- elm/stepA_mal.elm | 4 +- 11 files changed, 197 insertions(+), 150 deletions(-) diff --git a/elm/Core.elm b/elm/Core.elm index 02dc946853..95b9adf9c3 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -305,7 +305,7 @@ ns = Eval.fail "unsupported arguments" gc args = - Eval.withEnv (Env.gc >> Printer.printEnv >> writeLine) + Eval.withEnv (Env.gc MalNil >> Printer.printEnv >> writeLine) setDebug enabled = Eval.modifyEnv @@ -316,11 +316,14 @@ ns = debug args = case args of - [ MalBool True ] -> - setDebug True + [ MalBool value ] -> + setDebug value _ -> - setDebug False + Eval.withEnv + (\env -> + Eval.succeed (MalBool env.debug) + ) typeof args = case args of diff --git a/elm/Env.elm b/elm/Env.elm index 5f083a8742..867df02eae 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -36,6 +36,11 @@ globalFrameId = 0 +defaultGcInterval : Int +defaultGcInterval = + 3 + + global : Env global = { frames = Dict.singleton globalFrameId (emptyFrame Nothing) @@ -44,6 +49,8 @@ global = , atoms = Dict.empty , nextAtomId = 0 , debug = False + , gcInterval = defaultGcInterval + , gcCounter = 0 } @@ -57,6 +64,84 @@ getFrame frameId env = Debug.crash <| "frame #" ++ (toString frameId) ++ " not found" +emptyFrame : Maybe Int -> Frame +emptyFrame outerId = + { outerId = outerId + , data = Dict.empty + , refCnt = 1 + } + + +set : String -> MalExpr -> Env -> Env +set name expr env = + let + frameId = + env.currentFrameId + + updateFrame = + Maybe.map + (\frame -> + { frame | data = Dict.insert name expr frame.data } + ) + + newFrames = + Dict.update frameId updateFrame env.frames + in + { env | frames = newFrames } + + +get : String -> Env -> Result String MalExpr +get name env = + let + go frameId = + let + frame = + getFrame frameId env + in + case Dict.get name frame.data of + Just value -> + Ok value + + Nothing -> + frame.outerId + |> Maybe.map go + |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") + in + go env.currentFrameId + + +newAtom : MalExpr -> Env -> ( Env, Int ) +newAtom value env = + let + atomId = + env.nextAtomId + + newEnv = + { env + | atoms = Dict.insert atomId value env.atoms + , nextAtomId = atomId + 1 + } + in + ( newEnv, atomId ) + + +getAtom : Int -> Env -> MalExpr +getAtom atomId env = + case Dict.get atomId env.atoms of + Just value -> + value + + Nothing -> + Debug.crash <| "atom " ++ (toString atomId) ++ " not found" + + +setAtom : Int -> MalExpr -> Env -> Env +setAtom atomId value env = + { env + | atoms = Dict.insert atomId value env.atoms + } + + jump : Int -> Env -> Env jump frameId env = { env | currentFrameId = frameId } @@ -160,8 +245,11 @@ ref env = Nothing -> newEnv + + newEnv = + go env.currentFrameId env in - go env.currentFrameId env + { newEnv | gcCounter = newEnv.gcCounter + 1 } free : Maybe Frame -> Maybe Frame @@ -176,143 +264,99 @@ free = {-| Given an Env see which frames are not reachable from the -global frame. Return a new Env without the unreachable frames. +global frame, or from the current expression. -TODO include current expression. +Return a new Env with the unreachable frames removed. -} -gc : Env -> Env -gc env = +gc : MalExpr -> Env -> Env +gc currentExpr env = let countList acc = List.foldl countRefs acc - countFrame acc { data } = + countFrame { data } acc = data |> Dict.values |> countList acc - countRefs expr acc = - debug env ("gc-visit " ++ (toString expr)) <| - case expr of - MalFunction (UserFunc { frameId }) -> - if not (Set.member frameId acc) then - debug env "gc-counting" <| - case Dict.get frameId env.frames of - Just frame -> - countFrame (Set.insert frameId acc) frame - - Nothing -> - Debug.crash ("frame " ++ (toString frameId) ++ " not found in GC") - else - acc - - MalList list -> - countList acc list - - MalVector vec -> - countList acc (Array.toList vec) - - MalMap map -> - countList acc (Dict.values map) - - _ -> - acc - - initSet = - Set.fromList [ globalFrameId, env.currentFrameId ] + recur frameId acc = + if not (Set.member frameId acc) then + let + frame = + getFrame frameId env - reportUnused frames used = - Dict.diff frames used - |> debug env "unused frames" - |> (\_ -> frames) - in - case Dict.get globalFrameId env.frames of - Nothing -> - Debug.crash "global frame not found" + newAcc = + (Set.insert frameId acc) + in + countFrame frame newAcc + else + acc - Just globalFrame -> - countFrame initSet globalFrame - |> Set.toList - |> debug env "used frames" - |> List.map (\frameId -> ( frameId, emptyFrame Nothing )) - |> Dict.fromList - |> reportUnused env.frames - |> Dict.intersect env.frames - |> (\frames -> { env | frames = frames }) + countRefs expr acc = + case expr of + MalFunction (UserFunc { frameId }) -> + recur frameId acc + MalApply { frameId } -> + recur frameId acc -emptyFrame : Maybe Int -> Frame -emptyFrame outerId = - { outerId = outerId - , data = Dict.empty - , refCnt = 1 - } + MalList list -> + countList acc list + MalVector vec -> + countList acc (Array.toList vec) -set : String -> MalExpr -> Env -> Env -set name expr env = - let - frameId = - env.currentFrameId + MalMap map -> + countList acc (Dict.values map) - updateFrame = - Maybe.map - (\frame -> - { frame | data = Dict.insert name expr frame.data } - ) + MalAtom atomId -> + let + value = + getAtom atomId env + in + countRefs value acc - newFrames = - Dict.update frameId updateFrame env.frames - in - { env | frames = newFrames } + _ -> + acc + initSet = + Set.fromList [ globalFrameId, env.currentFrameId ] -get : String -> Env -> Result String MalExpr -get name env = - let - go frameId = + expandParents frameId acc = let frame = getFrame frameId env in - case Dict.get name frame.data of - Just value -> - Ok value + case frame.outerId of + Just parentId -> + Set.insert parentId acc Nothing -> - frame.outerId - |> Maybe.map go - |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") - in - go env.currentFrameId + acc + expandAllFrames frames = + Set.foldl expandParents frames frames -newAtom : MalExpr -> Env -> ( Env, Int ) -newAtom value env = - let - atomId = - env.nextAtomId + makeEmptyFrame frameId = + ( frameId, emptyFrame Nothing ) - newEnv = + globalFrame = + getFrame globalFrameId env + + makeNewEnv newFrames = { env - | atoms = Dict.insert atomId value env.atoms - , nextAtomId = atomId + 1 + | frames = newFrames + , gcCounter = 0 } - in - ( newEnv, atomId ) + keepFilter keep frameId _ = + Set.member frameId keep -getAtom : Int -> Env -> MalExpr -getAtom atomId env = - case Dict.get atomId env.atoms of - Just value -> - value - - Nothing -> - Debug.crash <| "atom " ++ (toString atomId) ++ " not found" - - -setAtom : Int -> MalExpr -> Env -> Env -setAtom atomId value env = - { env - | atoms = Dict.insert atomId value env.atoms - } + filterFrames frames keep = + Dict.filter (keepFilter keep) frames + in + initSet + |> countRefs currentExpr + |> countFrame globalFrame + |> expandAllFrames + |> filterFrames env.frames + |> makeNewEnv diff --git a/elm/Eval.elm b/elm/Eval.elm index cba0b41cde..4bd38a19ed 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -84,6 +84,26 @@ finally f e env = ( env, EvalIO cmd (cont >> finally f) ) +gcPass : Eval MalExpr -> Eval MalExpr +gcPass e env = + let + go env t expr = + if env.gcCounter >= env.gcInterval then + ( Env.gc expr env, t expr ) + else + ( env, t expr ) + in + case apply e env of + ( env, EvalOk res ) -> + go env EvalOk res + + ( env, EvalErr msg ) -> + go env EvalErr msg + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> gcPass) ) + + catchError : (MalExpr -> Eval a) -> Eval a -> Eval a catchError f e env = case apply e env of @@ -107,20 +127,6 @@ throw ex env = ( env, EvalErr ex ) -enter : Int -> List ( String, MalExpr ) -> Eval a -> Eval a -enter frameId bound body = - withEnv - (\env -> - modifyEnv (Env.enter frameId bound) - |> andThen (always body) - |> andThen - (\res -> - modifyEnv (Env.leave env.currentFrameId) - |> map (always res) - ) - ) - - {-| Apply f to expr repeatedly. Continues iterating if f returns (Left eval). Stops if f returns (Right expr). diff --git a/elm/Types.elm b/elm/Types.elm index 2fb55ec910..e978f638c4 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -28,6 +28,8 @@ type alias Env = , atoms : Dict Int MalExpr , nextAtomId : Int , debug : Bool + , gcInterval : Int + , gcCounter : Int } diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index e524426b44..ed1af853b4 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -423,7 +423,12 @@ evalFn args = fn args = case binder args of Ok bound -> - Eval.enter frameId bound (eval body) + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (always (eval body)) + |> Eval.finally (Env.leave env.currentFrameId) + ) Err msg -> Eval.fail msg diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index 7938325eae..d00791ef4f 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -188,11 +188,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.leave env.currentFrameId) - |> Eval.map (\_ -> res) - ) + |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.gcPass ) @@ -466,8 +463,6 @@ evalFn args = case binder args of Ok bound -> Eval.succeed <| - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. MalApply { frameId = frameId , bound = bound diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 1577b90e33..93d392888c 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -263,11 +263,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.leave env.currentFrameId) - |> Eval.map (\_ -> res) - ) + |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.gcPass ) @@ -541,8 +538,6 @@ evalFn args = case binder args of Ok bound -> Eval.succeed <| - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. MalApply { frameId = frameId , bound = bound diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index c10724df3a..5cc67c1f53 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -264,6 +264,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.gcPass ) @@ -538,8 +539,6 @@ evalFn args = >> Eval.fromResult >> Eval.map (\bound -> - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. MalApply { frameId = frameId , bound = bound diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm index f3c8cb8e80..476b5da2db 100644 --- a/elm/step8_macros.elm +++ b/elm/step8_macros.elm @@ -280,6 +280,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.gcPass ) @@ -593,8 +594,6 @@ evalFn args = >> Eval.fromResult >> Eval.map (\bound -> - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. MalApply { frameId = frameId , bound = bound diff --git a/elm/step9_try.elm b/elm/step9_try.elm index b67d35429b..20963eb2b6 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -280,6 +280,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.gcPass ) @@ -595,8 +596,6 @@ evalFn args = >> Eval.fromResult >> Eval.map (\bound -> - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. MalApply { frameId = frameId , bound = bound diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm index 5f8675f3b4..b6f60bd579 100644 --- a/elm/stepA_mal.elm +++ b/elm/stepA_mal.elm @@ -266,6 +266,7 @@ eval ast = in evalNoApply ast |> Eval.andThen (Eval.runLoop apply) + |> Eval.gcPass malEval : List MalExpr -> Eval MalExpr @@ -290,6 +291,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.gcPass ) @@ -605,8 +607,6 @@ evalFn args = >> Eval.fromResult >> Eval.map (\bound -> - -- TODO : choice Env.enter prematurely? - -- I think it is needed by the garbage collect.. MalApply { frameId = frameId , bound = bound From aee373f32ec26c654896c401d5cab401761ed8d7 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 9 Jul 2017 20:05:59 +0200 Subject: [PATCH 0057/1998] Wrap BlockClosure into Fn to work around a bug Extending a BlockClosure by a meta field gives a segfault for whatever reason. Yes, seriously. --- gst/core.st | 147 ++++++++++++++++++++---------------------- gst/func.st | 18 +----- gst/printer.st | 4 +- gst/step4_if_fn_do.st | 4 +- gst/step5_tco.st | 4 +- gst/step6_file.st | 6 +- gst/step7_quote.st | 6 +- gst/step8_macros.st | 8 +-- gst/step9_try.st | 8 +-- gst/types.st | 17 +++++ 10 files changed, 111 insertions(+), 111 deletions(-) diff --git a/gst/core.st b/gst/core.st index 62db39cd5a..a5a87e6397 100644 --- a/gst/core.st +++ b/gst/core.st @@ -28,90 +28,92 @@ Object subclass: Core [ ] Core Ns at: #+ put: - [ :args | MALNumber new: args first value + args second value ]. + (Fn new: [ :args | MALNumber new: args first value + args second value ]). Core Ns at: #- put: - [ :args | MALNumber new: args first value - args second value ]. + (Fn new: [ :args | MALNumber new: args first value - args second value ]). Core Ns at: #* put: - [ :args | MALNumber new: args first value * args second value ]. + (Fn new: [ :args | MALNumber new: args first value * args second value ]). Core Ns at: #/ put: - [ :args | MALNumber new: args first value // args second value ]. + (Fn new: [ :args | MALNumber new: args first value // args second value ]). Core Ns at: #'pr-str' put: - [ :args | MALString new: (Core printedArgs: args readable: true sep: ' ') ]. + (Fn new: [ :args | MALString new: (Core printedArgs: args readable: true + sep: ' ') ]). Core Ns at: #str put: - [ :args | MALString new: (Core printedArgs: args readable: false sep: '') ]. + (Fn new: [ :args | MALString new: (Core printedArgs: args readable: false + sep: '') ]). Core Ns at: #prn put: - [ :args | (Core printedArgs: args readable: true sep: ' ') displayNl. - MALObject Nil ]. + (Fn new: [ :args | + (Core printedArgs: args readable: true sep: ' ') displayNl. + MALObject Nil ]). Core Ns at: #println put: - [ :args | (Core printedArgs: args readable: false sep: ' ') displayNl. - MALObject Nil ]. + (Fn new: [ :args | + (Core printedArgs: args readable: false sep: ' ') displayNl. + MALObject Nil ]). -Core Ns at: #list put: [ :args | MALList new: (OrderedCollection from: args) ]. +Core Ns at: #list put: + (Fn new: [ :args | MALList new: (OrderedCollection from: args) ]). Core Ns at: #'list?' put: - [ :args | Core coerce: [ args first type = #list ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #list ] ]). Core Ns at: #'empty?' put: - [ :args | Core coerce: [ args first value isEmpty ] ]. + (Fn new: [ :args | Core coerce: [ args first value isEmpty ] ]). Core Ns at: #count put: - [ :args | MALNumber new: args first value size ]. + (Fn new: [ :args | MALNumber new: args first value size ]). Core Ns at: #= put: - [ :args | Core coerce: [ args first = args second ] ]. + (Fn new: [ :args | Core coerce: [ args first = args second ] ]). Core Ns at: #< put: - [ :args | Core coerce: [ args first value < args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value < args second value ] ]). Core Ns at: #<= put: - [ :args | Core coerce: [ args first value <= args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value <= args second value ] ]). Core Ns at: #> put: - [ :args | Core coerce: [ args first value > args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value > args second value ] ]). Core Ns at: #>= put: - [ :args | Core coerce: [ args first value >= args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value >= args second value ] ]). Core Ns at: #'read-string' put: - [ :args | Reader readStr: args first value ]. + (Fn new: [ :args | Reader readStr: args first value ]). Core Ns at: #slurp put: - [ :args | MALString new: (File path: args first value) contents ]. + (Fn new: [ :args | MALString new: (File path: args first value) contents ]). Core Ns at: #throw put: - [ :args | MALCustomError new signal: args first ]. + (Fn new: [ :args | MALCustomError new signal: args first ]). Core Ns at: #atom put: - [ :args | MALAtom new: args first ]. + (Fn new: [ :args | MALAtom new: args first ]). Core Ns at: #'atom?' put: - [ :args | Core coerce: [ args first type = #atom ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #atom ] ]). Core Ns at: #deref put: - [ :args | args first value ]. + (Fn new: [ :args | args first value ]). Core Ns at: #'reset!' put: - [ :args | args first value: args second. args second ]. + (Fn new: [ :args | args first value: args second. args second ]). Core Ns at: #'swap!' put: - [ :args | + (Fn new: [ :args | | a f x xs result | a := args first. - f := args second. - f class = Func ifTrue: [ f := f fn ]. + f := args second fn. x := a value. xs := args allButFirst: 2. result := f value: (xs copyWithFirst: x). a value: result. - result - ]. + result ]). Core Ns at: #cons put: - [ :args | MALList new: (args second value copyWithFirst: args first) ]. + (Fn new: [ :args | MALList new: (args second value copyWithFirst: args first) ]). Core Ns at: #concat put: - [ :args | MALList new: (OrderedCollection join: - (args collect: [ :arg | arg value ])) ]. + (Fn new: [ :args | MALList new: (OrderedCollection join: + (args collect: [ :arg | arg value ])) ]). Core Ns at: #nth put: - [ :args | + (Fn new: [ :args | | items index | items := args first value. index := args second value + 1. - items at: index ifAbsent: [ MALOutOfBounds new signal ] - ]. + items at: index ifAbsent: [ MALOutOfBounds new signal ] ]). Core Ns at: #first put: - [ :args | Core nilable: args else: [ - args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]. + (Fn new: [ :args | Core nilable: args else: [ + args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]). Core Ns at: #rest put: - [ :args | + (Fn new: [ :args | | items rest | items := args first value. (args first type = #nil or: [ items isEmpty ]) ifTrue: [ @@ -119,82 +121,75 @@ Core Ns at: #rest put: ] ifFalse: [ rest := items allButFirst ]. - MALList new: (OrderedCollection from: rest) - ]. + MALList new: (OrderedCollection from: rest) ]). Core Ns at: #apply put: - [ :args | + (Fn new: [ :args | | f rest result | - f := args first. - f class = Func ifTrue: [ f := f fn ]. + f := args first fn. args size < 3 ifTrue: [ rest := {} ] ifFalse: [ rest := args copyFrom: 2 to: args size - 1 ]. rest := rest, args last value. - f value: rest - ]. + f value: rest ]). Core Ns at: #map put: - [ :args | + (Fn new: [ :args | | items f result | - f := args first. - f class = Func ifTrue: [ f := f fn ]. + f := args first fn. items := args second value. result := items collect: [ :item | f value: {item} ]. - MALList new: (OrderedCollection from: result) - ]. + MALList new: (OrderedCollection from: result) ]). Core Ns at: #'nil?' put: - [ :args | Core coerce: [ args first type = #nil ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #nil ] ]). Core Ns at: #'true?' put: - [ :args | Core coerce: [ args first type = #true ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #true ] ]). Core Ns at: #'false?' put: - [ :args | Core coerce: [ args first type = #false ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #false ] ]). Core Ns at: #'symbol?' put: - [ :args | Core coerce: [ args first type = #symbol ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]). Core Ns at: #'keyword?' put: - [ :args | Core coerce: [ args first type = #keyword ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #keyword ] ]). Core Ns at: #'vector?' put: - [ :args | Core coerce: [ args first type = #vector ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #vector ] ]). Core Ns at: #'map?' put: - [ :args | Core coerce: [ args first type = #map ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #map ] ]). Core Ns at: #'sequential?' put: - [ :args | Core coerce: [ args first type = #list or: - [ args first type = #vector ] ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #list or: + [ args first type = #vector ] ] ]). Core Ns at: #symbol put: - [ :args | MALSymbol new: args first value asSymbol ]. + (Fn new: [ :args | MALSymbol new: args first value asSymbol ]). Core Ns at: #keyword put: - [ :args | MALKeyword new: args first value asSymbol ]. + (Fn new: [ :args | MALKeyword new: args first value asSymbol ]). Core Ns at: #vector put: - [ :args | MALVector new: (OrderedCollection from: args) ]. + (Fn new: [ :args | MALVector new: (OrderedCollection from: args) ]). Core Ns at: #'hash-map' put: - [ :args | MALMap new: args asDictionary ]. + (Fn new: [ :args | MALMap new: args asDictionary ]). Core Ns at: #assoc put: - [ :args | + (Fn new: [ :args | | result keyVals | result := Dictionary from: args first value associations. keyVals := args allButFirst. 1 to: keyVals size by: 2 do: [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ]. - MALMap new: result - ]. + MALMap new: result ]). Core Ns at: #dissoc put: - [ :args | + (Fn new: [ :args | | result keys | result := Dictionary from: args first value associations. keys := args allButFirst. keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ]. - MALMap new: result - ]. + MALMap new: result ]). Core Ns at: #get put: - [ :args | Core nilable: args else: - [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]. + (Fn new: [ :args | Core nilable: args else: + [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]). Core Ns at: #'contains?' put: - [ :args | Core coerce: [ args first value includesKey: args second ] ]. + (Fn new: [ :args | Core coerce: [ args first value includesKey: args second ] ]). Core Ns at: #keys put: - [ :args | MALList new: (OrderedCollection from: args first value keys) ]. + (Fn new: [ :args | MALList new: (OrderedCollection from: args first value keys) ]). Core Ns at: #vals put: - [ :args | MALList new: (OrderedCollection from: args first value values) ]. + (Fn new: [ :args | MALList new: (OrderedCollection from: args first value values) ]). diff --git a/gst/func.st b/gst/func.st index 76979d258a..dc5e97fe65 100644 --- a/gst/func.st +++ b/gst/func.st @@ -1,24 +1,19 @@ -Object subclass: Func [ - | ast params env fn isMacro meta | +MALObject subclass: Func [ + | ast params env fn isMacro | ast [ ^ast ] params [ ^params ] env [ ^env ] fn [ ^fn ] isMacro [ ^isMacro ] - meta [ ^meta ] isMacro: bool [ isMacro := bool ] - meta: aMeta [ - meta := aMeta - ] - Func class >> new: ast params: params env: env fn: fn [ | func | - func := super new. + func := super new: #func value: fn meta: nil. func init: ast params: params env: env fn: fn. ^func ] @@ -30,11 +25,4 @@ Object subclass: Func [ fn := aFn. isMacro := false ] - - withMeta: meta [ - | func | - func := self deepCopy. - func meta: meta. - ^func - ] ] diff --git a/gst/printer.st b/gst/printer.st index 4bf44d41ea..d84994656f 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -2,8 +2,8 @@ FileStream fileIn: 'types.st'. Object subclass: Printer [ Printer class >> prStr: sexp printReadably: printReadably [ - sexp class = BlockClosure ifTrue: [ ^'#' ]. - sexp class = Func ifTrue: [ ^'#' ]. + sexp type = #fn ifTrue: [ ^'#' ]. + sexp type = #func ifTrue: [ ^'#' ]. sexp type = #true ifTrue: [ ^'true' ]. sexp type = #false ifTrue: [ ^'false' ]. sexp type = #nil ifTrue: [ ^'nil' ]. diff --git a/gst/step4_if_fn_do.st b/gst/step4_if_fn_do.st index 138b967838..8bb7adb58a 100644 --- a/gst/step4_if_fn_do.st +++ b/gst/step4_if_fn_do.st @@ -89,12 +89,12 @@ Object subclass: MAL [ a1_ := ast second value. binds := a1_ collect: [ :item | item value ]. a2 := ast third. - ^[ :args | self EVAL: a2 env: + ^Fn new: [ :args | self EVAL: a2 env: (Env new: env binds: binds exprs: args) ] ]. forms := (self evalAst: sexp env: env) value. - function := forms first. + function := forms first fn. args := forms allButFirst asArray. ^function value: args ] diff --git a/gst/step5_tco.st b/gst/step5_tco.st index 7ac7f1bbca..9341b86c4e 100644 --- a/gst/step5_tco.st +++ b/gst/step5_tco.st @@ -123,8 +123,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params diff --git a/gst/step6_file.st b/gst/step6_file.st index 8315042c9b..758cc68c52 100644 --- a/gst/step6_file.st +++ b/gst/step6_file.st @@ -124,8 +124,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -157,7 +157,7 @@ argv notEmpty ifTrue: [ argv := argv allButFirst ]. argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/step7_quote.st b/gst/step7_quote.st index b1aa1f8db1..faeaf645f9 100644 --- a/gst/step7_quote.st +++ b/gst/step7_quote.st @@ -168,8 +168,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -201,7 +201,7 @@ argv notEmpty ifTrue: [ argv := argv allButFirst ]. argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/step8_macros.st b/gst/step8_macros.st index 76f612f26f..69c7721ac3 100644 --- a/gst/step8_macros.st +++ b/gst/step8_macros.st @@ -74,7 +74,7 @@ Object subclass: MAL [ a0_ := a0 value. a0 type = #symbol ifTrue: [ f := env find: a0_. - (f notNil and: [ f class = Func ]) ifTrue: [ + (f notNil and: [ f type = #func ]) ifTrue: [ ^f isMacro ] ] @@ -221,8 +221,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -254,7 +254,7 @@ argv notEmpty ifTrue: [ argv := argv allButFirst ]. argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/step9_try.st b/gst/step9_try.st index 7b5f65552b..bd0e434247 100644 --- a/gst/step9_try.st +++ b/gst/step9_try.st @@ -74,7 +74,7 @@ Object subclass: MAL [ a0_ := a0 value. a0 type = #symbol ifTrue: [ f := env find: a0_. - (f notNil and: [ f class = Func ]) ifTrue: [ + (f notNil and: [ f type = #func ]) ifTrue: [ ^f isMacro ] ] @@ -239,8 +239,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -272,7 +272,7 @@ argv notEmpty ifTrue: [ argv := argv allButFirst ]. argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/types.st b/gst/types.st index 9f3b032a1c..6e9a199176 100644 --- a/gst/types.st +++ b/gst/types.st @@ -146,6 +146,23 @@ MALObject subclass: MALAtom [ ] ] +MALObject subclass: Fn [ + | fn | + + fn [ ^fn ] + + Fn class >> new: fn [ + | f | + f := super new: #fn value: fn meta: nil. + f init: fn. + ^f + ] + + init: f [ + fn := f. + ] +] + Error subclass: MALError [ description [ ^'A MAL-related error' ] isResumable [ ^true ] From 968e1a199ef48ca596229fedbd508c65c4f9d1d6 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 9 Jul 2017 20:10:16 +0200 Subject: [PATCH 0058/1998] Implement step A --- gst/core.st | 52 ++++++++ gst/stepA_mal.st | 303 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 355 insertions(+) create mode 100644 gst/stepA_mal.st diff --git a/gst/core.st b/gst/core.st index a5a87e6397..651ab63713 100644 --- a/gst/core.st +++ b/gst/core.st @@ -1,6 +1,7 @@ FileStream fileIn: 'types.st'. FileStream fileIn: 'printer.st'. FileStream fileIn: 'reader.st'. +FileStream fileIn: 'readline.st'. Object subclass: Core [ Ns := Dictionary new. @@ -78,6 +79,17 @@ Core Ns at: #slurp put: (Fn new: [ :args | MALString new: (File path: args first value) contents ]). Core Ns at: #throw put: (Fn new: [ :args | MALCustomError new signal: args first ]). +Core Ns at: #readline put: + (Fn new: [ :args | + | result | + result := ReadLine readLine: args first value. + result isString ifTrue: [ + MALString new: result + ] ifFalse: [ + MALObject Nil + ] ]). +Core Ns at: #'time-ms' put: + (Fn new: [ :args | MALNumber new: Time millisecondClock ]). Core Ns at: #atom put: (Fn new: [ :args | MALAtom new: args first ]). @@ -122,6 +134,36 @@ Core Ns at: #rest put: rest := items allButFirst ]. MALList new: (OrderedCollection from: rest) ]). +Core Ns at: #conj put: + (Fn new: [ :args | + | kind result items | + kind := args first type. + result := args first value. + items := args allButFirst. + + kind = #list ifTrue: [ + MALList new: (OrderedCollection from: items reverse, result) + ] ifFalse: [ + MALVector new: (OrderedCollection from: result, items) + ] ]). +Core Ns at: #seq put: + (Fn new: [ :args | + | kind storage result | + kind := args first type. + storage := args first value. + Core nilable: args else: [ + storage isEmpty ifTrue: [ + MALObject Nil + ] ifFalse: [ + kind = #string ifTrue: [ + result := (OrderedCollection from: storage) collect: + [ :char | MALString new: char asString ]. + MALList new: result + ] ifFalse: [ + MALList new: (OrderedCollection from: storage) + ] + ] + ] ]). Core Ns at: #apply put: (Fn new: [ :args | @@ -142,6 +184,14 @@ Core Ns at: #map put: result := items collect: [ :item | f value: {item} ]. MALList new: (OrderedCollection from: result) ]). +Core Ns at: #meta put: + (Fn new: [ :args | + | meta | + meta := args first meta. + meta isNil ifTrue: [ MALObject Nil ] ifFalse: [ meta ] ]). +Core Ns at: #'with-meta' put: + (Fn new: [ :args | args first withMeta: args second ]). + Core Ns at: #'nil?' put: (Fn new: [ :args | Core coerce: [ args first type = #nil ] ]). Core Ns at: #'true?' put: @@ -152,6 +202,8 @@ Core Ns at: #'symbol?' put: (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]). Core Ns at: #'keyword?' put: (Fn new: [ :args | Core coerce: [ args first type = #keyword ] ]). +Core Ns at: #'string?' put: + (Fn new: [ :args | Core coerce: [ args first type = #string ] ]). Core Ns at: #'vector?' put: (Fn new: [ :args | Core coerce: [ args first type = #vector ] ]). Core Ns at: #'map?' put: diff --git a/gst/stepA_mal.st b/gst/stepA_mal.st new file mode 100644 index 0000000000..2bd378d668 --- /dev/null +++ b/gst/stepA_mal.st @@ -0,0 +1,303 @@ +FileStream fileIn: 'readline.st'. +FileStream fileIn: 'reader.st'. +FileStream fileIn: 'printer.st'. +FileStream fileIn: 'env.st'. +FileStream fileIn: 'func.st'. +FileStream fileIn: 'core.st'. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> quasiquote: ast [ + | result a a0 a0_ a0_0 a0_1 rest | + ast isPair ifFalse: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + + a := ast value. + a0 := a first. + + (a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ]. + + a0 isPair ifTrue: [ + a0_ := a0 value. + a0_0 := a0_ first. + a0_1 := a0_ second. + + (a0_0 type = #symbol and: + [ a0_0 value = #'splice-unquote' ]) ifTrue: [ + rest := MALList new: a allButFirst. + result := {MALSymbol new: #concat. a0_1. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + ]. + + rest := MALList new: a allButFirst. + result := {MALSymbol new: #cons. self quasiquote: a0. + self quasiquote: rest}. + ^MALList new: (OrderedCollection from: result) + ] + + MAL class >> isMacroCall: ast env: env [ + | a0 a0_ f | + ast type = #list ifTrue: [ + a0 := ast value first. + a0_ := a0 value. + a0 type = #symbol ifTrue: [ + f := env find: a0_. + (f notNil and: [ f type = #func ]) ifTrue: [ + ^f isMacro + ] + ] + ]. + ^false + ] + + MAL class >> macroexpand: aSexp env: env [ + | sexp | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + + [ self isMacroCall: sexp env: env ] whileTrue: [ + | ast a0_ macro rest | + ast := sexp value. + a0_ := ast first value. + macro := env find: a0_. + rest := ast allButFirst. + sexp := macro fn value: rest. + ]. + + ^sexp + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + sexp := self macroexpand: sexp env: env. + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'try*' ifTrue: [ + | A B C | + A := ast second. + a2_ := ast third value. + B := a2_ second value. + C := a2_ third. + ^[ self EVAL: A env: env ] on: MALError do: + [ :err | + | data env_ result | + data := err data. + data isString ifTrue: [ + data := MALString new: data + ]. + env_ := Env new: env binds: {B} exprs: {data}. + err return: (self EVAL: C env: env_) + ] + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). +replEnv set: #'*ARGV*' value: (MALList new: argv). +replEnv set: #'*host-language*' value: (MALString new: 'smalltalk'). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))' env: replEnv. + +MAL rep: '(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list ''if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons ''cond (rest (rest xs)))))))' env: replEnv. +MAL rep: '(def! *gensym-counter* (atom 0))' env: replEnv. +MAL rep: '(def! gensym (fn* [] (symbol (str "G__" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))' env: replEnv. +MAL rep: '(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + MAL rep: '(println (str "Mal [" *host-language* "]"))' env: replEnv. + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] From fd216c1911b08503b0ac47704f2ac203ff647ac9 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 9 Jul 2017 22:51:15 +0200 Subject: [PATCH 0059/1998] Self-hosting fix --- gst/env.st | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gst/env.st b/gst/env.st index ee9111cd07..a6658aba57 100644 --- a/gst/env.st +++ b/gst/env.st @@ -20,8 +20,8 @@ Object subclass: Env [ 1 to: binds size do: [ :i | (binds at: i) = #& ifTrue: [ | rest | - rest := MALList new: (exprs copyFrom: i). - self set: (binds at: i + 1) value: rest. + rest := OrderedCollection from: (exprs copyFrom: i). + self set: (binds at: i + 1) value: (MALList new: rest). ^nil ] ifFalse: [ self set: (binds at: i) value: (exprs at: i) From 2aa83563229537338d238e98df0485e1ff7ea7f8 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 9 Jul 2017 23:57:14 +0200 Subject: [PATCH 0060/1998] Write function for relative loading --- gst/core.st | 5 ----- gst/env.st | 2 -- gst/printer.st | 2 -- gst/reader.st | 3 --- gst/step0_repl.st | 11 ++++++++++- gst/step1_read_print.st | 17 ++++++++++++++--- gst/step2_eval.st | 17 ++++++++++++++--- gst/step3_env.st | 19 +++++++++++++++---- gst/step4_if_fn_do.st | 21 ++++++++++++++++----- gst/step5_tco.st | 23 +++++++++++++++++------ gst/step6_file.st | 23 +++++++++++++++++------ gst/step7_quote.st | 23 +++++++++++++++++------ gst/step8_macros.st | 23 +++++++++++++++++------ gst/step9_try.st | 23 +++++++++++++++++------ gst/stepA_mal.st | 23 +++++++++++++++++------ 15 files changed, 171 insertions(+), 64 deletions(-) diff --git a/gst/core.st b/gst/core.st index 651ab63713..2ceae1a886 100644 --- a/gst/core.st +++ b/gst/core.st @@ -1,8 +1,3 @@ -FileStream fileIn: 'types.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'readline.st'. - Object subclass: Core [ Ns := Dictionary new. Core class >> Ns [ ^Ns ] diff --git a/gst/env.st b/gst/env.st index a6658aba57..c62f871434 100644 --- a/gst/env.st +++ b/gst/env.st @@ -1,5 +1,3 @@ -FileStream fileIn: 'types.st'. - Object subclass: Env [ | data outer | diff --git a/gst/printer.st b/gst/printer.st index d84994656f..c86fc7ebf3 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -1,5 +1,3 @@ -FileStream fileIn: 'types.st'. - Object subclass: Printer [ Printer class >> prStr: sexp printReadably: printReadably [ sexp type = #fn ifTrue: [ ^'#' ]. diff --git a/gst/reader.st b/gst/reader.st index 2cbeea0353..1515d277aa 100644 --- a/gst/reader.st +++ b/gst/reader.st @@ -1,6 +1,3 @@ -FileStream fileIn: 'types.st'. -FileStream fileIn: 'util.st'. - Object subclass: Reader [ | storage index | diff --git a/gst/step0_repl.st b/gst/step0_repl.st index 982d89db02..622347dfc7 100644 --- a/gst/step0_repl.st +++ b/gst/step0_repl.st @@ -1,4 +1,13 @@ -FileStream fileIn: 'readline.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step1_read_print.st b/gst/step1_read_print.st index 6b33705a97..4957a4ef48 100644 --- a/gst/step1_read_print.st +++ b/gst/step1_read_print.st @@ -1,6 +1,17 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step2_eval.st b/gst/step2_eval.st index c105f9497b..030dbcb6d8 100644 --- a/gst/step2_eval.st +++ b/gst/step2_eval.st @@ -1,6 +1,17 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step3_env.st b/gst/step3_env.st index bb7e8a14a7..baf0289293 100644 --- a/gst/step3_env.st +++ b/gst/step3_env.st @@ -1,7 +1,18 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step4_if_fn_do.st b/gst/step4_if_fn_do.st index 8bb7adb58a..a61e0b21c1 100644 --- a/gst/step4_if_fn_do.st +++ b/gst/step4_if_fn_do.st @@ -1,8 +1,19 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step5_tco.st b/gst/step5_tco.st index 9341b86c4e..d0289b8cef 100644 --- a/gst/step5_tco.st +++ b/gst/step5_tco.st @@ -1,9 +1,20 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'func.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step6_file.st b/gst/step6_file.st index 758cc68c52..93b475ee57 100644 --- a/gst/step6_file.st +++ b/gst/step6_file.st @@ -1,9 +1,20 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'func.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step7_quote.st b/gst/step7_quote.st index faeaf645f9..0e28848631 100644 --- a/gst/step7_quote.st +++ b/gst/step7_quote.st @@ -1,9 +1,20 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'func.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step8_macros.st b/gst/step8_macros.st index 69c7721ac3..df76eafd3e 100644 --- a/gst/step8_macros.st +++ b/gst/step8_macros.st @@ -1,9 +1,20 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'func.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/step9_try.st b/gst/step9_try.st index bd0e434247..1e98b38832 100644 --- a/gst/step9_try.st +++ b/gst/step9_try.st @@ -1,9 +1,20 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'func.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ diff --git a/gst/stepA_mal.st b/gst/stepA_mal.st index 2bd378d668..299ded9af7 100644 --- a/gst/stepA_mal.st +++ b/gst/stepA_mal.st @@ -1,9 +1,20 @@ -FileStream fileIn: 'readline.st'. -FileStream fileIn: 'reader.st'. -FileStream fileIn: 'printer.st'. -FileStream fileIn: 'env.st'. -FileStream fileIn: 'func.st'. -FileStream fileIn: 'core.st'. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := ContextPart thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. Object subclass: MAL [ MAL class >> READ: input [ From 06ecfc6a61172f1851ac9d03729e46684dcc2419 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 10 Jul 2017 09:04:39 +0200 Subject: [PATCH 0061/1998] Fix backquote error for perf tests --- gst/step7_quote.st | 6 +++--- gst/step8_macros.st | 6 +++--- gst/step9_try.st | 6 +++--- gst/stepA_mal.st | 6 +++--- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/gst/step7_quote.st b/gst/step7_quote.st index 0e28848631..7d6c70095a 100644 --- a/gst/step7_quote.st +++ b/gst/step7_quote.st @@ -47,7 +47,7 @@ Object subclass: MAL [ ] MAL class >> quasiquote: ast [ - | result a a0 a0_ a0_0 a0_1 rest | + | result a a0 a0_ a0_0 rest | ast isPair ifFalse: [ result := {MALSymbol new: #quote. ast}. ^MALList new: (OrderedCollection from: result) @@ -61,12 +61,12 @@ Object subclass: MAL [ a0 isPair ifTrue: [ a0_ := a0 value. a0_0 := a0_ first. - a0_1 := a0_ second. (a0_0 type = #symbol and: [ a0_0 value = #'splice-unquote' ]) ifTrue: [ rest := MALList new: a allButFirst. - result := {MALSymbol new: #concat. a0_1. + result := {MALSymbol new: #concat. + a0_ second. self quasiquote: rest}. ^MALList new: (OrderedCollection from: result) ] diff --git a/gst/step8_macros.st b/gst/step8_macros.st index df76eafd3e..d51ea1c048 100644 --- a/gst/step8_macros.st +++ b/gst/step8_macros.st @@ -47,7 +47,7 @@ Object subclass: MAL [ ] MAL class >> quasiquote: ast [ - | result a a0 a0_ a0_0 a0_1 rest | + | result a a0 a0_ a0_0 rest | ast isPair ifFalse: [ result := {MALSymbol new: #quote. ast}. ^MALList new: (OrderedCollection from: result) @@ -61,12 +61,12 @@ Object subclass: MAL [ a0 isPair ifTrue: [ a0_ := a0 value. a0_0 := a0_ first. - a0_1 := a0_ second. (a0_0 type = #symbol and: [ a0_0 value = #'splice-unquote' ]) ifTrue: [ rest := MALList new: a allButFirst. - result := {MALSymbol new: #concat. a0_1. + result := {MALSymbol new: #concat. + a0_ second. self quasiquote: rest}. ^MALList new: (OrderedCollection from: result) ] diff --git a/gst/step9_try.st b/gst/step9_try.st index 1e98b38832..ae1db7fd5d 100644 --- a/gst/step9_try.st +++ b/gst/step9_try.st @@ -47,7 +47,7 @@ Object subclass: MAL [ ] MAL class >> quasiquote: ast [ - | result a a0 a0_ a0_0 a0_1 rest | + | result a a0 a0_ a0_0 rest | ast isPair ifFalse: [ result := {MALSymbol new: #quote. ast}. ^MALList new: (OrderedCollection from: result) @@ -61,12 +61,12 @@ Object subclass: MAL [ a0 isPair ifTrue: [ a0_ := a0 value. a0_0 := a0_ first. - a0_1 := a0_ second. (a0_0 type = #symbol and: [ a0_0 value = #'splice-unquote' ]) ifTrue: [ rest := MALList new: a allButFirst. - result := {MALSymbol new: #concat. a0_1. + result := {MALSymbol new: #concat. + a0_ second. self quasiquote: rest}. ^MALList new: (OrderedCollection from: result) ] diff --git a/gst/stepA_mal.st b/gst/stepA_mal.st index 299ded9af7..29f15d2efc 100644 --- a/gst/stepA_mal.st +++ b/gst/stepA_mal.st @@ -47,7 +47,7 @@ Object subclass: MAL [ ] MAL class >> quasiquote: ast [ - | result a a0 a0_ a0_0 a0_1 rest | + | result a a0 a0_ a0_0 rest | ast isPair ifFalse: [ result := {MALSymbol new: #quote. ast}. ^MALList new: (OrderedCollection from: result) @@ -61,12 +61,12 @@ Object subclass: MAL [ a0 isPair ifTrue: [ a0_ := a0 value. a0_0 := a0_ first. - a0_1 := a0_ second. (a0_0 type = #symbol and: [ a0_0 value = #'splice-unquote' ]) ifTrue: [ rest := MALList new: a allButFirst. - result := {MALSymbol new: #concat. a0_1. + result := {MALSymbol new: #concat. + a0_ second. self quasiquote: rest}. ^MALList new: (OrderedCollection from: result) ] From 9592d833f21dbb74d56bdf7d1840353961a7b662 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 10 Jul 2017 09:12:48 +0200 Subject: [PATCH 0062/1998] Mention in README --- README.md | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index bcaa3ca76a..dfcb2004de 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 65 languages: +Mal is implemented in 66 languages: * Ada * GNU awk @@ -32,6 +32,7 @@ Mal is implemented in 65 languages: * Go * Groovy * GNU Guile +* GNU Smalltalk * Haskell * Haxe * Io @@ -441,6 +442,17 @@ cd guile guile -L ./ stepX_YYY.scm ``` +### GNU Smalltalk + +*The Smalltalk implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* + +The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. + +``` +cd gst +./run +``` + ### Haskell The Haskell implementation requires the ghc compiler version 7.10.1 or From ae63cd371bf6e6039ae1088b28dd1331297095e3 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 10 Jul 2017 21:39:05 +0200 Subject: [PATCH 0063/1998] Add dockerfile --- gst/Dockerfile | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 gst/Dockerfile diff --git a/gst/Dockerfile b/gst/Dockerfile new file mode 100644 index 0000000000..81b7cebc03 --- /dev/null +++ b/gst/Dockerfile @@ -0,0 +1,26 @@ +FROM ubuntu:wily +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# picolisp +RUN apt-get -y install gnu-smalltalk + From 1c72f6ba960435f58076206593d92be968bc8fbd Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 10 Jul 2017 21:47:05 +0200 Subject: [PATCH 0064/1998] Add to test matrix --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 711212ab7d..3a53dd5b6b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,6 +28,7 @@ matrix: - {env: IMPL=fsharp, services: [docker]} - {env: IMPL=go, services: [docker]} - {env: IMPL=groovy, services: [docker]} + - {env: IMPL=gst, services: [docker]} - {env: IMPL=guile, services: [docker]} - {env: IMPL=haskell, services: [docker]} - {env: IMPL=haxe, services: [docker]} From 65055aa22268020407107a51c5bb3e56d8efee51 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 10 Jul 2017 23:28:26 +0200 Subject: [PATCH 0065/1998] Backport a regex bugfix from 3.2.91 to 3.2.4 --- gst/util.st | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/gst/util.st b/gst/util.st index 03a226d09e..6e0e429d53 100644 --- a/gst/util.st +++ b/gst/util.st @@ -33,8 +33,29 @@ BlockClosure extend [ valueWithExit [ ^self value: [ ^nil ] ] +] + +"NOTE: bugfix version from 3.2.91 for 3.2.4" +Namespace current: Kernel [ + +MatchingRegexResults extend [ + at: anIndex [ + + | reg text | + anIndex = 0 ifTrue: [^self match]. + cache isNil ifTrue: [cache := Array new: registers size]. + (cache at: anIndex) isNil + ifTrue: + [reg := registers at: anIndex. + text := reg isNil + ifTrue: [nil] + ifFalse: [ + reg isEmpty + ifTrue: [''] + ifFalse: [self subject copyFrom: reg first to: reg last]]. + cache at: anIndex put: text]. + ^cache at: anIndex + ] +] - "HACK" - type [ ^#closure ] - value [ ^nil ] ] From c4a26e54717d6aeaf6dfb908966db929f64718dc Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 11 Jul 2017 23:38:06 +0200 Subject: [PATCH 0066/1998] Implement gst-eval --- gst/core.st | 2 ++ gst/tests/stepA_mal.mal | 11 +++++++++++ gst/util.st | 27 +++++++++++++++++++++++++++ 3 files changed, 40 insertions(+) create mode 100644 gst/tests/stepA_mal.mal diff --git a/gst/core.st b/gst/core.st index 2ceae1a886..d1c52de0ce 100644 --- a/gst/core.st +++ b/gst/core.st @@ -85,6 +85,8 @@ Core Ns at: #readline put: ] ]). Core Ns at: #'time-ms' put: (Fn new: [ :args | MALNumber new: Time millisecondClock ]). +Core Ns at: #'gst-eval' put: + (Fn new: [ :args | (Behavior evaluate: args first value) toMALValue ]). Core Ns at: #atom put: (Fn new: [ :args | MALAtom new: args first ]). diff --git a/gst/tests/stepA_mal.mal b/gst/tests/stepA_mal.mal new file mode 100644 index 0000000000..32221a4580 --- /dev/null +++ b/gst/tests/stepA_mal.mal @@ -0,0 +1,11 @@ +(gst-eval "1 + 1") +;=>2 + +(gst-eval "{1. 2. 3}") +;=>[1 2 3] + +(gst-eval "#('a' 'b' 'c') join: ' '") +;=>"a b c" + +(gst-eval "'Hello World!' displayNl") +; Hello World! diff --git a/gst/util.st b/gst/util.st index 6e0e429d53..5a73576e27 100644 --- a/gst/util.st +++ b/gst/util.st @@ -35,6 +35,33 @@ BlockClosure extend [ ] ] +Object extend [ + toMALValue [ + self = true ifTrue: [ ^MALObject True ]. + self = false ifTrue: [ ^MALObject False ]. + self = nil ifTrue: [ ^MALObject Nil ]. + self isNumber ifTrue: [ ^MALNumber new: self ]. + self isString ifTrue: [ ^MALString new: self ]. + self isSymbol ifTrue: [ ^MALSymbol new: self ]. + self isArray ifTrue: [ + ^MALVector new: (self asOrderedCollection collect: + [ :item | item toMALValue ]) + ]. + self isSequenceable ifTrue: [ + ^MALList new: (self asOrderedCollection collect: + [ :item | item toMALValue ]) + ]. + self class = Dictionary ifTrue: [ + | result | + result := Dictionary new. + self keysAndValuesDo: [ :key :value | + result at: key toMALValue put: value toMALValue + ]. + ^MALMap new: result + ] + ] +] + "NOTE: bugfix version from 3.2.91 for 3.2.4" Namespace current: Kernel [ From 4c696bfb54c98b161070490b3e423b6bb0e9fbdc Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Tue, 18 Jul 2017 21:34:36 +0200 Subject: [PATCH 0067/1998] Elm: GC almost working. --- elm/Core.elm | 4 +- elm/Env.elm | 194 ++++++++++++++++++++++++++++++----------- elm/Eval.elm | 25 ++++++ elm/Makefile | 2 +- elm/Printer.elm | 35 ++++++-- elm/Types.elm | 2 + elm/step4_if_fn_do.elm | 6 +- elm/step5_tco.elm | 6 +- elm/step6_file.elm | 8 +- elm/step7_quote.elm | 8 +- elm/step8_macros.elm | 10 +-- elm/step9_try.elm | 10 +-- elm/stepA_mal.elm | 19 ++-- mal/core.mal | 4 +- 14 files changed, 241 insertions(+), 92 deletions(-) diff --git a/elm/Core.elm b/elm/Core.elm index 95b9adf9c3..1b31ae9e4e 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -500,12 +500,12 @@ ns = callFn func [ inv ] |> Eval.andThen (\outv -> - go func rest (outv :: acc) + Eval.pushRef outv (go func rest (outv :: acc)) ) in case args of [ MalFunction func, MalList list ] -> - go func list [] + Eval.withStack (go func list []) [ MalFunction func, MalVector vec ] -> go func (Array.toList vec) [] diff --git a/elm/Env.elm b/elm/Env.elm index 867df02eae..ae64056437 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -3,17 +3,19 @@ module Env ( debug , globalFrameId , global - , push - , pop - , jump - , enter - , leave - , ref , get , set , newAtom , getAtom , setAtom + , push + , pop + , enter + , jump + , leave + , ref + , pushRef + , restoreRefs , gc ) @@ -38,12 +40,12 @@ globalFrameId = defaultGcInterval : Int defaultGcInterval = - 3 + 10 global : Env global = - { frames = Dict.singleton globalFrameId (emptyFrame Nothing) + { frames = Dict.singleton globalFrameId (emptyFrame Nothing Nothing) , nextFrameId = globalFrameId + 1 , currentFrameId = globalFrameId , atoms = Dict.empty @@ -51,11 +53,12 @@ global = , debug = False , gcInterval = defaultGcInterval , gcCounter = 0 + , stack = [] } -getFrame : Int -> Env -> Frame -getFrame frameId env = +getFrame : Env -> Int -> Frame +getFrame env frameId = case Dict.get frameId env.frames of Just frame -> frame @@ -64,9 +67,10 @@ getFrame frameId env = Debug.crash <| "frame #" ++ (toString frameId) ++ " not found" -emptyFrame : Maybe Int -> Frame -emptyFrame outerId = +emptyFrame : Maybe Int -> Maybe Int -> Frame +emptyFrame outerId exitId = { outerId = outerId + , exitId = exitId , data = Dict.empty , refCnt = 1 } @@ -96,7 +100,7 @@ get name env = go frameId = let frame = - getFrame frameId env + getFrame env frameId in case Dict.get name frame.data of Just value -> @@ -142,11 +146,6 @@ setAtom atomId value env = } -jump : Int -> Env -> Env -jump frameId env = - { env | currentFrameId = frameId } - - push : Env -> Env push env = let @@ -154,7 +153,10 @@ push env = env.nextFrameId newFrame = - emptyFrame (Just env.currentFrameId) + emptyFrame (Just env.currentFrameId) Nothing + + bogus = + debug env "push" frameId in { env | currentFrameId = frameId @@ -170,7 +172,10 @@ pop env = env.currentFrameId frame = - getFrame frameId env + getFrame env frameId + + bogus = + debug env "pop" frameId in case frame.outerId of Just outerId -> @@ -194,14 +199,19 @@ setBinds binds frame = { frame | data = Dict.insert name expr frame.data } +{-| Enter a new frame with a set of binds +-} enter : Int -> List ( String, MalExpr ) -> Env -> Env -enter parentFrameId binds env = +enter outerId binds env = let frameId = debug env "enter #" env.nextFrameId + exitId = + env.currentFrameId + newFrame = - setBinds binds (emptyFrame (Just parentFrameId)) + setBinds binds (emptyFrame (Just outerId) (Just exitId)) in { env | currentFrameId = frameId @@ -210,15 +220,55 @@ enter parentFrameId binds env = } -leave : Int -> Env -> Env -leave orgFrameId env = +{-| Jump into a frame +-} +jump : Int -> Env -> Env +jump frameId env = + let + setExitId = + Maybe.map + (\frame -> + { frame + | exitId = Just env.currentFrameId + , refCnt = frame.refCnt + 1 + } + ) + + bogus = + debug env "jump #" frameId + in + { env + | currentFrameId = frameId + , frames = Dict.update frameId setExitId env.frames + } + + +leave : Env -> Env +leave env = let frameId = debug env "leave #" env.currentFrameId + + frame = + getFrame env frameId + + exitId = + case frame.exitId of + Just exitId -> + exitId + + Nothing -> + Debug.crash <| + "frame #" + ++ (toString frameId) + ++ " doesn't have an exitId" in { env - | currentFrameId = orgFrameId - , frames = Dict.update frameId free env.frames + | currentFrameId = exitId + , frames = + env.frames + |> Dict.insert frameId { frame | exitId = Nothing } + |> Dict.update frameId free } @@ -231,7 +281,7 @@ ref env = go frameId env = let frame = - getFrame frameId env + getFrame env frameId newFrame = { frame | refCnt = frame.refCnt + 1 } @@ -263,6 +313,16 @@ free = ) +pushRef : MalExpr -> Env -> Env +pushRef ref env = + { env | stack = ref :: env.stack } + + +restoreRefs : List MalExpr -> Env -> Env +restoreRefs refs env = + { env | stack = refs } + + {-| Given an Env see which frames are not reachable from the global frame, or from the current expression. @@ -270,10 +330,12 @@ Return a new Env with the unreachable frames removed. -} gc : MalExpr -> Env -> Env -gc currentExpr env = +gc expr env = let + -- bogus = + -- Debug.log "GC stack = " env.stack countList acc = - List.foldl countRefs acc + List.foldl countExpr acc countFrame { data } acc = data |> Dict.values |> countList acc @@ -282,22 +344,28 @@ gc currentExpr env = if not (Set.member frameId acc) then let frame = - getFrame frameId env + getFrame env frameId newAcc = - (Set.insert frameId acc) + Set.insert frameId acc in countFrame frame newAcc else acc - countRefs expr acc = + countBound bound acc = + bound + |> List.map Tuple.second + |> countList acc + + countExpr expr acc = case expr of MalFunction (UserFunc { frameId }) -> recur frameId acc - MalApply { frameId } -> + MalApply { frameId, bound } -> recur frameId acc + |> countBound bound MalList list -> countList acc list @@ -313,7 +381,7 @@ gc currentExpr env = value = getAtom atomId env in - countRefs value acc + countExpr value acc _ -> acc @@ -321,26 +389,42 @@ gc currentExpr env = initSet = Set.fromList [ globalFrameId, env.currentFrameId ] - expandParents frameId acc = + countFrames frames acc = + Set.toList frames + |> List.map (getFrame env) + |> List.foldl countFrame acc + + expand frameId frame fn acc = + case fn frame of + Nothing -> + acc + + Just parentId -> + Set.insert parentId acc + + expandBoth frameId = let frame = - getFrame frameId env + getFrame env frameId in - case frame.outerId of - Just parentId -> - Set.insert parentId acc - - Nothing -> - acc + expand frameId frame .outerId + >> expand frameId frame .exitId - expandAllFrames frames = - Set.foldl expandParents frames frames + expandParents frames = + Set.foldl expandBoth frames frames - makeEmptyFrame frameId = - ( frameId, emptyFrame Nothing ) + loop acc = + let + newAcc = + expandParents acc - globalFrame = - getFrame globalFrameId env + newParents = + Set.diff newAcc acc + in + if Set.isEmpty newParents then + newAcc + else + loop <| countFrames newParents newAcc makeNewEnv newFrames = { env @@ -353,10 +437,16 @@ gc currentExpr env = filterFrames frames keep = Dict.filter (keepFilter keep) frames + + reportUnused frames keep = + Set.diff (Set.fromList (Dict.keys frames)) keep + |> Debug.log "\n\nUNUSED FRAMES\n\n" + |> always keep in - initSet - |> countRefs currentExpr - |> countFrame globalFrame - |> expandAllFrames + countFrames initSet initSet + |> countExpr expr + |> (flip countList) env.stack + |> loop + -- |> reportUnused env.frames |> filterFrames env.frames |> makeNewEnv diff --git a/elm/Eval.elm b/elm/Eval.elm index 4bd38a19ed..1d37df3eb6 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -3,6 +3,7 @@ module Eval exposing (..) import Types exposing (..) import IO exposing (IO) import Env +import Printer exposing (printEnv) apply : Eval a -> Env -> EvalContext a @@ -89,6 +90,12 @@ gcPass e env = let go env t expr = if env.gcCounter >= env.gcInterval then + --Debug.log + -- ("before GC: " + -- ++ (printEnv env) + -- ) + -- "" + -- |> always ( Env.gc env, t expr ) ( Env.gc expr env, t expr ) else ( env, t expr ) @@ -172,3 +179,21 @@ ignore right left = right |> andThen (\_ -> succeed res) ) + + +withStack : Eval a -> Eval a +withStack e = + withEnv + (\env -> + e + |> ignore + (modifyEnv + (Env.restoreRefs env.stack) + ) + ) + + +pushRef : MalExpr -> Eval a -> Eval a +pushRef ref e = + modifyEnv (Env.pushRef ref) + |> andThen (always e) diff --git a/elm/Makefile b/elm/Makefile index d9724a99f6..e7ad0989a0 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,4 +1,4 @@ -SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ +SOURCES = stepA_mal.elm #step0_repl.elm step1_read_print.elm step2_eval.elm \ step3_env.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm \ step7_quote.elm step8_macros.elm step9_try.elm stepA_mal.elm diff --git a/elm/Printer.elm b/elm/Printer.elm index 0da4e2dda7..6359a23925 100644 --- a/elm/Printer.elm +++ b/elm/Printer.elm @@ -2,7 +2,7 @@ module Printer exposing (..) import Array exposing (Array) import Dict exposing (Dict) -import Types exposing (Env, MalExpr(..), keywordPrefix) +import Types exposing (Env, MalExpr(..), keywordPrefix, MalFunction(..)) import Utils exposing (encodeString, wrap) import Env @@ -40,6 +40,18 @@ printString env readably ast = MalMap map -> printMap env readably map + MalFunction (UserFunc { frameId, meta }) -> + "# + "" + + Just meta -> + " meta=" ++ printString env True meta + ) + ++ ">" + MalFunction _ -> "#" @@ -50,8 +62,19 @@ printString env readably ast = in "(atom " ++ (printString env True value) ++ ")" - MalApply _ -> - "#" + MalApply { frameId, bound } -> + "#" + + +printBound : Env -> Bool -> List ( String, MalExpr ) -> String +printBound env readably = + let + printEntry name value = + name ++ "=" ++ (printString env readably value) + in + List.map (uncurry printEntry) + >> String.join " " + >> wrap "(" ")" printRawString : Env -> Bool -> String -> String @@ -107,11 +130,13 @@ printEnv env = printOuterId = Maybe.map toString >> Maybe.withDefault "nil" - printHeader frameId { outerId, refCnt } = + printHeader frameId { outerId, exitId, refCnt } = "#" ++ (toString frameId) ++ " outer=" ++ printOuterId outerId + ++ " exit=" + ++ printOuterId exitId ++ " refCnt=" ++ (toString refCnt) @@ -125,7 +150,7 @@ printEnv env = printFrame k v :: acc printDatum k v acc = - (k ++ " = " ++ (printString env True v)) :: acc + (k ++ " = " ++ (printString env False v)) :: acc in "--- Environment ---\n" ++ "Current frame: #" diff --git a/elm/Types.elm b/elm/Types.elm index e978f638c4..1cdcb110cc 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -16,6 +16,7 @@ type Msg type alias Frame = { outerId : Maybe Int + , exitId : Maybe Int , data : Dict String MalExpr , refCnt : Int } @@ -30,6 +31,7 @@ type alias Env = , debug : Bool , gcInterval : Int , gcCounter : Int + , stack : List MalExpr } diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index ed1af853b4..c769ffaaae 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -187,7 +187,7 @@ eval ast = fn args (MalFunction (UserFunc { eagerFn })) :: args -> - eagerFn args + eagerFn [] args fn :: _ -> Eval.withEnv @@ -427,7 +427,7 @@ evalFn args = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (always (eval body)) - |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.finally Env.leave ) Err msg -> @@ -437,7 +437,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = fn - , eagerFn = fn + , eagerFn = always fn , isMacro = False , meta = Nothing } diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index d00791ef4f..96a87b46cc 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -188,8 +188,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally (Env.leave env.currentFrameId) - |> Eval.gcPass + |> Eval.finally Env.leave + |> Eval.gcPass [] ) @@ -475,7 +475,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval + , eagerFn = \_ -> lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 93d392888c..87643819ce 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -250,7 +250,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.finally (Env.jump env.currentFrameId) + |> Eval.finally Env.leave ) _ -> @@ -263,8 +263,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally (Env.leave env.currentFrameId) - |> Eval.gcPass + |> Eval.finally Env.leave + |> Eval.gcPass [] ) @@ -550,7 +550,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval + , eagerFn = \_ -> lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 5cc67c1f53..8a09aaa50e 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -250,7 +250,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.finally (Env.jump env.currentFrameId) + |> Eval.finally Env.leave ) _ -> @@ -263,8 +263,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally (Env.leave env.currentFrameId) - |> Eval.gcPass + |> Eval.finally Env.leave + |> Eval.gcPass [] ) @@ -549,7 +549,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval + , eagerFn = \_ -> lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm index 476b5da2db..adf9caa2f0 100644 --- a/elm/step8_macros.elm +++ b/elm/step8_macros.elm @@ -266,7 +266,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.finally (Env.jump env.currentFrameId) + |> Eval.finally Env.leave ) _ -> @@ -279,8 +279,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally (Env.leave env.currentFrameId) - |> Eval.gcPass + |> Eval.finally Env.leave + |> Eval.gcPass [] ) @@ -604,7 +604,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval + , eagerFn = \_ -> lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } @@ -687,7 +687,7 @@ macroexpand expr = case Env.get name env of Ok (MalFunction (UserFunc fn)) -> if fn.isMacro then - Left <| fn.eagerFn args + Left <| fn.eagerFn [] args else Right expr diff --git a/elm/step9_try.elm b/elm/step9_try.elm index 20963eb2b6..ba886aae6d 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -266,7 +266,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.finally (Env.jump env.currentFrameId) + |> Eval.finally Env.leave ) _ -> @@ -279,8 +279,8 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally (Env.leave env.currentFrameId) - |> Eval.gcPass + |> Eval.finally Env.leave + |> Eval.gcPass [] ) @@ -606,7 +606,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval + , eagerFn = \_ -> lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } @@ -689,7 +689,7 @@ macroexpand expr = case Env.get name env of Ok (MalFunction (UserFunc fn)) -> if fn.isMacro then - Left <| fn.eagerFn args + Left <| fn.eagerFn [] args else Right expr diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm index b6f60bd579..478b7c0c40 100644 --- a/elm/stepA_mal.elm +++ b/elm/stepA_mal.elm @@ -277,7 +277,7 @@ malEval args = (\env -> Eval.modifyEnv (Env.jump Env.globalFrameId) |> Eval.andThen (\_ -> eval expr) - |> Eval.finally (Env.jump env.currentFrameId) + |> Eval.finally Env.leave ) _ -> @@ -290,7 +290,7 @@ evalApply { frameId, bound, body } = (\env -> Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally (Env.leave env.currentFrameId) + |> Eval.finally Env.leave |> Eval.gcPass ) @@ -368,9 +368,14 @@ evalNoApply ast = _ -> evalAst ast in - debug "evalNoApply" - (\env -> printString env True ast) - (macroexpand ast |> Eval.andThen go) + macroexpand ast + |> Eval.andThen go + |> Eval.andThen + (\res -> + debug "evalNoApply" + (\env -> (printString env True ast) ++ " = " ++ (printString env True res)) + (Eval.succeed res) + ) evalAst : MalExpr -> Eval MalExpr @@ -413,10 +418,10 @@ evalList list = eval x |> Eval.andThen (\val -> - go rest (val :: acc) + Eval.pushRef val <| go rest (val :: acc) ) in - go list [] + Eval.withStack <| go list [] evalDef : List MalExpr -> Eval MalExpr diff --git a/mal/core.mal b/mal/core.mal index a766b80125..dbf7944c6d 100644 --- a/mal/core.mal +++ b/mal/core.mal @@ -60,4 +60,6 @@ ["atom?" atom?] ["deref" deref] ["reset!" reset!] - ["swap!" swap!]]) + ["swap!" swap!] + ["gc" gc] + ["pr-env" pr-env]]) From 55c252420126adc9c1b7bd5c4c2b270aa3303f1a Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 20 Jul 2017 11:36:36 +0000 Subject: [PATCH 0068/1998] tests: Add test cases in step4 and step9 --- tests/step4_if_fn_do.mal | 6 ++++++ tests/step9_try.mal | 2 ++ 2 files changed, 8 insertions(+) diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal index 7b0b9a015a..0b69031ac1 100644 --- a/tests/step4_if_fn_do.mal +++ b/tests/step4_if_fn_do.mal @@ -120,6 +120,12 @@ ;=>false (= "abc" "ABC") ;=>false +(= true true) +;=>true +(= false false) +;=>true +(= nil nil) +;=>true (= (list) (list)) ;=>true diff --git a/tests/step9_try.mal b/tests/step9_try.mal index 2d82121e86..17cfae240e 100644 --- a/tests/step9_try.mal +++ b/tests/step9_try.mal @@ -55,6 +55,8 @@ ;=>nil (apply list (list)) ;=>() +(apply symbol? (list (quote two))) +;=>true ;; Testing apply function with user functions (apply (fn* (a b) (+ a b)) (list 2 3)) From 33a372916d6495fa9b111b9e13071ba5810d65b1 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sun, 2 Apr 2017 10:46:45 +0000 Subject: [PATCH 0069/1998] Add rexx implementation --- Makefile | 3 +- rexx/.gitignore | 1 + rexx/Dockerfile | 26 ++ rexx/Makefile | 43 ++++ rexx/core.rexx | 498 +++++++++++++++++++++++++++++++++++++ rexx/env.rexx | 59 +++++ rexx/printer.rexx | 54 ++++ rexx/reader.rexx | 194 +++++++++++++++ rexx/readline.rexx | 8 + rexx/run | 2 + rexx/step0_repl.rexx | 23 ++ rexx/step1_read_print.rexx | 32 +++ rexx/step2_eval.rexx | 127 ++++++++++ rexx/step3_env.rexx | 151 +++++++++++ rexx/step4_if_fn_do.rexx | 176 +++++++++++++ rexx/step5_tco.rexx | 183 ++++++++++++++ rexx/step6_file.rexx | 214 ++++++++++++++++ rexx/step7_quote.rexx | 234 +++++++++++++++++ rexx/step8_macros.rexx | 265 ++++++++++++++++++++ rexx/step9_try.rexx | 286 +++++++++++++++++++++ rexx/stepA_mal.rexx | 291 ++++++++++++++++++++++ rexx/tests/step5_tco.mal | 2 + rexx/tests/stepA_mal.mal | 23 ++ rexx/types.rexx | 248 ++++++++++++++++++ 24 files changed, 3142 insertions(+), 1 deletion(-) create mode 100644 rexx/.gitignore create mode 100644 rexx/Dockerfile create mode 100644 rexx/Makefile create mode 100644 rexx/core.rexx create mode 100644 rexx/env.rexx create mode 100644 rexx/printer.rexx create mode 100644 rexx/reader.rexx create mode 100644 rexx/readline.rexx create mode 100755 rexx/run create mode 100644 rexx/step0_repl.rexx create mode 100644 rexx/step1_read_print.rexx create mode 100644 rexx/step2_eval.rexx create mode 100644 rexx/step3_env.rexx create mode 100644 rexx/step4_if_fn_do.rexx create mode 100644 rexx/step5_tco.rexx create mode 100644 rexx/step6_file.rexx create mode 100644 rexx/step7_quote.rexx create mode 100644 rexx/step8_macros.rexx create mode 100644 rexx/step9_try.rexx create mode 100644 rexx/stepA_mal.rexx create mode 100644 rexx/tests/step5_tco.mal create mode 100644 rexx/tests/stepA_mal.mal create mode 100644 rexx/types.rexx diff --git a/Makefile b/Makefile index 8bafcfee2f..805e3c4ca1 100644 --- a/Makefile +++ b/Makefile @@ -81,7 +81,7 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ - python r racket rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ + python r racket rexx rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ vimscript livescript EXTENSION = .mal @@ -203,6 +203,7 @@ ps_STEP_TO_PROG = ps/$($(1)).ps python_STEP_TO_PROG = python/$($(1)).py r_STEP_TO_PROG = r/$($(1)).r racket_STEP_TO_PROG = racket/$($(1)).rkt +rexx_STEP_TO_PROG = rexx/$($(1)).rexx rpython_STEP_TO_PROG = rpython/$($(1)) ruby_STEP_TO_PROG = ruby/$($(1)).rb rust_STEP_TO_PROG = rust/target/release/$($(1)) diff --git a/rexx/.gitignore b/rexx/.gitignore new file mode 100644 index 0000000000..8b0a0636a6 --- /dev/null +++ b/rexx/.gitignore @@ -0,0 +1 @@ +*.rexxpp diff --git a/rexx/Dockerfile b/rexx/Dockerfile new file mode 100644 index 0000000000..83b666f13f --- /dev/null +++ b/rexx/Dockerfile @@ -0,0 +1,26 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install cpp regina-rexx + +ENV HOME /mal diff --git a/rexx/Makefile b/rexx/Makefile new file mode 100644 index 0000000000..151ff038d6 --- /dev/null +++ b/rexx/Makefile @@ -0,0 +1,43 @@ +TESTS = + +SOURCES_BASE = readline.rexx types.rexx reader.rexx printer.rexx +SOURCES_LISP = env.rexx core.rexx stepA_mal.rexx +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +SRCS = step0_repl.rexx step1_read_print.rexx step2_eval.rexx step3_env.rexx \ + step4_if_fn_do.rexx step5_tco.rexx step6_file.rexx step7_quote.rexx \ + step8_macros.rexx step9_try.rexx stepA_mal.rexx +PREPROCESSED = $(SRCS:%.rexx=%.rexxpp) + +all: $(PREPROCESSED) dist + +dist: mal + +mal: mal.rexxpp + echo "#!/usr/bin/rexx -a" > $@ + cat $< >> $@ + chmod +x $@ + +mal.rexxpp: stepA_mal.rexxpp + cp -a $+ $@ + +$(PREPROCESSED): %.rexxpp: %.rexx readline.rexx types.rexx reader.rexx printer.rexx env.rexx core.rexx + cpp -CC -P -nostdinc $< > $@ + +clean: + rm -f mal.rexx mal *.rexxpp + +.PHONY: all dist clean stats tests $(TESTS) + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" + +tests: $(TESTS) + +$(TESTS): + @echo "Running $@"; \ + rexx $@ || exit 1; \ diff --git a/rexx/core.rexx b/rexx/core.rexx new file mode 100644 index 0000000000..d458fcf03c --- /dev/null +++ b/rexx/core.rexx @@ -0,0 +1,498 @@ +#ifndef __core__ +#define __core__ + +#include "types.rexx" + +mal_equal?: procedure expose values. /* mal_equal?(a, b) */ + return new_boolean(equal?(arg(1), arg(2))) + +mal_throw: procedure expose values. err /* mal_throw(a) */ + err = "__MAL_EXCEPTION__" arg(1) + return "ERR" + +mal_nil?: procedure expose values. /* mal_nil?(a) */ + return new_boolean(nil?(arg(1))) + +mal_true?: procedure expose values. /* mal_true?(a) */ + return new_boolean(true?(arg(1))) + +mal_false?: procedure expose values. /* mal_false?(a) */ + return new_boolean(false?(arg(1))) + +mal_string?: procedure expose values. /* mal_string?(a) */ + return new_boolean(string?(arg(1))) + +mal_symbol: procedure expose values. /* mal_symbol(a) */ + return new_symbol(obj_val(arg(1))) + +mal_symbol?: procedure expose values. /* mal_symbol?(a) */ + return new_boolean(symbol?(arg(1))) + +mal_keyword: procedure expose values. /* mal_keyword(a) */ + return new_keyword(obj_val(arg(1))) + +mal_keyword?: procedure expose values. /* mal_keyword?(a) */ + return new_boolean(keyword?(arg(1))) + +mal_pr_str: procedure expose values. /* mal_pr_str(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 1) + if i == 1 then + res = element + else + res = res || " " || element + end + return new_string(res) + +mal_str: procedure expose values. /* mal_str(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 0) + if i == 1 then + res = element + else + res = res || element + end + return new_string(res) + +mal_prn: procedure expose values. /* mal_prn(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 1) + if i == 1 then + res = element + else + res = res || " " || element + end + say res + return new_nil() + +mal_println: procedure expose values. /* mal_println(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 0) + if i == 1 then + res = element + else + res = res || " " || element + end + say res + return new_nil() + +mal_read_string: procedure expose values. /* mal_read_string(str) */ + return read_str(obj_val(arg(1))) + +mal_readline: procedure expose values. /* mal_readline(prompt) */ + line = readline(obj_val(arg(1))) + if length(line) > 0 then return new_string(line) + if lines() > 0 then return new_string("") + return new_nil() + +mal_slurp: procedure expose values. /* mal_read_string(filename) */ + file_content = charin(obj_val(arg(1)), , 100000) + return new_string(file_content) + +mal_lt: procedure expose values. /* mal_lt(a, b) */ + return new_boolean(obj_val(arg(1)) < obj_val(arg(2))) + +mal_lte: procedure expose values. /* mal_lte(a, b) */ + return new_boolean(obj_val(arg(1)) <= obj_val(arg(2))) + +mal_gt: procedure expose values. /* mal_gt(a, b) */ + return new_boolean(obj_val(arg(1)) > obj_val(arg(2))) + +mal_gte: procedure expose values. /* mal_gte(a, b) */ + return new_boolean(obj_val(arg(1)) >= obj_val(arg(2))) + +mal_add: procedure expose values. /* mal_add(a, b) */ + return new_number(obj_val(arg(1)) + obj_val(arg(2))) + +mal_sub: procedure expose values. /* mal_sub(a, b) */ + return new_number(obj_val(arg(1)) - obj_val(arg(2))) + +mal_mul: procedure expose values. /* mal_mul(a, b) */ + return new_number(obj_val(arg(1)) * obj_val(arg(2))) + +mal_div: procedure expose values. /* mal_div(a, b) */ + return new_number(obj_val(arg(1)) / obj_val(arg(2))) + +mal_time_ms: procedure expose values. /* mal_time_ms() */ + return new_number(trunc(time('E') * 1000)) + +mal_list: procedure expose values. /* mal_list(...) */ + res = "" + do i=1 to arg() + if i == 1 then + res = arg(i) + else + res = res || " " || arg(i) + end + return new_list(res) + +mal_list?: procedure expose values. /* mal_list?(a) */ + return new_boolean(list?(arg(1))) + +mal_vector: procedure expose values. /* mal_vector(...) */ + res = "" + do i=1 to arg() + if i == 1 then + res = arg(i) + else + res = res || " " || arg(i) + end + return new_vector(res) + +mal_vector?: procedure expose values. /* mal_vector?(a) */ + return new_boolean(vector?(arg(1))) + +mal_hash_map: procedure expose values. /* mal_hash_map(...) */ + res = "" + do i=1 to arg() + if i == 1 then + res = arg(i) + else + res = res || " " || arg(i) + end + return new_hashmap(res) + +mal_map?: procedure expose values. /* mal_map?(a) */ + return new_boolean(hashmap?(arg(1))) + +mal_assoc: procedure expose values. /* mal_assoc(a, ...) */ + hm = arg(1) + res = "" + do i=2 to arg() by 2 + key_val = arg(i) || " " || arg(i + 1) + if res == 2 then + res = key_val + else + res = res || " " || key_val + end + hm_val = obj_val(hm) + do i=1 to words(hm_val) by 2 + if \contains?(res, word(hm_val, i)) then + res = res || " " || word(hm_val, i) || " " || word(hm_val, i + 1) + end + return new_hashmap(res) + +mal_dissoc: procedure expose values. /* mal_dissoc(a, ...) */ + hm = arg(1) + res = "" + hm_val = obj_val(hm) + do i=1 to words(hm_val) by 2 + key = word(hm_val, i) + found = 0 + do j=2 to arg() + if equal?(key, arg(j)) then do + found = 1 + leave + end + end + if \found then do + if length(res) > 0 then res = res || " " + res = res || key || " " || word(hm_val, i + 1) + end + end + return new_hashmap(res) + +mal_get: procedure expose values. /* mal_get(a, b) */ + res = hashmap_get(obj_val(arg(1)), arg(2)) + if res == "" then + return new_nil() + else + return res + +mal_contains?: procedure expose values. /* mal_contains?(a, b) */ + return new_boolean(contains?(obj_val(arg(1)), arg(2))) + +mal_keys: procedure expose values. /* mal_keys(a) */ + hm_val = obj_val(arg(1)) + seq = "" + do i=1 to words(hm_val) by 2 + if i == 1 then + seq = word(hm_val, i) + else + seq = seq || " " || word(hm_val, i) + end + return new_list(seq) + +mal_vals: procedure expose values. /* mal_vals(a) */ + hm_val = obj_val(arg(1)) + seq = "" + do i=2 to words(hm_val) by 2 + if i == 1 then + seq = word(hm_val, i) + else + seq = seq || " " || word(hm_val, i) + end + return new_list(seq) + +mal_sequential?: procedure expose values. /* mal_sequential?(a) */ + return new_boolean(sequential?(arg(1))) + +mal_cons: procedure expose values. /* mal_cons(a, b) */ + return new_list(arg(1) || " " || obj_val(arg(2))) + +mal_concat: procedure expose values. /* mal_concat(...) */ + seq = "" + do i=1 to arg() + if i == 1 then + seq = obj_val(arg(i)) + else + seq = seq || " " || obj_val(arg(i)) + end + return new_list(seq) + +mal_nth: procedure expose values. err /* mal_nth(list, index) */ + list_val = obj_val(arg(1)) + i = obj_val(arg(2)) + if i >= words(list_val) then do + err = "nth: index out of range" + return "ERR" + end + return word(list_val, i + 1) + +mal_first: procedure expose values. /* mal_first(a) */ + if nil?(arg(1)) then return new_nil() + list_val = obj_val(arg(1)) + if words(list_val) == 0 then return new_nil() + return word(list_val, 1) + +mal_rest: procedure expose values. /* mal_rest(a) */ + return new_list(subword(obj_val(arg(1)), 2)) + +mal_empty?: procedure expose values. /* mal_empty?(a) */ + if nil?(arg(1)) then return new_true() + return new_boolean(count_elements(arg(1)) == 0) + +mal_count: procedure expose values. /* mal_count(a) */ + if nil?(arg(1)) then return new_number(0) + return new_number(count_elements(arg(1))) + +apply_function: procedure expose values. env. err /* apply_function(fn, lst) */ + f = arg(1) + call_args = arg(2) + select + when nativefn?(f) then do + call_args_val = obj_val(call_args) + call_list = "" + do i=1 to words(call_args_val) + element = '"' || word(call_args_val, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + apply_env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + return eval(func_body_ast(f), apply_env_idx) + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + +mal_apply: procedure expose values. env. err /* mal_apply(fn, ..., lst) */ + fn = arg(1) + seq = "" + do i=2 to (arg() - 1) + if i == 2 then + seq = arg(i) + else + seq = seq || " " || arg(i) + end + if arg() > 1 then do + seq = seq || " " || obj_val(arg(arg())) + end + return apply_function(fn, new_list(seq)) + +mal_map: procedure expose values. env. err /* mal_map(f, lst) */ + fn = arg(1) + lst_val = obj_val(arg(2)) + res = "" + do i=1 to words(lst_val) + element = word(lst_val, i) + mapped_element = apply_function(fn, new_list(element)) + if mapped_element == "ERR" then return "ERR" + if i == 1 then + res = mapped_element + else + res = res || " " || mapped_element + end + return new_list(res) + +mal_conj: procedure expose values. env. err /* mal_conj(a, ...) */ + a = arg(1) + select + when list?(a) then do + do i=2 to arg() + a = mal_cons(arg(i), a) + end + return a + end + when vector?(a) then do + seq = obj_val(a) + do i=2 to arg() + if length(seq) > 0 then seq = seq || " " + seq = seq || arg(i) + end + return new_vector(seq) + end + otherwise + err = "conj requires list or vector" + return "ERR" + end + +mal_seq: procedure expose values. env. err /* mal_conj(a) */ + a = arg(1) + select + when string?(a) then do + str = obj_val(a) + if length(str) == 0 then return new_nil() + seq = "" + do i=1 to length(str) + element = new_string(substr(str, i, 1)) + if i == 1 then + seq = element + else + seq = seq || " " || element + end + return new_list(seq) + end + when list?(a) then do + if count_elements(a) == 0 then return new_nil() + return a + end + when vector?(a) then do + if count_elements(a) == 0 then return new_nil() + return new_list(obj_val(a)) + end + when nil?(a) then return new_nil() + otherwise + err = "seq requires string or list or vector or nil" + return "ERR" + end + +mal_with_meta: procedure expose values. /* mal_with_meta(a, b) */ + new_obj = obj_clone_and_set_meta(arg(1), arg(2)) + if new_obj == "" then return arg(1) + return new_obj + +mal_meta: procedure expose values. /* mal_meta(a) */ + meta = obj_meta(arg(1)) + if meta == "" then return new_nil() + return meta + +mal_atom: procedure expose values. /* mal_atom(a) */ + return new_atom(arg(1)) + +mal_atom?: procedure expose values. /* mal_atom?(a) */ + return new_boolean(atom?(arg(1))) + +mal_deref: procedure expose values. /* mal_deref(a) */ + return obj_val(arg(1)) + +mal_reset!: procedure expose values. /* mal_reset!(a, new_val) */ + return atom_set(arg(1), arg(2)) + +mal_swap!: procedure expose values. env. err /* mal_swap!(a, fn, ...) */ + atom = arg(1) + fn = arg(2) + atom_val = obj_val(atom) + seq = atom_val + do i=3 to arg() + seq = seq || " " || arg(i) + end + new_val = apply_function(fn, new_list(seq)) + if new_val == "ERR" then return "ERR" + return atom_set(atom, new_val) + +mal_rexx_eval: procedure expose values. /* mal_rexx_eval(..., a) */ + do i=1 to (arg() - 1) + interpret obj_val(arg(i)) + end + last_arg = arg(arg()) + if nil?(last_arg) then return new_nil() + last_arg_str = obj_val(last_arg) + if length(last_arg_str) == 0 then return new_nil() + rexx_eval_res = "" + interpret "rexx_eval_res = " || last_arg_str + if datatype(rexx_eval_res) == "NUM" then + return new_number(rexx_eval_res) + else + return new_string(rexx_eval_res) + +get_core_ns: procedure /* get_core_ns() */ + return "= mal_equal?" , + "throw mal_throw" , + , + "nil? mal_nil?" , + "true? mal_true?" , + "false? mal_false?" , + "string? mal_string?" , + "symbol mal_symbol" , + "symbol? mal_symbol?" , + "keyword mal_keyword" , + "keyword? mal_keyword?" , + , + "pr-str mal_pr_str" , + "str mal_str" , + "prn mal_prn" , + "println mal_println" , + "read-string mal_read_string" , + "readline mal_readline" , + "slurp mal_slurp" , + , + "< mal_lt" , + "<= mal_lte" , + "> mal_gt" , + ">= mal_gte" , + "+ mal_add" , + "- mal_sub" , + "* mal_mul" , + "/ mal_div" , + "time-ms mal_time_ms" , + , + "list mal_list" , + "list? mal_list?" , + "vector mal_vector" , + "vector? mal_vector?" , + "hash-map mal_hash_map" , + "map? mal_map?" , + "assoc mal_assoc" , + "dissoc mal_dissoc" , + "get mal_get" , + "contains? mal_contains?" , + "keys mal_keys" , + "vals mal_vals" , + , + "sequential? mal_sequential?" , + "cons mal_cons" , + "concat mal_concat" , + "nth mal_nth" , + "first mal_first" , + "rest mal_rest" , + "empty? mal_empty?" , + "count mal_count" , + "apply mal_apply" , + "map mal_map" , + , + "conj mal_conj" , + "seq mal_seq" , + , + "meta mal_meta" , + "with-meta mal_with_meta" , + "atom mal_atom" , + "atom? mal_atom?" , + "deref mal_deref" , + "reset! mal_reset!" , + "swap! mal_swap!" , + , + "rexx-eval mal_rexx_eval" + +#endif diff --git a/rexx/env.rexx b/rexx/env.rexx new file mode 100644 index 0000000000..4dec7e62bf --- /dev/null +++ b/rexx/env.rexx @@ -0,0 +1,59 @@ +#ifndef __env__ +#define __env__ + +env. = "" +env.0 = 0 + +new_env_index: procedure expose env. /* new_env_index() */ + env.0 = env.0 + 1 + return env.0 + +new_env: procedure expose env. values. /* new_env(outer_env_idx [, binds, exprs]) */ + outer_env_idx = arg(1) + binds = arg(2) + exprs = arg(3) + idx = new_env_index() + env.idx.outer = outer_env_idx + env.idx.data. = "" + if binds \= "" then do + binds_val = obj_val(binds) + exprs_val = obj_val(exprs) + do i=1 to words(binds_val) + varname = obj_val(word(binds_val, i)) + if varname == "&" then do + rest_args_list = new_list(subword(exprs_val, i)) + varname = obj_val(word(binds_val, i + 1)) + x = env_set(idx, varname, rest_args_list) + leave + end + else + x = env_set(idx, varname, word(exprs_val, i)) + end + end + return idx + +env_set: procedure expose env. /* env_set(env_idx, key, val) */ + env_idx = arg(1) + key = arg(2) + val = arg(3) + env.env_idx.data.key = val + return val + +env_find: procedure expose env. /* env_find(env_idx, key) */ + env_idx = arg(1) + key = arg(2) + if env.env_idx.data.key \= "" then return env_idx + if env.env_idx.outer > 0 then return env_find(env.env_idx.outer, key) + return 0 + +env_get: procedure expose env. err /* env_get(env_idx, key) */ + env_idx = arg(1) + key = arg(2) + found_env_idx = env_find(env_idx, key) + if found_env_idx == 0 then do + err = "'" || key || "' not found" + return "ERR" + end + return env.found_env_idx.data.key + +#endif diff --git a/rexx/printer.rexx b/rexx/printer.rexx new file mode 100644 index 0000000000..e7922ef0ab --- /dev/null +++ b/rexx/printer.rexx @@ -0,0 +1,54 @@ +#ifndef __printer__ +#define __printer__ + +#include "types.rexx" + +format_string: procedure /* format_string(str, readable) */ + str = arg(1) + readable = arg(2) + if readable then do + res = changestr('5C'x, str, "\\") + res = changestr('"', res, '\"') + res = changestr('0A'x, res, "\n") + return '"' || res || '"' + end + else + return str + +format_sequence: procedure expose values. /* format_sequence(val, open_char, close_char, readable) */ + val = arg(1) + open_char = arg(2) + close_char = arg(3) + readable = arg(4) + res = "" + do i=1 to words(val) + element = word(val, i) + if i > 1 then res = res || " " + res = res || pr_str(element, readable) + end + return open_char || res || close_char + +pr_str: procedure expose values. /* pr_str(ast, readable) */ + ast = arg(1) + readable = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "nill" then return "nil" + when type == "true" then return "true" + when type == "fals" then return "false" + when type == "numb" then return val + when type == "symb" then return val + when type == "stri" then return format_string(val, readable) + when type == "keyw" then return ":" || val + when type == "list" then return format_sequence(val, "(", ")", readable) + when type == "vect" then return format_sequence(val, "[", "]", readable) + when type == "hash" then return format_sequence(val, "{", "}", readable) + when type == "nafn" then return "#" + when type == "func" then return "#" + when type == "atom" then return "(atom " || pr_str(val, readable) || ")" + otherwise + return "#" + end + +#endif diff --git a/rexx/reader.rexx b/rexx/reader.rexx new file mode 100644 index 0000000000..3afc8620d0 --- /dev/null +++ b/rexx/reader.rexx @@ -0,0 +1,194 @@ +#ifndef __reader__ +#define __reader__ + +#include "types.rexx" + +next_token: procedure expose pos /* next_token(str) */ + TAB = '09'x + LF = '0A'x + CR = '0D'x + SEPARATOR_CHARS = TAB || LF || CR || " []{}()'`,;" || '"' + WHITESPACE_CHARS = TAB || LF || CR || " ," + str = arg(1) + token = "" + ch = substr(str, pos, 1) + select + when pos(ch, WHITESPACE_CHARS) > 0 then + pos = pos + 1 + when pos(ch, "[]{}()'`^@") > 0 then do + pos = pos + 1 + token = ch + end + when ch == '~' then do + if substr(str, pos + 1, 1) == '@' then do + pos = pos + 2 + token = "~@" + end + else do + pos = pos + 1 + token = "~" + end + end + when ch == ";" then do + do while pos <= length(str) + ch = substr(str, pos, 1) + if (ch == LF) | (ch == CR) then + leave + else + pos = pos + 1 + end + end + when ch == '"' then do + tmppos = pos + 1 + do while tmppos < length(str) + ch = substr(str, tmppos, 1) + select + when ch == '"' then + leave + when ch == '5C'x then /* backslash */ + tmppos = tmppos + 2 + otherwise + tmppos = tmppos + 1 + end + end + token = substr(str, pos, tmppos - pos + 1) + pos = tmppos + 1 + end + otherwise + tmppos = pos + do while tmppos <= length(str) + ch = substr(str, tmppos, 1) + if pos(ch, SEPARATOR_CHARS) > 0 then + leave + else + token = token || ch + tmppos = tmppos + 1 + end + pos = tmppos + end + return token + +tokenize: procedure expose tokens. /* tokenize(str) */ + str = arg(1) + tokens. = "" + num_of_tokens = 0 + str_to_tokenize = str + pos = 1 + do while pos <= length(str) + token = next_token(str_to_tokenize) + if length(token) > 0 then do + num_of_tokens = num_of_tokens + 1 + tokens.num_of_tokens = token + end + end + tokens.0 = num_of_tokens + return num_of_tokens + +is_number: procedure /* is_number(token) */ + token = arg(1) + ch = substr(token, 1, 1) + DIGITS = "0123456789" + if pos(ch, DIGITS) > 0 then return 1 + if (ch == '-') & (pos(substr(token, 2, 1), DIGITS) > 0) then return 1 + return 0 + +parse_string: procedure /* parse_string(token) */ + token = arg(1) + res = substr(token, 2, length(token) - 2) /* Remove quotes */ + res = changestr("\n", res, '0A'x) + res = changestr('\"', res, '"') + res = changestr("\\", res, '5C'x) + return res + +parse_keyword: procedure /* parse_keyword(token) */ + token = arg(1) + return substr(token, 2) /* Remove initial ":" */ + +read_atom: procedure expose values. tokens. pos /* read_atom() */ + token = tokens.pos + pos = pos + 1 + select + when is_number(token) then return new_number(token) + when token == "nil" then return new_nil() + when token == "true" then return new_true() + when token == "false" then return new_false() + when substr(token, 1, 1) == ':' then return new_keyword(parse_keyword(token)) + when substr(token, 1, 1) == '"' then return new_string(parse_string(token)) + otherwise + return new_symbol(token) + end + +read_sequence: procedure expose values. tokens. pos /* read_sequence(type, end_char) */ + type = arg(1) + end_char = arg(2) + pos = pos + 1 /* Consume the open paren */ + token = tokens.pos + seq = "" + do while (pos <= tokens.0) & (token \== end_char) + element = read_form() + if element == "ERR" then return "ERR" + if seq == "" then + seq = element + else + seq = seq || " " || element + token = tokens.pos + end + pos = pos + 1 /* Consume the close paren */ + return new_seq(type, seq) + +reader_macro: procedure expose values. tokens. pos /* reader_macro(symbol) */ + symbol = arg(1) + pos = pos + 1 /* Consume the macro token */ + element = read_form() + if element == "ERR" then return "ERR" + seq = new_symbol(symbol) || " " || element + return new_list(seq) + +reader_with_meta_macro: procedure expose values. tokens. pos /* reader_with_meta_macro() */ + pos = pos + 1 /* Consume the macro token */ + meta = read_form() + if meta == "ERR" then return "ERR" + element = read_form() + if element == "ERR" then return "ERR" + seq = new_symbol("with-meta") || " " || element || " " || meta + return new_list(seq) + +read_form: procedure expose values. tokens. pos err /* read_form() */ + token = tokens.pos + select + when token == "'" then return reader_macro("quote") + when token == '`' then return reader_macro("quasiquote") + when token == '~' then return reader_macro("unquote") + when token == '~@' then return reader_macro("splice-unquote") + when token == '@' then return reader_macro("deref") + when token == '^' then return reader_with_meta_macro() + when token == '(' then return read_sequence("list", ")") + when token == ')' then do + err = "unexpected ')'" + return "ERR" + end + when token == '[' then return read_sequence("vect", "]") + when token == ']' then do + err = "unexpected ']'" + return "ERR" + end + when token == '{' then return read_sequence("hash", "}") + when token == '}' then do + err = "unexpected '}'" + return "ERR" + end + otherwise + return read_atom() + end + +read_str: procedure expose values. err /* read_str(line) */ + line = arg(1) + tokens. = "" + num_of_tokens = tokenize(line) + if num_of_tokens == 0 then + return "" + ast. = "" + pos = 1 + return read_form() + +#endif diff --git a/rexx/readline.rexx b/rexx/readline.rexx new file mode 100644 index 0000000000..4482bd7e5b --- /dev/null +++ b/rexx/readline.rexx @@ -0,0 +1,8 @@ +#ifndef __readline__ +#define __readline__ + +readline: procedure /* readline(prompt) */ + call charout , arg(1) + return linein() + +#endif diff --git a/rexx/run b/rexx/run new file mode 100755 index 0000000000..f792d597f3 --- /dev/null +++ b/rexx/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec rexx -a $(dirname $0)/${STEP:-stepA_mal}.rexxpp "${@}" diff --git a/rexx/step0_repl.rexx b/rexx/step0_repl.rexx new file mode 100644 index 0000000000..7ae0168c1c --- /dev/null +++ b/rexx/step0_repl.rexx @@ -0,0 +1,23 @@ +call main +exit + +#include "readline.rexx" + +read: procedure /* read(str) */ + return arg(1) + +eval: procedure /* eval(exp, env) */ + return arg(1) + +print: procedure /* print(exp) */ + return arg(1) + +rep: procedure /* rep(str) */ + return print(eval(read(arg(1), ""))) + +main: + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then + call lineout , rep(input_line) + end diff --git a/rexx/step1_read_print.rexx b/rexx/step1_read_print.rexx new file mode 100644 index 0000000000..eb697ff075 --- /dev/null +++ b/rexx/step1_read_print.rexx @@ -0,0 +1,32 @@ +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" + +read: procedure expose values. /* read(str) */ + return read_str(arg(1)) + +eval: procedure expose values. /* eval(exp, env) */ + return arg(1) + +print: procedure expose values. /* print(exp) */ + return pr_str(arg(1), 1) + +rep: procedure expose values. /* rep(str) */ + return print(eval(read(arg(1), ""))) + +main: + values. = "" + values.0 = 0 + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step2_eval.rexx b/rexx/step2_eval.rexx new file mode 100644 index 0000000000..6fffd80acd --- /dev/null +++ b/rexx/step2_eval.rexx @@ -0,0 +1,127 @@ +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast) */ + ast = arg(1) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then do + varname = val + if env.varname == "" then do + err = "'" || varname || "' not found" + return "ERR" + end + return env.varname + end + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i)) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i)) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i)) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + if \list?(ast) then return eval_ast(ast) + astval = obj_val(ast) + if words(astval) == 0 then return ast + lst_obj = eval_ast(ast) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || f || "(" || call_list || ")" + return res + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +rep: procedure expose values. env. err /* rep(str) */ + ast = read(arg(1)) + if ast == "ERR" then return "ERR" + exp = eval(ast) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_add: procedure expose values. /* mal_add(a, b) */ + return new_number(obj_val(arg(1)) + obj_val(arg(2))) + +mal_sub: procedure expose values. /* mal_sub(a, b) */ + return new_number(obj_val(arg(1)) - obj_val(arg(2))) + +mal_mul: procedure expose values. /* mal_mul(a, b) */ + return new_number(obj_val(arg(1)) * obj_val(arg(2))) + +mal_div: procedure expose values. /* mal_div(a, b) */ + return new_number(obj_val(arg(1)) / obj_val(arg(2))) + +main: + values. = "" + values.0 = 0 + env. = "" + key = "+" ; env.key = "mal_add" + key = "-" ; env.key = "mal_sub" + key = "*" ; env.key = "mal_mul" + key = "/" ; env.key = "mal_div" + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step3_env.rexx b/rexx/step3_env.rexx new file mode 100644 index 0000000000..839e2fe68c --- /dev/null +++ b/rexx/step3_env.rexx @@ -0,0 +1,151 @@ +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + return eval(word(astval, 3), letenv_idx) + end + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || f || "(" || call_list || ")" + return res + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_add: procedure expose values. /* mal_add(a, b) */ + return new_number(obj_val(arg(1)) + obj_val(arg(2))) + +mal_sub: procedure expose values. /* mal_sub(a, b) */ + return new_number(obj_val(arg(1)) - obj_val(arg(2))) + +mal_mul: procedure expose values. /* mal_mul(a, b) */ + return new_number(obj_val(arg(1)) * obj_val(arg(2))) + +mal_div: procedure expose values. /* mal_div(a, b) */ + return new_number(obj_val(arg(1)) / obj_val(arg(2))) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + x = env_set(repl_env_idx, "+", "mal_add") + x = env_set(repl_env_idx, "-", "mal_sub") + x = env_set(repl_env_idx, "*", "mal_mul") + x = env_set(repl_env_idx, "/", "mal_div") + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step4_if_fn_do.rexx b/rexx/step4_if_fn_do.rexx new file mode 100644 index 0000000000..564fbed84e --- /dev/null +++ b/rexx/step4_if_fn_do.rexx @@ -0,0 +1,176 @@ +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + return eval(word(astval, 3), letenv_idx) + end + when a0sym == "do" then do + res = "ERR" + do i=2 to words(astval) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + return res + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + return eval(word(astval, 4), env_idx) + else + return new_nil() + else + return eval(word(astval, 3), env_idx) + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + return eval(func_body_ast(f), new_env(func_env_idx(f), func_binds(f), call_args)) + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step5_tco.rexx b/rexx/step5_tco.rexx new file mode 100644 index 0000000000..6799b761ed --- /dev/null +++ b/rexx/step5_tco.rexx @@ -0,0 +1,183 @@ +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + + /* core.mal: defined using the language itself */ + x = rep("(def! not (fn* (a) (if a false true)))") + + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step6_file.rexx b/rexx/step6_file.rexx new file mode 100644 index 0000000000..fa1223177c --- /dev/null +++ b/rexx/step6_file.rexx @@ -0,0 +1,214 @@ +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))') + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step7_quote.rexx b/rexx/step7_quote.rexx new file mode 100644 index 0000000000..648317c52d --- /dev/null +++ b/rexx/step7_quote.rexx @@ -0,0 +1,234 @@ +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +pair?: procedure expose values. /* pair?(ast) */ + ast = arg(1) + return sequential?(ast) & words(obj_val(ast)) > 0 + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + if \pair?(ast) then return new_list(new_symbol("quote") || " " || ast) + ast0 = word(obj_val(ast), 1) + if symbol?(ast0) & obj_val(ast0) == "unquote" then return word(obj_val(ast), 2) + ast00 = word(obj_val(ast0), 1) + if pair?(ast0) & symbol?(ast00) & obj_val(ast00) == "splice-unquote" then + return new_list(new_symbol("concat") || " " || word(obj_val(ast0), 2) || " " || quasiquote(mal_rest(ast))) + else + return new_list(new_symbol("cons") || " " || quasiquote(ast0) || " " || quasiquote(mal_rest(ast))) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))') + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step8_macros.rexx b/rexx/step8_macros.rexx new file mode 100644 index 0000000000..7430a0b0e7 --- /dev/null +++ b/rexx/step8_macros.rexx @@ -0,0 +1,265 @@ +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +pair?: procedure expose values. /* pair?(ast) */ + ast = arg(1) + return sequential?(ast) & words(obj_val(ast)) > 0 + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + if \pair?(ast) then return new_list(new_symbol("quote") || " " || ast) + ast0 = word(obj_val(ast), 1) + if symbol?(ast0) & obj_val(ast0) == "unquote" then return word(obj_val(ast), 2) + ast00 = word(obj_val(ast0), 1) + if pair?(ast0) & symbol?(ast00) & obj_val(ast00) == "splice-unquote" then + return new_list(new_symbol("concat") || " " || word(obj_val(ast0), 2) || " " || quasiquote(mal_rest(ast))) + else + return new_list(new_symbol("cons") || " " || quasiquote(ast0) || " " || quasiquote(mal_rest(ast))) + +macro?: procedure expose values. env. /* macro?(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return 0 + ast0 = mal_first(ast) + if \symbol?(ast0) then return 0 + if env_find(env_idx, obj_val(ast0)) == 0 then return 0 + return func_macro?(env_get(env_idx, obj_val(ast0))) + +macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + do while macro?(ast, env_idx) + mac = env_get(env_idx, obj_val(mal_first(ast))) + call_args = mal_rest(ast) + mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) + ast = eval(func_body_ast(mac), mac_env_idx) + end + return ast + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + ast = macroexpand(ast, env_idx) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "defmacro!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, func_mark_as_macro(a2)) + end + when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))') + x = re("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw " || '"' || "odd number of forms to cond" || '"' || ")) (cons 'cond (rest (rest xs)))))))"); + x = re("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"); + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/rexx/step9_try.rexx b/rexx/step9_try.rexx new file mode 100644 index 0000000000..36a1cc3c10 --- /dev/null +++ b/rexx/step9_try.rexx @@ -0,0 +1,286 @@ +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +pair?: procedure expose values. /* pair?(ast) */ + ast = arg(1) + return sequential?(ast) & words(obj_val(ast)) > 0 + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + if \pair?(ast) then return new_list(new_symbol("quote") || " " || ast) + ast0 = word(obj_val(ast), 1) + if symbol?(ast0) & obj_val(ast0) == "unquote" then return word(obj_val(ast), 2) + ast00 = word(obj_val(ast0), 1) + if pair?(ast0) & symbol?(ast00) & obj_val(ast00) == "splice-unquote" then + return new_list(new_symbol("concat") || " " || word(obj_val(ast0), 2) || " " || quasiquote(mal_rest(ast))) + else + return new_list(new_symbol("cons") || " " || quasiquote(ast0) || " " || quasiquote(mal_rest(ast))) + +macro?: procedure expose values. env. /* macro?(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return 0 + ast0 = mal_first(ast) + if \symbol?(ast0) then return 0 + if env_find(env_idx, obj_val(ast0)) == 0 then return 0 + return func_macro?(env_get(env_idx, obj_val(ast0))) + +macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + do while macro?(ast, env_idx) + mac = env_get(env_idx, obj_val(mal_first(ast))) + call_args = mal_rest(ast) + mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) + ast = eval(func_body_ast(mac), mac_env_idx) + end + return ast + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + ast = macroexpand(ast, env_idx) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "defmacro!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, func_mark_as_macro(a2)) + end + when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) + when a0sym == "try*" then do + res = eval(word(astval, 2), env_idx) + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errobj = word(err, 2) + else + errobj = new_string(err) + catchlst = obj_val(word(astval, 3)) + catch_env_idx = new_env(env_idx, new_list(word(catchlst, 2)), new_list(errobj)) + err = "" + return eval(word(catchlst, 3), catch_env_idx) + end + else + return res + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))') + x = re("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw " || '"' || "odd number of forms to cond" || '"' || ")) (cons 'cond (rest (rest xs)))))))"); + x = re("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"); + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errstr = pr_str(word(err, 2), 0) + else + errstr = err + call lineout , "Error: " || errstr + err = "" + end + else + call lineout , res + end + end diff --git a/rexx/stepA_mal.rexx b/rexx/stepA_mal.rexx new file mode 100644 index 0000000000..fb01015d8f --- /dev/null +++ b/rexx/stepA_mal.rexx @@ -0,0 +1,291 @@ +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +pair?: procedure expose values. /* pair?(ast) */ + ast = arg(1) + return sequential?(ast) & words(obj_val(ast)) > 0 + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + if \pair?(ast) then return new_list(new_symbol("quote") || " " || ast) + ast0 = word(obj_val(ast), 1) + if symbol?(ast0) & obj_val(ast0) == "unquote" then return word(obj_val(ast), 2) + ast00 = word(obj_val(ast0), 1) + if pair?(ast0) & symbol?(ast00) & obj_val(ast00) == "splice-unquote" then + return new_list(new_symbol("concat") || " " || word(obj_val(ast0), 2) || " " || quasiquote(mal_rest(ast))) + else + return new_list(new_symbol("cons") || " " || quasiquote(ast0) || " " || quasiquote(mal_rest(ast))) + +macro?: procedure expose values. env. /* macro?(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return 0 + ast0 = mal_first(ast) + if \symbol?(ast0) then return 0 + if env_find(env_idx, obj_val(ast0)) == 0 then return 0 + return func_macro?(env_get(env_idx, obj_val(ast0))) + +macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + do while macro?(ast, env_idx) + mac = env_get(env_idx, obj_val(mal_first(ast))) + call_args = mal_rest(ast) + mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) + ast = eval(func_body_ast(mac), mac_env_idx) + end + return ast + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + ast = macroexpand(ast, env_idx) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "defmacro!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, func_mark_as_macro(a2)) + end + when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) + when a0sym == "try*" then do + res = eval(word(astval, 2), env_idx) + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errobj = word(err, 2) + else + errobj = new_string(err) + catchlst = obj_val(word(astval, 3)) + catch_env_idx = new_env(env_idx, new_list(word(catchlst, 2)), new_list(errobj)) + err = "" + return eval(word(catchlst, 3), catch_env_idx) + end + else + return res + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + x = time('R') /* Reset the internal stopwatch; used by `time-ms` */ + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re('(def! *host-language* "rexx")') + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))') + x = re("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw " || '"' || "odd number of forms to cond" || '"' || ")) (cons 'cond (rest (rest xs)))))))"); + x = re("(def! *gensym-counter* (atom 0))") + x = re('(def! gensym (fn* [] (symbol (str "G__" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))') + x = re("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))") + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + x = re('(println (str "Mal [" *host-language* "]"))') + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errstr = pr_str(word(err, 2), 0) + else + errstr = err + call lineout , "Error: " || errstr + err = "" + end + else + call lineout , res + end + end diff --git a/rexx/tests/step5_tco.mal b/rexx/tests/step5_tco.mal new file mode 100644 index 0000000000..51604d627e --- /dev/null +++ b/rexx/tests/step5_tco.mal @@ -0,0 +1,2 @@ +;; REXX: skipping non-TCO recursion +;; Reason: regina rexx interpreter segfaults (unrecoverable) diff --git a/rexx/tests/stepA_mal.mal b/rexx/tests/stepA_mal.mal new file mode 100644 index 0000000000..cc05df486b --- /dev/null +++ b/rexx/tests/stepA_mal.mal @@ -0,0 +1,23 @@ +;; Testing basic Rexx interop +;; +;; Note that in Rexx "everything is a string". Numeric outputs are converted to +;; Mal numbers. + +(rexx-eval "3 ** 4") +;=>81 + +(rexx-eval "words('a bb ' || 'ccc dddd')") +;=>4 + +(rexx-eval "d2x(254)") +;=>"FE" + +(rexx-eval "say 'hello' 12.34 upper('rexx')" nil) +; hello 12.34 REXX +;=>nil + +(rexx-eval "foo = 8" "foo + 3") +;=>11 + +(rexx-eval "parse version s1 s2 s3 s4 s5" "'rexx_version=' || s2") +;=>"rexx_version=5.00" diff --git a/rexx/types.rexx b/rexx/types.rexx new file mode 100644 index 0000000000..c9b1ad3e9a --- /dev/null +++ b/rexx/types.rexx @@ -0,0 +1,248 @@ +#ifndef __types__ +#define __types__ + +values. = "" +values.0 = 0 + +new_value_index: procedure expose values. /* new_value_index() */ + values.0 = values.0 + 1 + return values.0 + +obj_type: procedure /* obj_type(obj) */ + obj = arg(1) + return left(obj, 4) + +obj_val: procedure expose values. /* obj_val(obj) */ + obj = arg(1) + type = obj_type(obj) + val = substr(obj, 6) + select + when type == "numb" | type == "nill" | type == "true" | type == "fals" then return val + otherwise + return values.val + end + +obj_meta: procedure expose values. /* obj_meta(obj) */ + obj = arg(1) + type = obj_type(obj) + if type == "numb" | type == "nill" | type == "true" | type == "fals" then return "" + ind = substr(obj, 6) + return values.meta.ind + +obj_clone_and_set_meta: procedure expose values. /* obj_clone_and_set_meta(obj, new_meta) */ + obj = arg(1) + new_meta = arg(2) + type = obj_type(obj) + if type == "numb" | type == "nill" | type == "true" | type == "fals" then return "" + orig_ind = substr(obj, 6) + new_idx = new_value_index() + values.new_idx = values.orig_ind + values.meta.new_idx = new_meta + return type || "_" || new_idx + +new_number: procedure /* new_number(n) */ + n = arg(1) + return "numb_" || n + +new_nil: procedure /* new_nil() */ + return "nill_0" + +nil?: procedure /* nil?(obj) */ + return obj_type(arg(1)) == "nill" + +new_true: procedure /* new_true() */ + return "true_0" + +true?: procedure /* true?(obj) */ + return obj_type(arg(1)) == "true" + +new_false: procedure /* new_false() */ + return "fals_0" + +false?: procedure /* false?(obj) */ + return obj_type(arg(1)) == "fals" + +new_boolean: procedure /* new_boolean(cond) */ + if arg(1) then + return new_true() + else + return new_false() + +new_symbol: procedure expose values. /* new_symbol(str) */ + str = arg(1) + idx = new_value_index() + values.idx = str + return "symb_" || idx + +symbol?: procedure /* symbol?(obj) */ + return obj_type(arg(1)) == "symb" + +new_string: procedure expose values. /* new_string(str) */ + str = arg(1) + idx = new_value_index() + values.idx = str + return "stri_" || idx + +string?: procedure /* string?(obj) */ + return obj_type(arg(1)) == "stri" + +new_keyword: procedure expose values. /* new_keyword(str) */ + str = arg(1) + idx = new_value_index() + values.idx = str + return "keyw_" || idx + +keyword?: procedure /* keyword?(obj) */ + return obj_type(arg(1)) == "keyw" + +new_seq: procedure expose values. /* new_seq(type, seq) */ + type = arg(1) + seq = arg(2) + idx = new_value_index() + values.idx = seq + return type || "_" || idx + +new_list: procedure expose values. /* new_list(seq) */ + seq = arg(1) + return new_seq("list", seq) + +list?: procedure /* list?(obj) */ + return obj_type(arg(1)) == "list" + +new_vector: procedure expose values. /* new_vector(seq) */ + seq = arg(1) + return new_seq("vect", seq) + +vector?: procedure /* vector?(obj) */ + return obj_type(arg(1)) == "vect" + +sequential?: procedure /* sequential?(obj) */ + return (list?(arg(1)) | vector?(arg(1))) + +count_elements: procedure expose values. /* count_elements(lst) */ + return words(obj_val(arg(1))) + +new_hashmap: procedure expose values. /* new_hashmap(seq) */ + seq = arg(1) + return new_seq("hash", seq) + +hashmap?: procedure /* hashmap?(obj) */ + return obj_type(arg(1)) == "hash" + +contains?: procedure expose values. /* contains?(hm_val, key) */ + hm_val = arg(1) + key = arg(2) + do i=1 to words(hm_val) by 2 + if equal?(key, word(hm_val, i)) then return 1 + end + return 0 + +hashmap_get: procedure expose values. /* hashmap_get(hm_val, key) */ + hm_val = arg(1) + key = arg(2) + do i=1 to words(hm_val) by 2 + if equal?(key, word(hm_val, i)) then return word(hm_val, i + 1) + end + return "" + +new_nativefn: procedure expose values. /* new_hashmap(native_func_name) */ + native_func_name = arg(1) + idx = new_value_index() + values.idx = native_func_name + return "nafn_" || idx + +nativefn?: procedure /* nativefn?(obj) */ + return obj_type(arg(1)) == "nafn" + +new_func: procedure expose values. /* new_func(body_ast, env_idx, binds) */ + body_ast = arg(1) + env_idx = arg(2) + binds = arg(3) + is_macro = 0 + idx = new_value_index() + values.idx = body_ast env_idx binds is_macro + return "func_" || idx + +func?: procedure /* func?(obj) */ + return obj_type(arg(1)) == "func" + +func_macro?: procedure expose values. /* func_macro?(obj) */ + return func?(arg(1)) & (func_is_macro(arg(1)) == 1) + +func_body_ast: procedure expose values. /* func_body_ast(func_obj) */ + return word(obj_val(arg(1)), 1) + +func_env_idx: procedure expose values. /* func_env_idx(func_obj) */ + return word(obj_val(arg(1)), 2) + +func_binds: procedure expose values. /* func_binds(func_obj) */ + return word(obj_val(arg(1)), 3) + +func_is_macro: procedure expose values. /* func_is_macro(func_obj) */ + return word(obj_val(arg(1)), 4) + +func_mark_as_macro: procedure expose values. /* func_mark_as_macro(func_obj) */ + idx = substr(arg(1), 6) + values.idx = subword(values.idx, 1, 3) 1 + return arg(1) + +new_atom: procedure expose values. /* new_atom(obj) */ + obj = arg(1) + idx = new_value_index() + values.idx = obj + return "atom_" || idx + +atom?: procedure /* atom?(obj) */ + return obj_type(arg(1)) == "atom" + +atom_set: procedure expose values. /* atom_set(atom, new_value) */ + atom = arg(1) + new_value = arg(2) + idx = substr(atom, 6) + values.idx = new_value + return new_value + +equal_hashmap?: procedure expose values. /* equal_hashmap?(a, b) */ + hma_val = obj_val(arg(1)) + hmb_val = obj_val(arg(2)) + if words(hma_val) \= words(hmb_val) then return 0 + do i=1 to words(hma_val) by 2 + a_key = word(hma_val, i) + a_val = word(hma_val, i + 1) + b_val = hashmap_get(hmb_val, a_key) + if b_val == "" then return 0 + if \equal?(a_val, b_val) then return 0 + end + return 1 + +equal_sequential?: procedure expose values. /* equal_sequential?(a, b) */ + a_val = obj_val(arg(1)) + b_val = obj_val(arg(2)) + if words(a_val) \= words(b_val) then return 0 + do i=1 to words(a_val) + if \equal?(word(a_val, i), word(b_val, i)) then return 0 + end + return 1 + +equal?: procedure expose values. /* equal?(a, b) */ + a = arg(1) + b = arg(2) + a_type = obj_type(a) + b_type = obj_type(b) + a_val = obj_val(a) + b_val = obj_val(b) + select + when nil?(a) then return nil?(b) + when true?(a) then return true?(b) + when false?(a) then return false?(b) + when (a_type == "numb" & b_type = "numb") | , + (a_type == "symb" & b_type = "symb") | , + (a_type == "stri" & b_type = "stri") | , + (a_type == "keyw" & b_type = "keyw") then return (obj_val(a) == obj_val(b)) + when (sequential?(a) & sequential?(b)) then return equal_sequential?(a, b) + when (hashmap?(a) & hashmap?(b)) then return equal_hashmap?(a, b) + otherwise + return 0 + end + +#endif From 44a3e2ef704458c407c446b90aef345de13f9cc0 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 20 Jul 2017 12:07:01 +0000 Subject: [PATCH 0070/1998] rexx: Add Rexx to main README --- README.md | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index dfcb2004de..baac56710e 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 66 languages: +Mal is implemented in 67 languages: * Ada * GNU awk @@ -63,6 +63,7 @@ Mal is implemented in 66 languages: * RPython * R * Racket +* Rexx * Ruby * Rust * Scala @@ -808,6 +809,18 @@ cd racket ./stepX_YYY.rkt ``` +### Rexx + +*The Rexx implementation was created by [Dov Murik](https://github.com/dubek)* + +The Rexx implementation of mal has been tested with Regina Rexx 3.6. + +``` +cd rexx +make +rexx -a ./stepX_YYY.rexxpp +``` + ### Ruby (1.9+) ``` From a66c64008abcb0156d821da34ebd68719cf8f039 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 20 Jul 2017 12:07:45 +0000 Subject: [PATCH 0071/1998] rexx: Add `rexx` to Travis CI matrix --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 3a53dd5b6b..f482183a95 100644 --- a/.travis.yml +++ b/.travis.yml @@ -60,6 +60,7 @@ matrix: - {env: IMPL=python, services: [docker]} - {env: IMPL=r, services: [docker]} - {env: IMPL=racket, services: [docker]} + - {env: IMPL=rexx, services: [docker]} - {env: IMPL=rpython, services: [docker]} - {env: IMPL=ruby, services: [docker]} - {env: IMPL=rust, services: [docker]} From 999efc9f4ba2f360c674b9fba535d236b6525708 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Thu, 20 Jul 2017 17:37:08 +0200 Subject: [PATCH 0072/1998] Fix init warning I mistakenly assumed that the way to retrieve the current context is by calling a documented static method. Apparently thisContext is the missing sixth keyword in Smalltalk, so that's not needed. --- gst/step0_repl.st | 2 +- gst/step1_read_print.st | 2 +- gst/step2_eval.st | 2 +- gst/step3_env.st | 2 +- gst/step4_if_fn_do.st | 2 +- gst/step5_tco.st | 2 +- gst/step6_file.st | 2 +- gst/step7_quote.st | 2 +- gst/step8_macros.st | 2 +- gst/step9_try.st | 2 +- gst/stepA_mal.st | 2 +- 11 files changed, 11 insertions(+), 11 deletions(-) diff --git a/gst/step0_repl.st b/gst/step0_repl.st index 622347dfc7..5549a89fcd 100644 --- a/gst/step0_repl.st +++ b/gst/step0_repl.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step1_read_print.st b/gst/step1_read_print.st index 4957a4ef48..53384b4c05 100644 --- a/gst/step1_read_print.st +++ b/gst/step1_read_print.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step2_eval.st b/gst/step2_eval.st index 030dbcb6d8..7682ccd9db 100644 --- a/gst/step2_eval.st +++ b/gst/step2_eval.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step3_env.st b/gst/step3_env.st index baf0289293..9c51b7b238 100644 --- a/gst/step3_env.st +++ b/gst/step3_env.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step4_if_fn_do.st b/gst/step4_if_fn_do.st index a61e0b21c1..b3cc590d42 100644 --- a/gst/step4_if_fn_do.st +++ b/gst/step4_if_fn_do.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step5_tco.st b/gst/step5_tco.st index d0289b8cef..43c7381ca3 100644 --- a/gst/step5_tco.st +++ b/gst/step5_tco.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step6_file.st b/gst/step6_file.st index 93b475ee57..9e79435f5e 100644 --- a/gst/step6_file.st +++ b/gst/step6_file.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step7_quote.st b/gst/step7_quote.st index 7d6c70095a..bdb8d88b59 100644 --- a/gst/step7_quote.st +++ b/gst/step7_quote.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step8_macros.st b/gst/step8_macros.st index d51ea1c048..602e44415d 100644 --- a/gst/step8_macros.st +++ b/gst/step8_macros.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/step9_try.st b/gst/step9_try.st index ae1db7fd5d..08bb9768de 100644 --- a/gst/step9_try.st +++ b/gst/step9_try.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] diff --git a/gst/stepA_mal.st b/gst/stepA_mal.st index 29f15d2efc..dea76c217c 100644 --- a/gst/stepA_mal.st +++ b/gst/stepA_mal.st @@ -1,7 +1,7 @@ String extend [ String >> loadRelative [ | scriptPath scriptDirectory | - scriptPath := ContextPart thisContext currentFileName. + scriptPath := thisContext currentFileName. scriptDirectory := FilePath stripFileNameFor: scriptPath. FileStream fileIn: (FilePath append: self to: scriptDirectory) ] From 4c77d21607778fb6680549430c4d3750e353a679 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 20 Jul 2017 20:12:14 +0000 Subject: [PATCH 0073/1998] bash: Fix `string?` result on keyword arguments Fixed wrong `string?` value on keyword arguments in bash implementation (2 soft test fails). Before the fix: ``` TEST: (string? :abc) -> ['',false] -> SOFT FAIL (line 115): Expected : '(string? :abc)\r\nfalse' Got : '(string? :abc)\r\ntrue' TEST: (string? (keyword "abc")) -> ['',false] -> SOFT FAIL (line 117): Expected : '(string? (keyword "abc"))\r\nfalse' Got : '(string? (keyword "abc"))\r\ntrue' ``` With the fix: ``` TEST: (string? :abc) -> ['',false] -> SUCCESS TEST: (string? (keyword "abc")) -> ['',false] -> SUCCESS ``` --- bash/core.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bash/core.sh b/bash/core.sh index 0a4d07c97a..99cc98c8ff 100644 --- a/bash/core.sh +++ b/bash/core.sh @@ -74,7 +74,7 @@ time_ms () { # String functions -string? () { _string? "${1}" && r="${__true}" || r="${__false}"; } +string? () { _string? "${1}" && ( ! _keyword? "${1}" ) && r="${__true}" || r="${__false}"; } pr_str () { local res="" From 50ed0aa9a14318b551e547a24ddaf4c5efd9e8ad Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 22 Jul 2017 21:44:25 +0200 Subject: [PATCH 0074/1998] Elm step A: GC working --- elm/Env.elm | 38 +++++--------------------------------- elm/Eval.elm | 28 +++++++++++++++++++++++++++- elm/Types.elm | 1 + elm/stepA_mal.elm | 7 +------ 4 files changed, 34 insertions(+), 40 deletions(-) diff --git a/elm/Env.elm b/elm/Env.elm index ae64056437..7aaff29da8 100644 --- a/elm/Env.elm +++ b/elm/Env.elm @@ -11,7 +11,6 @@ module Env , push , pop , enter - , jump , leave , ref , pushRef @@ -54,6 +53,7 @@ global = , gcInterval = defaultGcInterval , gcCounter = 0 , stack = [] + , keepFrames = [] } @@ -220,29 +220,6 @@ enter outerId binds env = } -{-| Jump into a frame --} -jump : Int -> Env -> Env -jump frameId env = - let - setExitId = - Maybe.map - (\frame -> - { frame - | exitId = Just env.currentFrameId - , refCnt = frame.refCnt + 1 - } - ) - - bogus = - debug env "jump #" frameId - in - { env - | currentFrameId = frameId - , frames = Dict.update frameId setExitId env.frames - } - - leave : Env -> Env leave env = let @@ -332,8 +309,6 @@ Return a new Env with the unreachable frames removed. gc : MalExpr -> Env -> Env gc expr env = let - -- bogus = - -- Debug.log "GC stack = " env.stack countList acc = List.foldl countExpr acc @@ -387,7 +362,10 @@ gc expr env = acc initSet = - Set.fromList [ globalFrameId, env.currentFrameId ] + Set.fromList + ([ globalFrameId, env.currentFrameId ] + ++ env.keepFrames + ) countFrames frames acc = Set.toList frames @@ -437,16 +415,10 @@ gc expr env = filterFrames frames keep = Dict.filter (keepFilter keep) frames - - reportUnused frames keep = - Set.diff (Set.fromList (Dict.keys frames)) keep - |> Debug.log "\n\nUNUSED FRAMES\n\n" - |> always keep in countFrames initSet initSet |> countExpr expr |> (flip countList) env.stack |> loop - -- |> reportUnused env.frames |> filterFrames env.frames |> makeNewEnv diff --git a/elm/Eval.elm b/elm/Eval.elm index 1d37df3eb6..b32946e661 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -3,7 +3,6 @@ module Eval exposing (..) import Types exposing (..) import IO exposing (IO) import Env -import Printer exposing (printEnv) apply : Eval a -> Env -> EvalContext a @@ -197,3 +196,30 @@ pushRef : MalExpr -> Eval a -> Eval a pushRef ref e = modifyEnv (Env.pushRef ref) |> andThen (always e) + + +inGlobal : Eval a -> Eval a +inGlobal body = + let + enter env = + setEnv + { env + | keepFrames = env.currentFrameId :: env.keepFrames + , currentFrameId = Env.globalFrameId + } + + leave oldEnv newEnv = + { newEnv + | keepFrames = oldEnv.keepFrames + , currentFrameId = oldEnv.currentFrameId + } + in + withEnv + (\env -> + if env.currentFrameId /= Env.globalFrameId then + enter env + |> andThen (always body) + |> finally (leave env) + else + body + ) diff --git a/elm/Types.elm b/elm/Types.elm index 1cdcb110cc..9960c55362 100644 --- a/elm/Types.elm +++ b/elm/Types.elm @@ -32,6 +32,7 @@ type alias Env = , gcInterval : Int , gcCounter : Int , stack : List MalExpr + , keepFrames : List Int } diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm index 478b7c0c40..71bdac5613 100644 --- a/elm/stepA_mal.elm +++ b/elm/stepA_mal.elm @@ -273,12 +273,7 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.jump Env.globalFrameId) - |> Eval.andThen (\_ -> eval expr) - |> Eval.finally Env.leave - ) + Eval.inGlobal (eval expr) _ -> Eval.fail "unsupported arguments" From b346116e53af3138bb890c6564099be3598806eb Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 22 Jul 2017 21:59:59 +0200 Subject: [PATCH 0075/1998] Elm: re-enabled steps 1-9 --- elm/Makefile | 17 ++++++++++------- elm/step4_if_fn_do.elm | 4 ++-- elm/step5_tco.elm | 4 ++-- elm/step6_file.elm | 11 +++-------- elm/step7_quote.elm | 11 +++-------- elm/step8_macros.elm | 13 ++++--------- elm/step9_try.elm | 13 ++++--------- 7 files changed, 28 insertions(+), 45 deletions(-) diff --git a/elm/Makefile b/elm/Makefile index e7ad0989a0..99fcffddf6 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -1,7 +1,10 @@ -SOURCES = stepA_mal.elm #step0_repl.elm step1_read_print.elm step2_eval.elm \ +SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ step3_env.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm \ step7_quote.elm step8_macros.elm step9_try.elm stepA_mal.elm +SOURCES_LISP = Env.elm Core.elm Eval.elm stepA_mal.elm + + BINS = $(SOURCES:%.elm=%.js) ELM = node_modules/.bin/elm @@ -38,10 +41,10 @@ stepA_mal.js: $(STEP4_SOURCES) clean: rm -f $(BINS) -# stats: $(SOURCES) -# @wc $^ -# @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" +stats: $(STEP4_SOURCES) stepA_mal.elm + @wc $^ + @printf "%5s %5s %5s %s\n" `egrep "^\w*(--|\{-|-\})|^\w*$$" $^ | wc` "[comments/blanks]" -# stats-lisp: $(SOURCES_LISP) -# @wc $^ -# @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `egrep "^\w*(--|\{-|-\})|^\w*$$" $^ | wc` "[comments/blanks]" diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index c769ffaaae..113e2253c7 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -187,7 +187,7 @@ eval ast = fn args (MalFunction (UserFunc { eagerFn })) :: args -> - eagerFn [] args + eagerFn args fn :: _ -> Eval.withEnv @@ -437,7 +437,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = fn - , eagerFn = always fn + , eagerFn = fn , isMacro = False , meta = Nothing } diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index 96a87b46cc..c460102c03 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -189,7 +189,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally Env.leave - |> Eval.gcPass [] + |> Eval.gcPass ) @@ -475,7 +475,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = \_ -> lazyFn >> Eval.andThen eval + , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 87643819ce..670cdadaac 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -246,12 +246,7 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.jump Env.globalFrameId) - |> Eval.andThen (\_ -> eval expr) - |> Eval.finally Env.leave - ) + Eval.inGlobal (eval expr) _ -> Eval.fail "unsupported arguments" @@ -264,7 +259,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally Env.leave - |> Eval.gcPass [] + |> Eval.gcPass ) @@ -550,7 +545,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = \_ -> lazyFn >> Eval.andThen eval + , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 8a09aaa50e..1e396dce5b 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -246,12 +246,7 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.jump Env.globalFrameId) - |> Eval.andThen (\_ -> eval expr) - |> Eval.finally Env.leave - ) + Eval.inGlobal (eval expr) _ -> Eval.fail "unsupported arguments" @@ -264,7 +259,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally Env.leave - |> Eval.gcPass [] + |> Eval.gcPass ) @@ -549,7 +544,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = \_ -> lazyFn >> Eval.andThen eval + , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm index adf9caa2f0..c089a90f08 100644 --- a/elm/step8_macros.elm +++ b/elm/step8_macros.elm @@ -262,12 +262,7 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.jump Env.globalFrameId) - |> Eval.andThen (\_ -> eval expr) - |> Eval.finally Env.leave - ) + Eval.inGlobal (eval expr) _ -> Eval.fail "unsupported arguments" @@ -280,7 +275,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally Env.leave - |> Eval.gcPass [] + |> Eval.gcPass ) @@ -604,7 +599,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = \_ -> lazyFn >> Eval.andThen eval + , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } @@ -687,7 +682,7 @@ macroexpand expr = case Env.get name env of Ok (MalFunction (UserFunc fn)) -> if fn.isMacro then - Left <| fn.eagerFn [] args + Left <| fn.eagerFn args else Right expr diff --git a/elm/step9_try.elm b/elm/step9_try.elm index ba886aae6d..356584ec5f 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -262,12 +262,7 @@ malEval : List MalExpr -> Eval MalExpr malEval args = case args of [ expr ] -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.jump Env.globalFrameId) - |> Eval.andThen (\_ -> eval expr) - |> Eval.finally Env.leave - ) + Eval.inGlobal (eval expr) _ -> Eval.fail "unsupported arguments" @@ -280,7 +275,7 @@ evalApply { frameId, bound, body } = Eval.modifyEnv (Env.enter frameId bound) |> Eval.andThen (\_ -> evalNoApply body) |> Eval.finally Env.leave - |> Eval.gcPass [] + |> Eval.gcPass ) @@ -606,7 +601,7 @@ evalFn args = UserFunc { frameId = frameId , lazyFn = lazyFn - , eagerFn = \_ -> lazyFn >> Eval.andThen eval + , eagerFn = lazyFn >> Eval.andThen eval , isMacro = False , meta = Nothing } @@ -689,7 +684,7 @@ macroexpand expr = case Env.get name env of Ok (MalFunction (UserFunc fn)) -> if fn.isMacro then - Left <| fn.eagerFn [] args + Left <| fn.eagerFn args else Right expr From f38c7ffad12aea5b3c4b8bbccf7c0f4c14662721 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 22 Jul 2017 22:18:35 +0200 Subject: [PATCH 0076/1998] Elm: fix makefile, added to readme and enable travis --- .travis.yml | 1 + Makefile | 2 +- README.md | 13 +++++++++++++ elm/Makefile | 7 +++---- 4 files changed, 18 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 711212ab7d..c9aa9b5c68 100644 --- a/.travis.yml +++ b/.travis.yml @@ -21,6 +21,7 @@ matrix: - {env: IMPL=dart, services: [docker]} - {env: IMPL=elisp, services: [docker]} - {env: IMPL=elixir, services: [docker]} + - {env: IMPL=elm, services: [docker]} - {env: IMPL=erlang NO_PERF=1, services: [docker]} # perf runs out of memory - {env: IMPL=es6, services: [docker]} - {env: IMPL=factor, services: [docker]} diff --git a/Makefile b/Makefile index 7473c11cc0..cd6872971e 100644 --- a/Makefile +++ b/Makefile @@ -216,7 +216,7 @@ vhdl_STEP_TO_PROG = vhdl/$($(1)) vimscript_STEP_TO_PROG = vimscript/$($(1)).vim guile_STEP_TO_PROG = guile/$($(1)).scm livescript_STEP_TO_PROG = livescript/$($(1)).js -elm_STEP_TO_PROG = elm/$($(1)).elm +elm_STEP_TO_PROG = elm/$($(1)).js # Needed some argument munging diff --git a/README.md b/README.md index 97aa11167a..94e60a029d 100644 --- a/README.md +++ b/README.md @@ -23,6 +23,7 @@ Mal is implemented in 65 languages: * D * Dart * Elixir +* Elm * Emacs Lisp * Erlang * ES6 (ECMAScript 6 / ECMAScript 2015) @@ -345,6 +346,18 @@ mix stepX_YYY iex -S mix stepX_YYY ``` +### Elm + +*The Elm implementation was created by [Jos van Bakel](https://github.com/c0deaddict)* + +The Elm implementation of mal has been tested with Elm 0.18.0 + +``` +cd elm +make stepX_YYY.js +STEP=stepX_YYY ./run +``` + ### Erlang *The Erlang implementation was created by [Nathan Fiedler (nlfiedler)](https://github.com/nlfiedler)* diff --git a/elm/Makefile b/elm/Makefile index 99fcffddf6..b20685f406 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -4,20 +4,19 @@ SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ SOURCES_LISP = Env.elm Core.elm Eval.elm stepA_mal.elm - BINS = $(SOURCES:%.elm=%.js) ELM = node_modules/.bin/elm -all: node_modules $(BINS) +all: node_modules elm_packages $(BINS) node_modules: npm install elm_packages: - $(ELM) package install + $(ELM) package install -y -%.js: %.elm node_modules +%.js: %.elm node_modules elm_packages $(ELM) make $(@:%.js=%.elm) --output $@ STEP0_SOURCES = IO.elm From 1a9bc42c5a37049bd3de331bfb77882799cdf457 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Sat, 22 Jul 2017 22:21:45 +0200 Subject: [PATCH 0077/1998] Elm: revert change in core.mal --- mal/core.mal | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/mal/core.mal b/mal/core.mal index dbf7944c6d..a766b80125 100644 --- a/mal/core.mal +++ b/mal/core.mal @@ -60,6 +60,4 @@ ["atom?" atom?] ["deref" deref] ["reset!" reset!] - ["swap!" swap!] - ["gc" gc] - ["pr-env" pr-env]]) + ["swap!" swap!]]) From 9c47ff44dac16eec9a6d2dd15e9c4d13c89e97ba Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Tue, 25 Jul 2017 09:55:52 +0200 Subject: [PATCH 0078/1998] Elm: use direct paths in Makefile --- elm/Makefile | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/elm/Makefile b/elm/Makefile index b20685f406..1ad56ff655 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -6,7 +6,8 @@ SOURCES_LISP = Env.elm Core.elm Eval.elm stepA_mal.elm BINS = $(SOURCES:%.elm=%.js) -ELM = node_modules/.bin/elm +ELM_MAKE = node_modules/.bin/elm-make +ELM_PACKAGE = node_modules/.bin/elm-package all: node_modules elm_packages $(BINS) @@ -14,10 +15,10 @@ node_modules: npm install elm_packages: - $(ELM) package install -y + $(ELM_PACKAGE) install -y %.js: %.elm node_modules elm_packages - $(ELM) make $(@:%.js=%.elm) --output $@ + $(ELM_MAKE) $(@:%.js=%.elm) --output $@ STEP0_SOURCES = IO.elm STEP1_SOURCES = $(STEP0_SOURCES) Reader.elm Printer.elm Utils.elm Types.elm Env.elm From 224f4c78eab3d0a11e603ea9966fc9f0679039b8 Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Tue, 25 Jul 2017 16:42:53 +0200 Subject: [PATCH 0079/1998] Elm: fixed Dockerfile --- elm/.dockerignore | 1 + elm/Dockerfile | 7 +++++-- 2 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 elm/.dockerignore diff --git a/elm/.dockerignore b/elm/.dockerignore new file mode 100644 index 0000000000..3c3629e647 --- /dev/null +++ b/elm/.dockerignore @@ -0,0 +1 @@ +node_modules diff --git a/elm/Dockerfile b/elm/Dockerfile index fbb4b5572e..ef06b82a21 100644 --- a/elm/Dockerfile +++ b/elm/Dockerfile @@ -12,7 +12,7 @@ RUN apt-get -y update RUN apt-get -y install make python # Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev +RUN apt-get -y install curl libreadline-dev libedit-dev netbase RUN mkdir -p /mal WORKDIR /mal @@ -28,4 +28,7 @@ RUN apt-get -y install g++ RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - # Install nodejs -RUN apt-get -y install nodejs \ No newline at end of file +RUN apt-get -y install nodejs + +ENV HOME /mal +ENV NPM_CONFIG_CACHE /mal/.npm From 6351d14c6c84a72b8feccd24de6a90f64624e1c1 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 25 Jul 2017 11:12:46 -0500 Subject: [PATCH 0080/1998] elm: move more specific deps lower in the file. --- elm/Dockerfile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/elm/Dockerfile b/elm/Dockerfile index ef06b82a21..5b3bc3e271 100644 --- a/elm/Dockerfile +++ b/elm/Dockerfile @@ -12,7 +12,7 @@ RUN apt-get -y update RUN apt-get -y install make python # Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev netbase +RUN apt-get -y install curl libreadline-dev libedit-dev RUN mkdir -p /mal WORKDIR /mal @@ -21,8 +21,8 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -# For building node modules -RUN apt-get -y install g++ +# For building node modules and pulling elm packages +RUN apt-get -y install g++ netbase # Add nodesource apt repo config for 7.X RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - From 74771ea2a9a58e07f71c3213957fb60d27dc91c8 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 25 Jul 2017 11:13:13 -0500 Subject: [PATCH 0081/1998] plpgsql: support Travis run with alt. user Seems that Travis sometimes runs with a user other than 1001 so add user ID 2000 as well. --- plpgsql/Dockerfile | 4 +++- plpgsql/entrypoint.sh | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/plpgsql/Dockerfile b/plpgsql/Dockerfile index bde9fcdd23..eb64c1ae34 100644 --- a/plpgsql/Dockerfile +++ b/plpgsql/Dockerfile @@ -19,8 +19,9 @@ ENV HOME=/var/run/postgresql WORKDIR /mal -# Travis runs as user ID 1001 so add that user +# Travis runs as a couple of different users so add them RUN useradd -ou 1001 -m -s /bin/bash -G sudo,postgres travis +RUN useradd -ou 2000 -m -s /bin/bash -G sudo,postgres travis2 # Enable postgres and travis users to sudo for postgres startup RUN echo "%sudo ALL=(ALL:ALL) NOPASSWD: ALL" >> /etc/sudoers @@ -29,6 +30,7 @@ RUN echo "%sudo ALL=(ALL:ALL) NOPASSWD: ALL" >> /etc/sudoers RUN sed -i 's/peer$/peer map=mal/' /etc/postgresql/9.4/main/pg_hba.conf RUN echo "mal postgres postgres" >> /etc/postgresql/9.4/main/pg_ident.conf RUN echo "mal travis postgres" >> /etc/postgresql/9.4/main/pg_ident.conf +RUN echo "mal travis2 postgres" >> /etc/postgresql/9.4/main/pg_ident.conf # Add entrypoint.sh which starts postgres then run bash/command ADD entrypoint.sh /entrypoint.sh diff --git a/plpgsql/entrypoint.sh b/plpgsql/entrypoint.sh index 76b614af31..6eaf5164b7 100755 --- a/plpgsql/entrypoint.sh +++ b/plpgsql/entrypoint.sh @@ -9,9 +9,9 @@ while [[ ${1:0:1} = '-' ]]; do done sudo --user=${POSTGRES_SUDO_USER} \ - /usr/lib/postgresql/9.4/bin/postgres \ + bash -c "/usr/lib/postgresql/9.4/bin/postgres \ -c config_file=/etc/postgresql/9.4/main/postgresql.conf \ - ${POPTS} >/var/log/postgresql/output.log 2>&1 & disown -h + ${POPTS} >/var/log/postgresql/output.log 2>&1" & disown -h while ! ( echo "" > /dev/tcp/localhost/5432) 2>/dev/null; do echo "Waiting for postgres to start" From b5775743e151a7f00bd5da744678166326b65a38 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 25 Jul 2017 11:18:33 -0500 Subject: [PATCH 0082/1998] README: update to 68 languages. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 7debacefea..4cc1e729e6 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 67 languages: +Mal is implemented in 68 languages: * Ada * GNU awk From 2110814e43e464afceea62ae9a997944339d5a1c Mon Sep 17 00:00:00 2001 From: Jos van Bakel Date: Tue, 25 Jul 2017 22:19:56 +0200 Subject: [PATCH 0083/1998] Elm: Removed usage of Env from step1 and step2 --- elm/Eval.elm | 13 +++++++++++++ elm/Printer.elm | 21 +++++++-------------- elm/step1_read_print.elm | 5 ++--- elm/step2_eval.elm | 14 +++++--------- elm/step3_env.elm | 9 +++------ 5 files changed, 30 insertions(+), 32 deletions(-) diff --git a/elm/Eval.elm b/elm/Eval.elm index b32946e661..d05888f947 100644 --- a/elm/Eval.elm +++ b/elm/Eval.elm @@ -223,3 +223,16 @@ inGlobal body = else body ) + + +runSimple : Eval a -> Result MalExpr a +runSimple e = + case run Env.global e of + ( _, EvalOk res ) -> + Ok res + + ( _, EvalErr msg ) -> + Err msg + + _ -> + Debug.crash "can't happen" diff --git a/elm/Printer.elm b/elm/Printer.elm index 6359a23925..2c4402a027 100644 --- a/elm/Printer.elm +++ b/elm/Printer.elm @@ -7,6 +7,11 @@ import Utils exposing (encodeString, wrap) import Env +printStr : Bool -> MalExpr -> String +printStr = + printString Env.global + + printString : Env -> Bool -> MalExpr -> String printString env readably ast = case ast of @@ -40,18 +45,6 @@ printString env readably ast = MalMap map -> printMap env readably map - MalFunction (UserFunc { frameId, meta }) -> - "# - "" - - Just meta -> - " meta=" ++ printString env True meta - ) - ++ ">" - MalFunction _ -> "#" @@ -62,8 +55,8 @@ printString env readably ast = in "(atom " ++ (printString env True value) ++ ")" - MalApply { frameId, bound } -> - "#" + MalApply _ -> + "#" printBound : Env -> Bool -> List ( String, MalExpr ) -> String diff --git a/elm/step1_read_print.elm b/elm/step1_read_print.elm index c0653c81b2..46476bf583 100644 --- a/elm/step1_read_print.elm +++ b/elm/step1_read_print.elm @@ -5,8 +5,7 @@ import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) import Types exposing (MalExpr(..)) import Reader exposing (readString) -import Printer exposing (printString) -import Env +import Printer exposing (printStr) main : Program Flags Model Msg @@ -86,7 +85,7 @@ eval ast = print : MalExpr -> String print = - printString Env.global True + printStr True {-| Read-Eval-Print diff --git a/elm/step2_eval.elm b/elm/step2_eval.elm index 39ebf8a751..d23e1d8cea 100644 --- a/elm/step2_eval.elm +++ b/elm/step2_eval.elm @@ -5,13 +5,12 @@ import Json.Decode exposing (decodeValue) import Platform exposing (programWithFlags) import Types exposing (..) import Reader exposing (readString) -import Printer exposing (printString) +import Printer exposing (printStr) import Utils exposing (maybeToList, zip) import Dict exposing (Dict) import Tuple exposing (mapFirst, second) import Array import Eval -import Env main : Program Flags Model Msg @@ -135,16 +134,13 @@ eval env ast = ( Err "can't happen", newEnv ) (MalFunction (CoreFunc fn)) :: args -> - case second <| Eval.run Env.global (fn args) of - EvalOk res -> + case Eval.runSimple (fn args) of + Ok res -> ( Ok res, newEnv ) - EvalErr msg -> + Err msg -> ( Err (print msg), newEnv ) - _ -> - Debug.crash "can't happen" - fn :: _ -> ( Err ((print fn) ++ " is not a function"), newEnv ) @@ -232,7 +228,7 @@ tryMapList fn list = print : MalExpr -> String print = - printString Env.global True + printStr True {-| Read-Eval-Print. rep returns: diff --git a/elm/step3_env.elm b/elm/step3_env.elm index ddcb858f55..59a592c874 100644 --- a/elm/step3_env.elm +++ b/elm/step3_env.elm @@ -135,16 +135,13 @@ eval env ast = ( Err "can't happen", newEnv ) (MalFunction (CoreFunc fn)) :: args -> - case second <| Eval.run Env.global (fn args) of - EvalOk res -> + case Eval.runSimple (fn args) of + Ok res -> ( Ok res, newEnv ) - EvalErr msg -> + Err msg -> ( Err (print msg), newEnv ) - _ -> - Debug.crash "can't happen" - fn :: _ -> ( Err ((print fn) ++ " is not a function"), newEnv ) From 62fc786e1b7c0a1a6448500b691c93baa3e6d04f Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 26 Jul 2017 23:53:39 -0500 Subject: [PATCH 0084/1998] [clojure] Fixes to support lumo 1.6.0. - Pass down the CLJ_MODE value for DOCKERIZED builds in addition to run/tests. - Correct deps so that node_modules is installed for CLJ_MODE=cljs for all steps. - Lumo 1.6.0 is currently not able to install globally as root (https://github.com/anmonteiro/lumo/issues/206) so add the local node_modules/.bin to the PATH in the run script. - Reader conditionals needed for clojure.reader/cljs.reader until this is fixed: https://github.com/anmonteiro/lumo/issues/209 --- .gitignore | 3 +++ Makefile | 12 ++++++++++-- clojure/Dockerfile | 14 ++++++++++---- clojure/Makefile | 7 ++++++- clojure/package.json | 2 +- clojure/run | 1 + clojure/src/mal/reader.cljc | 6 ++++-- 7 files changed, 35 insertions(+), 10 deletions(-) diff --git a/.gitignore b/.gitignore index b5bfa49851..279cf5c950 100644 --- a/.gitignore +++ b/.gitignore @@ -1,11 +1,14 @@ .bash_history .cache +.config .mal-history .crystal .lein .m2 .ivy2 .sbt +.npm +.node-gyp */experiments */node_modules *.o diff --git a/Makefile b/Makefile index 0cdecb0eba..20a663629d 100644 --- a/Makefile +++ b/Makefile @@ -237,7 +237,15 @@ actual_impl = $(if $(filter mal,$(1)),$(MAL_IMPL),$(1)) # Returns nothing if DOCKERIZE is not set, otherwise returns the # docker prefix necessary to run make within the docker environment # for this impl -get_build_prefix = $(if $(strip $(DOCKERIZE)),docker run -it --rm -u $(shell id -u) -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal -w /mal/$(1) $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) $(call impl_to_image,$(1)) ,) +get_build_prefix = $(strip $(if $(strip $(DOCKERIZE)),\ + docker run \ + -it --rm -u $(shell id -u) \ + -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ + -w /mal/$(1) \ + $(if $(filter clojure,$(1)),-e CLJ_MODE=$(CLJ_MODE),) \ + $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ + $(call impl_to_image,$(1)) \ + ,)) # Takes impl and step arguments # Returns a command prefix (docker command and environment variables) @@ -304,7 +312,7 @@ ALL_REPL = $(strip $(sort \ $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))): $(foreach impl,$(word 1,$(subst /, ,$(@))),\ $(if $(DOCKERIZE), \ - $(call get_build_prefix,$(impl))$(MAKE) $(patsubst $(impl)/%,%,$(@)), \ + $(call get_build_prefix,$(impl)) $(MAKE) $(patsubst $(impl)/%,%,$(@)), \ $(MAKE) -C $(impl) $(subst $(impl)/,,$(@)))) # Allow IMPL, and IMPL^STEP diff --git a/clojure/Dockerfile b/clojure/Dockerfile index 1784e6e189..2a8eb37114 100644 --- a/clojure/Dockerfile +++ b/clojure/Dockerfile @@ -40,8 +40,14 @@ ENV LEIN_JVM_OPTS -Duser.home=/mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 7.X -RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - +# Add nodesource apt repo config for 8.X +RUN curl -sL https://deb.nodesource.com/setup_8.x | bash - + +# Install nodejs. +RUN apt-get -y install nodejs + +## Install ffi and lumo-cljs modules globally +#RUN npm install -g ffi lumo-cljs + +ENV HOME=/mal -# Install nodejs. Install ffi and lumo-cljs modules globally -RUN apt-get -y install nodejs && npm install -g ffi lumo-cljs diff --git a/clojure/Makefile b/clojure/Makefile index 5931cf94de..f1b4039848 100644 --- a/clojure/Makefile +++ b/clojure/Makefile @@ -5,7 +5,7 @@ SOURCES_LISP = src/mal/env.cljc src/mal/core.cljc src/mal/stepA_mal.cljc SRCS = $(SOURCES_BASE) src/mal/env.cljc src/mal/core.cljc SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -all: $(if $(filter cljs,$(CLJ_MODE)),node_modules,deps) +DEPS = $(if $(filter cljs,$(CLJ_MODE)),node_modules,deps) dist: mal.jar mal @@ -21,6 +21,11 @@ mal: mal.jar cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ chmod +x mal +src/mal/%.cljc: $(DEPS) + @true + +#src/mal/stepA_mal.cljc: $(DEPS) + target/%.jar: src/mal/%.cljc $(SRCS) lein with-profile $(word 1,$(subst _, ,$*)) uberjar diff --git a/clojure/package.json b/clojure/package.json index dfaab9cd82..ea4479f733 100644 --- a/clojure/package.json +++ b/clojure/package.json @@ -4,6 +4,6 @@ "description": "Make a Lisp (mal) language implemented in ClojureScript", "dependencies": { "ffi": "2.2.x", - "lumo-cljs": "1.0.0" + "lumo-cljs": "^1.6.0" } } diff --git a/clojure/run b/clojure/run index a00d501ad4..54c14f8014 100755 --- a/clojure/run +++ b/clojure/run @@ -1,4 +1,5 @@ #!/bin/bash +export PATH=$PATH:$(dirname $0)/node_modules/.bin STEP=${STEP:-stepA_mal} if [ "${CLJ_MODE}" = "cljs" ]; then exec lumo -c $(dirname $0)/src -m mal.${STEP//_/-} "${@}" diff --git a/clojure/src/mal/reader.cljc b/clojure/src/mal/reader.cljc index 1e7c7e6e99..fbe36d5788 100644 --- a/clojure/src/mal/reader.cljc +++ b/clojure/src/mal/reader.cljc @@ -1,7 +1,9 @@ (ns mal.reader (:refer-clojure :exclude [read-string]) - (:require [clojure.tools.reader :as r] - [clojure.tools.reader.reader-types :as rt])) + #?(:clj (:require [clojure.tools.reader :as r] + [clojure.tools.reader.reader-types :as rt])) + #?(:cljs (:require [cljs.tools.reader :as r] + [cljs.tools.reader.reader-types :as rt]))) ;; change tools.reader syntax-quote to quasiquote (defn- wrap [sym] From 259b5c9420f6aadebf091d7783d726d6249c7468 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 27 Jul 2017 00:19:00 -0500 Subject: [PATCH 0085/1998] [clojure] fix uberjar file name. The project.clj sets the uberjar path so the build needs to copy from that location. --- clojure/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/clojure/Makefile b/clojure/Makefile index f1b4039848..4c468efd29 100644 --- a/clojure/Makefile +++ b/clojure/Makefile @@ -14,7 +14,7 @@ deps: mal.jar: $(SOURCES) lein with-profile stepA uberjar - cp target/mal-0.0.1-SNAPSHOT-standalone.jar $@ + cp target/stepA_mal.jar $@ SHELL := bash mal: mal.jar From e4d2540897258c90c29f0081ac742cede8915175 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 27 Jul 2017 00:35:46 -0500 Subject: [PATCH 0086/1998] [clojure] add ClojureScript mode to travis list. --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index e211b438ac..fc6c6a7ffe 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,7 +14,8 @@ matrix: - {env: IMPL=coffee, services: [docker]} - {env: IMPL=cs, services: [docker]} - {env: IMPL=chuck, services: [docker]} - - {env: IMPL=clojure, services: [docker]} + - {env: IMPL=clojure CLJ_MODE=clj, services: [docker]} + - {env: IMPL=clojure CLJ_MODE=cljs, services: [docker]} - {env: IMPL=common-lisp, services: [docker]} - {env: IMPL=crystal, services: [docker]} - {env: IMPL=d, services: [docker]} From 7a6fdd1b4c959843c622e1223c4f9a6652cae242 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 27 Jul 2017 00:52:31 -0500 Subject: [PATCH 0087/1998] [travis] pass down CLJ_MODE --- .travis_build.sh | 6 ++++-- .travis_test.sh | 4 +++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/.travis_build.sh b/.travis_build.sh index 308965ec24..5adf810cee 100755 --- a/.travis_build.sh +++ b/.travis_build.sh @@ -21,7 +21,9 @@ if [ -z "${NO_DOCKER}" ]; then make -C ${BUILD_IMPL} step9_try || true fi docker run -it -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl} \ - make -C ${BUILD_IMPL} + make CLJ_MODE=${CLJ_MODE} \ + -C ${BUILD_IMPL} else - make -C ${BUILD_IMPL} + make CLJ_MODE=${CLJ_MODE} \ + -C ${BUILD_IMPL} fi diff --git a/.travis_test.sh b/.travis_test.sh index af5d16c61b..0a3d95062d 100755 --- a/.travis_test.sh +++ b/.travis_test.sh @@ -22,7 +22,9 @@ else fi ${MAKE} TEST_OPTS="--debug-file ../${ACTION}.err" \ - MAL_IMPL=${MAL_IMPL} ${ACTION}^${IMPL} + MAL_IMPL=${MAL_IMPL} \ + CLJ_MODE=${CLJ_MODE} \ + ${ACTION}^${IMPL} # no failure so remove error log rm -f ${ACTION}.err || true From f88f1ca1e1ffe79aaf5258a5581166c9fa4e4be2 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Nov 2016 13:42:27 +0530 Subject: [PATCH 0088/1998] Common Lisp: Fix warning while compiling core.lisp --- common-lisp/core.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/common-lisp/core.lisp b/common-lisp/core.lisp index c87779eef6..e333c8cdd4 100644 --- a/common-lisp/core.lisp +++ b/common-lisp/core.lisp @@ -145,8 +145,8 @@ (or (nth (types:mal-data-value index) (map 'list #'identity (types:mal-data-value sequence))) (error 'index-error - :size (length (mal-value sequence)) - :index (mal-value index) + :size (length (types:mal-data-value sequence)) + :index (types:mal-data-value index) :sequence sequence))) (defun mal-first (sequence) From efe3f67629f96339b1b672e542d2964729149148 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Nov 2016 13:44:20 +0530 Subject: [PATCH 0089/1998] Common Lisp: Do not create boolean and nil while reading --- common-lisp/reader.lisp | 6 +++--- common-lisp/types.lisp | 1 - 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/common-lisp/reader.lisp b/common-lisp/reader.lisp index 539949629e..bd609ff216 100644 --- a/common-lisp/reader.lisp +++ b/common-lisp/reader.lisp @@ -166,11 +166,11 @@ raised" (let ((token (next reader))) (cond ((string= token "false") - (make-mal-boolean nil)) + mal-false) ((string= token "true") - (make-mal-boolean t)) + mal-true) ((string= token "nil") - (make-mal-nil nil)) + mal-nil) ((char= (char token 0) #\") (make-mal-string (parse-string token))) ((char= (char token 0) #\:) diff --git a/common-lisp/types.lisp b/common-lisp/types.lisp index 9b1cdf28fe..9b29799efd 100644 --- a/common-lisp/types.lisp +++ b/common-lisp/types.lisp @@ -124,7 +124,6 @@ (define-mal-type symbol) (define-mal-type keyword) (define-mal-type string) -;; TODO true, false and nil should ideally be singleton (define-mal-type boolean) (define-mal-type nil) From 1a33a0b66e97018fee1c9db9b0fbe83423be07f2 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Nov 2016 13:45:40 +0530 Subject: [PATCH 0090/1998] Common Lisp: Use genhash APIs instead of native API in (un)wrap-value --- common-lisp/types.lisp | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/common-lisp/types.lisp b/common-lisp/types.lisp index 9b29799efd..2d97b554ff 100644 --- a/common-lisp/types.lisp +++ b/common-lisp/types.lisp @@ -223,10 +223,10 @@ (list (make-mal-list (map 'list #'wrap-value value))) (vector (make-mal-vector (map 'vector #'wrap-value value))) (hash-table (make-mal-hash-map (let ((new-hash-table (make-mal-value-hash-table))) - (loop - for key being the hash-keys of value - do (setf (gethash (wrap-value key) new-hash-table) - (wrap-value (gethash key value)))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref (wrap-value key) new-hash-table) + (wrap-value value))) + value) new-hash-table))))) (defun unwrap-value (value) @@ -235,10 +235,10 @@ (vector (map 'vector #'unwrap-value (mal-data-value value))) (hash-map (let ((hash-table (make-hash-table)) (hash-map-value (mal-data-value value))) - (loop - for key being the hash-keys of hash-map-value - do (setf (gethash (mal-data-value key) hash-table) - (mal-data-value (gethash key hash-map-value)))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref (mal-data-value key) hash-table) + (mal-data-value value))) + hash-map-value) hash-table)) (any (mal-data-value value)))) From 0795349bc4b1b8193cf8c4402a9a0460e8da09b9 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Nov 2016 13:47:28 +0530 Subject: [PATCH 0091/1998] Common Lisp: DRY conversion of vectors to list --- common-lisp/reader.lisp | 5 +++-- common-lisp/step0_repl.lisp | 5 +++-- common-lisp/step1_read_print.lisp | 10 ++++++---- common-lisp/step2_eval.lisp | 12 ++++++++---- common-lisp/step3_env.lisp | 14 ++++++++------ common-lisp/step4_if_fn_do.lisp | 15 +++++++++------ common-lisp/step5_tco.lisp | 15 +++++++++------ common-lisp/step6_file.lisp | 18 ++++++++++-------- common-lisp/step7_quote.lisp | 18 ++++++++++-------- common-lisp/step8_macros.lisp | 18 ++++++++++-------- common-lisp/step9_try.lisp | 14 ++++++++------ common-lisp/stepA_mal.lisp | 18 ++++++++++-------- common-lisp/types.lisp | 13 ++++++++----- common-lisp/utils.lisp | 7 ++++++- 14 files changed, 108 insertions(+), 74 deletions(-) diff --git a/common-lisp/reader.lisp b/common-lisp/reader.lisp index bd609ff216..ba4f44c828 100644 --- a/common-lisp/reader.lisp +++ b/common-lisp/reader.lisp @@ -1,7 +1,8 @@ (defpackage :reader (:use :common-lisp - :types - :genhash) + :types) + (:import-from :genhash + :hashref) (:import-from :cl-ppcre :create-scanner :do-matches-as-strings diff --git a/common-lisp/step0_repl.lisp b/common-lisp/step0_repl.lisp index 4f43b58884..c881dd5a75 100644 --- a/common-lisp/step0_repl.lisp +++ b/common-lisp/step0_repl.lisp @@ -1,6 +1,7 @@ (defpackage :mal - (:use :common-lisp - :uiop) + (:use :common-lisp) + (:import-from :uiop + :getenv) (:export :main)) (in-package :mal) diff --git a/common-lisp/step1_read_print.lisp b/common-lisp/step1_read_print.lisp index f0032b62d0..b16578b629 100644 --- a/common-lisp/step1_read_print.lisp +++ b/common-lisp/step1_read_print.lisp @@ -1,8 +1,9 @@ (defpackage :mal (:use :common-lisp :reader - :printer - :utils) + :printer) + (:import-from :utils + :getenv) (:export :main)) (in-package :mal) @@ -11,6 +12,7 @@ (reader:read-str string)) (defun mal-eval (ast env) + (declare (ignorable env)) ast) (defun mal-print (expression) @@ -48,8 +50,8 @@ (defun main (&optional (argv nil argv-provided-p)) (declare (ignorable argv argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step2_eval.lisp b/common-lisp/step2_eval.lisp index b19c5fdf2d..e3d33b5a31 100644 --- a/common-lisp/step2_eval.lisp +++ b/common-lisp/step2_eval.lisp @@ -3,8 +3,12 @@ :types :env :reader - :printer - :genhash) + :printer) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :getenv) (:export :main)) (in-package :mal) @@ -111,8 +115,8 @@ (defun main (&optional (argv nil argv-provided-p)) (declare (ignorable argv argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step3_env.lisp b/common-lisp/step3_env.lisp index 7bb2057b15..3365a72f65 100644 --- a/common-lisp/step3_env.lisp +++ b/common-lisp/step3_env.lisp @@ -5,6 +5,11 @@ :reader :printer :genhash) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :getenv) (:export :main)) (in-package :mal) @@ -66,10 +71,7 @@ (defun eval-let* (forms env) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (types:mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -140,8 +142,8 @@ (defun main (&optional (argv nil argv-provided-p)) (declare (ignorable argv argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step4_if_fn_do.lisp b/common-lisp/step4_if_fn_do.lisp index 1f7bfa3878..52b3a934bf 100644 --- a/common-lisp/step4_if_fn_do.lisp +++ b/common-lisp/step4_if_fn_do.lisp @@ -5,6 +5,12 @@ :reader :printer :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -46,10 +52,7 @@ (defun eval-let* (forms env) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -143,8 +146,8 @@ (defun main (&optional (argv nil argv-provided-p)) (declare (ignorable argv argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step5_tco.lisp b/common-lisp/step5_tco.lisp index aa6244f97a..181bfab623 100644 --- a/common-lisp/step5_tco.lisp +++ b/common-lisp/step5_tco.lisp @@ -5,6 +5,12 @@ :reader :printer :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -60,10 +66,7 @@ ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -154,8 +157,8 @@ (defun main (&optional (argv nil argv-provided-p)) (declare (ignorable argv argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step6_file.lisp b/common-lisp/step6_file.lisp index 71a4f7972e..b474aac53c 100644 --- a/common-lisp/step6_file.lisp +++ b/common-lisp/step6_file.lisp @@ -4,8 +4,13 @@ :env :reader :printer - :core - :utils) + :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -61,10 +66,7 @@ ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -169,8 +171,8 @@ (defun main (&optional (argv nil argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step7_quote.lisp b/common-lisp/step7_quote.lisp index 3250f80d55..26d4a57ba6 100644 --- a/common-lisp/step7_quote.lisp +++ b/common-lisp/step7_quote.lisp @@ -4,8 +4,13 @@ :env :reader :printer - :core - :utils) + :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -97,10 +102,7 @@ ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -205,8 +207,8 @@ (defun main (&optional (argv nil argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step8_macros.lisp b/common-lisp/step8_macros.lisp index a8f370b966..4ae36f87b2 100644 --- a/common-lisp/step8_macros.lisp +++ b/common-lisp/step8_macros.lisp @@ -4,8 +4,13 @@ :env :reader :printer - :core - :utils) + :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -145,10 +150,7 @@ ((types:mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (types:mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -264,8 +266,8 @@ (defun main (&optional (argv nil argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/step9_try.lisp b/common-lisp/step9_try.lisp index cbf759c0af..c03be8f2af 100644 --- a/common-lisp/step9_try.lisp +++ b/common-lisp/step9_try.lisp @@ -4,8 +4,13 @@ :env :reader :printer - :core - :utils) + :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -148,10 +153,7 @@ ((types:mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (types:mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env diff --git a/common-lisp/stepA_mal.lisp b/common-lisp/stepA_mal.lisp index 84b7690a7f..fa629aa7ac 100644 --- a/common-lisp/stepA_mal.lisp +++ b/common-lisp/stepA_mal.lisp @@ -4,8 +4,13 @@ :env :reader :printer - :core - :utils) + :core) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv) (:export :main)) (in-package :mal) @@ -148,10 +153,7 @@ ((types:mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - ;; Convert a potential vector to a list - (bindings (map 'list - #'identity - (types:mal-data-value (second forms))))) + (bindings (utils:listify (types:mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env @@ -304,8 +306,8 @@ (defun main (&optional (argv nil argv-provided-p)) - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment diff --git a/common-lisp/types.lisp b/common-lisp/types.lisp index 2d97b554ff..5e9ac37599 100644 --- a/common-lisp/types.lisp +++ b/common-lisp/types.lisp @@ -1,6 +1,8 @@ (defpackage :types (:use :common-lisp :genhash) + (:import-from :utils + :listify) (:export :mal-data-value= ;; Accessors :mal-data-value @@ -155,8 +157,8 @@ forms)))) (defun mal-sequence= (value1 value2) - (let ((sequence1 (map 'list #'identity (mal-data-value value1))) - (sequence2 (map 'list #'identity (mal-data-value value2)))) + (let ((sequence1 (utils:listify (mal-data-value value1))) + (sequence2 (utils:listify (mal-data-value value2)))) (when (= (length sequence1) (length sequence2)) (every #'identity (loop @@ -181,6 +183,7 @@ (defun mal-data-value= (value1 value2) (when (and (typep value1 'mal-data) (typep value2 'mal-data)) + (if (equal (mal-data-type value1) (mal-data-type value2)) (switch-mal-type value1 (list (mal-sequence= value1 value2)) @@ -211,9 +214,9 @@ (number (make-mal-number value)) ;; This needs to be before symbol since nil is a symbol (null (funcall (cond - (booleanp #'make-mal-boolean) - (listp #'make-mal-list) - (t #'make-mal-nil)) + (booleanp #'make-mal-boolean) + (listp #'make-mal-list) + (t #'make-mal-nil)) value)) ;; This needs to before symbol since t, nil are symbols (boolean (make-mal-boolean value)) diff --git a/common-lisp/utils.lisp b/common-lisp/utils.lisp index f90bfd5943..8845f2048b 100644 --- a/common-lisp/utils.lisp +++ b/common-lisp/utils.lisp @@ -4,7 +4,8 @@ (:export :replace-all :getenv :read-file-string - :raw-command-line-arguments)) + :raw-command-line-arguments + :listify)) (in-package :utils) @@ -22,3 +23,7 @@ is replaced with replacement." :end (or pos (length string))) when pos do (write-string replacement out) while pos))) + +(defun listify (sequence) + "Convert a sequence to a list" + (map 'list #'identity sequence)) From a0e32831fd595caa55ec866ea1f24e164350524c Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Nov 2016 13:49:00 +0530 Subject: [PATCH 0092/1998] Common Lisp: Cleanup printing of hashmap and sequences --- common-lisp/printer.lisp | 45 ++++++++++++++++------------------------ common-lisp/types.lisp | 9 ++------ 2 files changed, 20 insertions(+), 34 deletions(-) diff --git a/common-lisp/printer.lisp b/common-lisp/printer.lisp index de227a32dd..a6833d0ef8 100644 --- a/common-lisp/printer.lisp +++ b/common-lisp/printer.lisp @@ -1,41 +1,32 @@ (defpackage :printer (:use :common-lisp - :types - :genhash) + :types) + (:import-from :genhash + :hashmap) (:import-from :cl-ppcre :regex-replace) (:import-from :utils - :replace-all) + :replace-all + :listify) (:export :pr-str)) (in-package :printer) (defun pr-mal-sequence (start-delimiter sequence end-delimiter &optional (print-readably t)) - (concatenate 'string - start-delimiter - (format nil - "~{~a~^ ~}" - (map 'list (lambda (value) - (pr-str value print-readably)) - (types:mal-data-value sequence))) - end-delimiter)) + (format nil + "~a~{~a~^ ~}~a" + start-delimiter + (mapcar (lambda (value) + (pr-str value print-readably)) + (utils:listify (types:mal-data-value sequence))) + end-delimiter)) -(defun pr-mal-hash-map (hash-map &optional (print-readably t)) - (let ((hash-map-value (types:mal-data-value hash-map))) - (concatenate 'string - "{" - (format nil - "~{~a~^ ~}" - (let (repr) - (genhash:hashmap (lambda (key value) - (push (format nil - "~a ~a" - (pr-str key print-readably) - (pr-str value print-readably)) - repr)) - hash-map-value) - repr)) - "}"))) +(defun pr-mal-hash-map (hash-map &optional (print-readably t) &aux repr) + (genhash:hashmap (lambda (key value) + (push (pr-str value print-readably) repr) + (push (pr-str key print-readably) repr)) + (types:mal-data-value hash-map)) + (format nil "{~{~a ~a~^ ~}}" repr)) (defun pr-string (ast &optional (print-readably t)) (if print-readably diff --git a/common-lisp/types.lisp b/common-lisp/types.lisp index 5e9ac37599..2447da518b 100644 --- a/common-lisp/types.lisp +++ b/common-lisp/types.lisp @@ -105,13 +105,8 @@ ;; Create a constructor and predicate for given type (defmacro define-mal-type (type) - (let ((constructor (intern (string-upcase (concatenate 'string - "make-mal-" - (symbol-name type))))) - (predicate (intern (string-upcase (concatenate 'string - "mal-" - (symbol-name type) - "-p"))))) + (let ((constructor (intern (format nil "MAKE-MAL-~a" (symbol-name type)))) + (predicate (intern (format nil "MAL-~a-P" (symbol-name type))))) `(progn (defun ,constructor (value &key meta attrs) (make-mal-data :type ',type :value value From 371ebd53a3292ec65a25338592f217e0fb29bf27 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Nov 2016 17:25:16 +0530 Subject: [PATCH 0093/1998] Common Lisp: Move source code to src/ folder --- common-lisp/Makefile | 6 +++--- common-lisp/{ => src}/core.lisp | 0 common-lisp/{ => src}/env.lisp | 0 common-lisp/{ => src}/printer.lisp | 0 common-lisp/{ => src}/reader.lisp | 0 common-lisp/{ => src}/step0_repl.lisp | 0 common-lisp/{ => src}/step1_read_print.lisp | 0 common-lisp/{ => src}/step2_eval.lisp | 0 common-lisp/{ => src}/step3_env.lisp | 0 common-lisp/{ => src}/step4_if_fn_do.lisp | 0 common-lisp/{ => src}/step5_tco.lisp | 0 common-lisp/{ => src}/step6_file.lisp | 0 common-lisp/{ => src}/step7_quote.lisp | 0 common-lisp/{ => src}/step8_macros.lisp | 0 common-lisp/{ => src}/step9_try.lisp | 0 common-lisp/{ => src}/stepA_mal.lisp | 0 common-lisp/{ => src}/types.lisp | 0 common-lisp/{ => src}/utils.lisp | 0 common-lisp/step0_repl.asd | 3 ++- common-lisp/step1_read_print.asd | 3 ++- common-lisp/step2_eval.asd | 3 ++- common-lisp/step3_env.asd | 3 ++- common-lisp/step4_if_fn_do.asd | 3 ++- common-lisp/step5_tco.asd | 3 ++- common-lisp/step6_file.asd | 3 ++- common-lisp/step7_quote.asd | 3 ++- common-lisp/step8_macros.asd | 3 ++- common-lisp/step9_try.asd | 3 ++- common-lisp/stepA_mal.asd | 3 ++- 29 files changed, 25 insertions(+), 14 deletions(-) rename common-lisp/{ => src}/core.lisp (100%) rename common-lisp/{ => src}/env.lisp (100%) rename common-lisp/{ => src}/printer.lisp (100%) rename common-lisp/{ => src}/reader.lisp (100%) rename common-lisp/{ => src}/step0_repl.lisp (100%) rename common-lisp/{ => src}/step1_read_print.lisp (100%) rename common-lisp/{ => src}/step2_eval.lisp (100%) rename common-lisp/{ => src}/step3_env.lisp (100%) rename common-lisp/{ => src}/step4_if_fn_do.lisp (100%) rename common-lisp/{ => src}/step5_tco.lisp (100%) rename common-lisp/{ => src}/step6_file.lisp (100%) rename common-lisp/{ => src}/step7_quote.lisp (100%) rename common-lisp/{ => src}/step8_macros.lisp (100%) rename common-lisp/{ => src}/step9_try.lisp (100%) rename common-lisp/{ => src}/stepA_mal.lisp (100%) rename common-lisp/{ => src}/types.lisp (100%) rename common-lisp/{ => src}/utils.lisp (100%) diff --git a/common-lisp/Makefile b/common-lisp/Makefile index 9d620701dd..d6d8437d0f 100644 --- a/common-lisp/Makefile +++ b/common-lisp/Makefile @@ -12,8 +12,8 @@ define steps endef ROOT_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) -SOURCES_LISP := env.lisp core.lisp stepA_mal.lisp -SOURCES := utils.lisp types.lisp reader.lisp printer.lisp $(SOURCES_LISP) +SOURCES_LISP := src/env.lisp src/core.lisp src/stepA_mal.lisp +SOURCES := src/utils.lisp src/types.lisp src/reader.lisp src/printer.lisp $(SOURCES_LISP) LISP ?= sbcl ABCL ?= abcl @@ -33,7 +33,7 @@ hist/%_impl: ; # directory of the CL_LAUNCH_FILE in --wrap script so that the script can find the dumped # image even if invoked from some directory different from where it # currently resides -step% : step%.lisp utils.lisp types.lisp env.lisp printer.lisp reader.lisp core.lisp hist/%_impl +step% : src/step%.lisp src/utils.lisp src/types.lisp src/env.lisp src/printer.lisp src/reader.lisp src/core.lisp hist/%_impl ifeq ($(LISP),abcl) echo -n '#!/bin/sh\ncd `dirname $$0` ; $(ABCL) --noinform --noinit --nosystem --load run-abcl.lisp -- $@ $$@' > $@ chmod +x $@ diff --git a/common-lisp/core.lisp b/common-lisp/src/core.lisp similarity index 100% rename from common-lisp/core.lisp rename to common-lisp/src/core.lisp diff --git a/common-lisp/env.lisp b/common-lisp/src/env.lisp similarity index 100% rename from common-lisp/env.lisp rename to common-lisp/src/env.lisp diff --git a/common-lisp/printer.lisp b/common-lisp/src/printer.lisp similarity index 100% rename from common-lisp/printer.lisp rename to common-lisp/src/printer.lisp diff --git a/common-lisp/reader.lisp b/common-lisp/src/reader.lisp similarity index 100% rename from common-lisp/reader.lisp rename to common-lisp/src/reader.lisp diff --git a/common-lisp/step0_repl.lisp b/common-lisp/src/step0_repl.lisp similarity index 100% rename from common-lisp/step0_repl.lisp rename to common-lisp/src/step0_repl.lisp diff --git a/common-lisp/step1_read_print.lisp b/common-lisp/src/step1_read_print.lisp similarity index 100% rename from common-lisp/step1_read_print.lisp rename to common-lisp/src/step1_read_print.lisp diff --git a/common-lisp/step2_eval.lisp b/common-lisp/src/step2_eval.lisp similarity index 100% rename from common-lisp/step2_eval.lisp rename to common-lisp/src/step2_eval.lisp diff --git a/common-lisp/step3_env.lisp b/common-lisp/src/step3_env.lisp similarity index 100% rename from common-lisp/step3_env.lisp rename to common-lisp/src/step3_env.lisp diff --git a/common-lisp/step4_if_fn_do.lisp b/common-lisp/src/step4_if_fn_do.lisp similarity index 100% rename from common-lisp/step4_if_fn_do.lisp rename to common-lisp/src/step4_if_fn_do.lisp diff --git a/common-lisp/step5_tco.lisp b/common-lisp/src/step5_tco.lisp similarity index 100% rename from common-lisp/step5_tco.lisp rename to common-lisp/src/step5_tco.lisp diff --git a/common-lisp/step6_file.lisp b/common-lisp/src/step6_file.lisp similarity index 100% rename from common-lisp/step6_file.lisp rename to common-lisp/src/step6_file.lisp diff --git a/common-lisp/step7_quote.lisp b/common-lisp/src/step7_quote.lisp similarity index 100% rename from common-lisp/step7_quote.lisp rename to common-lisp/src/step7_quote.lisp diff --git a/common-lisp/step8_macros.lisp b/common-lisp/src/step8_macros.lisp similarity index 100% rename from common-lisp/step8_macros.lisp rename to common-lisp/src/step8_macros.lisp diff --git a/common-lisp/step9_try.lisp b/common-lisp/src/step9_try.lisp similarity index 100% rename from common-lisp/step9_try.lisp rename to common-lisp/src/step9_try.lisp diff --git a/common-lisp/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp similarity index 100% rename from common-lisp/stepA_mal.lisp rename to common-lisp/src/stepA_mal.lisp diff --git a/common-lisp/types.lisp b/common-lisp/src/types.lisp similarity index 100% rename from common-lisp/types.lisp rename to common-lisp/src/types.lisp diff --git a/common-lisp/utils.lisp b/common-lisp/src/utils.lisp similarity index 100% rename from common-lisp/utils.lisp rename to common-lisp/src/utils.lisp diff --git a/common-lisp/step0_repl.asd b/common-lisp/step0_repl.asd index aee96e820a..fbad7d602c 100644 --- a/common-lisp/step0_repl.asd +++ b/common-lisp/step0_repl.asd @@ -19,4 +19,5 @@ :description "Implementation of step 0 of MAL in Common Lisp" :serial t :components ((:file "step0_repl")) - :depends-on (:uiop :cl-readline)) + :depends-on (:uiop :cl-readline) + :pathname "src/") diff --git a/common-lisp/step1_read_print.asd b/common-lisp/step1_read_print.asd index 993b77d333..ea7134fbe3 100644 --- a/common-lisp/step1_read_print.asd +++ b/common-lisp/step1_read_print.asd @@ -25,4 +25,5 @@ (:file "reader") (:file "printer") (:file "step1_read_print")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step2_eval.asd b/common-lisp/step2_eval.asd index 2b0b3c5907..06b1b8074d 100644 --- a/common-lisp/step2_eval.asd +++ b/common-lisp/step2_eval.asd @@ -26,4 +26,5 @@ (:file "reader") (:file "printer") (:file "step2_eval")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step3_env.asd b/common-lisp/step3_env.asd index 3dc014a669..5120a3c54b 100644 --- a/common-lisp/step3_env.asd +++ b/common-lisp/step3_env.asd @@ -26,4 +26,5 @@ (:file "reader") (:file "printer") (:file "step3_env")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step4_if_fn_do.asd b/common-lisp/step4_if_fn_do.asd index efddd5e3b7..902f99a242 100644 --- a/common-lisp/step4_if_fn_do.asd +++ b/common-lisp/step4_if_fn_do.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "step4_if_fn_do")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step5_tco.asd b/common-lisp/step5_tco.asd index bdc42096bc..08ebfaddb6 100644 --- a/common-lisp/step5_tco.asd +++ b/common-lisp/step5_tco.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "step5_tco")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step6_file.asd b/common-lisp/step6_file.asd index 35bc77f375..f8937b2109 100644 --- a/common-lisp/step6_file.asd +++ b/common-lisp/step6_file.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "step6_file")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step7_quote.asd b/common-lisp/step7_quote.asd index efa026930f..73df642a2c 100644 --- a/common-lisp/step7_quote.asd +++ b/common-lisp/step7_quote.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "step7_quote")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step8_macros.asd b/common-lisp/step8_macros.asd index 64d2f97636..e0b4c41a32 100644 --- a/common-lisp/step8_macros.asd +++ b/common-lisp/step8_macros.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "step8_macros")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/step9_try.asd b/common-lisp/step9_try.asd index 84e0ef0248..b1ea4a08fd 100644 --- a/common-lisp/step9_try.asd +++ b/common-lisp/step9_try.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "step9_try")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/common-lisp/stepA_mal.asd b/common-lisp/stepA_mal.asd index 63efad14ac..b9aca81c7e 100644 --- a/common-lisp/stepA_mal.asd +++ b/common-lisp/stepA_mal.asd @@ -27,4 +27,5 @@ (:file "printer") (:file "core") (:file "stepA_mal")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash)) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") From 2ce883223985bb66a408a934549b4ec2fc2e0bb7 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Sun, 4 Dec 2016 13:50:37 +0530 Subject: [PATCH 0094/1998] Common Lisp: Miscellaneous cleanups Refactor env a bit --- common-lisp/src/env.lisp | 54 +++++++++++++------------- common-lisp/src/reader.lisp | 66 ++++++++++++++------------------ common-lisp/step1_read_print.asd | 1 + common-lisp/step2_eval.asd | 1 + common-lisp/step3_env.asd | 1 + common-lisp/step4_if_fn_do.asd | 1 + common-lisp/step5_tco.asd | 1 + common-lisp/step6_file.asd | 1 + common-lisp/step7_quote.asd | 1 + common-lisp/step8_macros.asd | 1 + common-lisp/step9_try.asd | 1 + common-lisp/stepA_mal.asd | 1 + 12 files changed, 66 insertions(+), 64 deletions(-) diff --git a/common-lisp/src/env.lisp b/common-lisp/src/env.lisp index f63364d8d5..b28d984189 100644 --- a/common-lisp/src/env.lisp +++ b/common-lisp/src/env.lisp @@ -30,38 +30,38 @@ (parent nil :read-only t)) (defun find-env (env symbol) - (let ((value (gethash (types:mal-data-value symbol) - (mal-env-bindings env))) - (parent (mal-env-parent env))) - (cond - (value value) - (parent (find-env parent symbol)) - (t nil)))) + (when env + (or (gethash (mal-data-value symbol) + (mal-env-bindings env)) + (find-env (mal-env-parent env) symbol)))) (defun get-env (env symbol) - (let ((value (find-env env symbol))) - (if value - value - (error 'undefined-symbol - :symbol (format nil "~a" (types:mal-data-value symbol)))))) + (or (find-env env symbol) + (error 'undefined-symbol + :symbol (format nil "~a" (mal-data-value symbol))))) (defun set-env (env symbol value) (setf (gethash (types:mal-data-value symbol) (mal-env-bindings env)) value)) -(defun create-mal-env (&key (parent nil) (binds nil) (exprs nil)) - (let ((env (make-mal-env :parent parent))) - (loop - while binds - do (let ((key (pop binds))) - (if (string= (types:mal-data-value key) "&") - (let ((key (pop binds))) - (unless key - (error 'arity-mismatch - :required (length binds) - :provided (length exprs))) - (set-env env key (types:make-mal-list exprs)) - (setq binds nil)) - (set-env env key (pop exprs))))) - env)) +(defun create-mal-env (&key parent binds exprs) + (let ((env (make-mal-env :parent parent)) + (params-length (length binds)) + (arg-length (length exprs))) + + (flet ((arity-mismatch () + (error 'arity-mismatch + :required params-length + :provided arg-length))) + (loop + for key = (pop binds) + while key + do (if (string/= (mal-data-value key) "&") + (set-env env key (or (pop exprs) + (arity-mismatch))) + (progn (set-env env + (or (pop binds) (arity-mismatch)) + (make-mal-list exprs)) + (setq binds nil)))) + env))) diff --git a/common-lisp/src/reader.lisp b/common-lisp/src/reader.lisp index ba4f44c828..d088453476 100644 --- a/common-lisp/src/reader.lisp +++ b/common-lisp/src/reader.lisp @@ -1,6 +1,7 @@ (defpackage :reader (:use :common-lisp - :types) + :types + :alexandria) (:import-from :genhash :hashref) (:import-from :cl-ppcre @@ -85,9 +86,7 @@ raised" (let ((actual-token (pop (token-reader-tokens reader)))) (when (and token-provided-p (not (equal actual-token token))) - (error 'unexpected-token - :expected token - :actual actual-token))) + (error 'unexpected-token :expected token :actual actual-token))) reader) (defun parse-string (token) @@ -97,8 +96,7 @@ raised" "\\n" " ")) - (error 'eof - :context "string"))) + (error 'eof :context "string"))) (defun read-form-with-meta (reader) (consume reader) @@ -107,20 +105,18 @@ raised" (when (or (null meta) (null value)) - (error 'eof - :context "object metadata")) + (error 'eof :context "object metadata")) (make-mal-list (list (make-mal-symbol "with-meta") value meta)))) (defun expand-quote (reader) - (let ((quote (next reader))) - (make-mal-list (list (make-mal-symbol (cond - ((string= quote "'") "quote") - ((string= quote "`") "quasiquote") - ((string= quote "~") "unquote") - ((string= quote "~@") "splice-unquote") - ((string= quote "@") "deref"))) - (read-form reader))))) + (let ((quote-sym (make-mal-symbol (switch ((next reader) :test #'string=) + ("'" "quote") + ("`" "quasiquote") + ("~" "unquote") + ("~@" "splice-unquote") + ("@" "deref"))))) + (make-mal-list (list quote-sym (read-form reader))))) (defun read-mal-sequence (reader &optional (delimiter ")") (constructor 'list)) ;; Consume the opening brace @@ -129,10 +125,9 @@ raised" (loop for token = (peek reader) while (cond - ((null token) (error 'eof - :context (if (string= delimiter ")") - "list" - "vector"))) + ((null token) (error 'eof :context (if (string= delimiter ")") + "list" + "vector"))) ((string= token delimiter) (return)) (t (push (read-form reader) forms)))) ;; Consume the closing brace @@ -147,14 +142,12 @@ raised" (loop for token = (peek reader) while (cond - ((null token) (error 'eof - :context "hash-map")) + ((null token) (error 'eof :context "hash-map")) ((string= token "}") (return)) (t (let ((key (read-form reader)) (value (read-form reader))) (if (null value) - (error 'eof - :context "hash-map") + (error 'eof :context "hash-map") (push (cons key value) forms)))))) ;; Consume the closing brace (consume reader) @@ -181,19 +174,18 @@ raised" (t (make-mal-symbol token))))) (defun read-form (reader) - (let ((token (peek reader))) - (cond - ((null token) nil) - ((string= token "(") (make-mal-list (read-mal-sequence reader - ")" - 'list))) - ((string= token "[") (make-mal-vector (read-mal-sequence reader - "]" - 'vector))) - ((string= token "{") (make-mal-hash-map (read-hash-map reader))) - ((string= token "^") (read-form-with-meta reader)) - ((member token '("'" "`" "~" "~@" "@") :test #'string=) (expand-quote reader)) - (t (read-atom reader))))) + (switch ((peek reader) :test #'equal) + (nil nil) + ("(" (make-mal-list (read-mal-sequence reader ")" 'list))) + ("[" (make-mal-vector (read-mal-sequence reader "]" 'vector))) + ("{" (make-mal-hash-map (read-hash-map reader))) + ("^" (read-form-with-meta reader)) + ("'" (expand-quote reader)) + ("`" (expand-quote reader)) + ("~" (expand-quote reader)) + ("~@" (expand-quote reader)) + ("@" (expand-quote reader)) + (t (read-atom reader)))) (defun read-str (string) (read-form (make-token-reader :tokens (tokenize string)))) diff --git a/common-lisp/step1_read_print.asd b/common-lisp/step1_read_print.asd index ea7134fbe3..c3719f155e 100644 --- a/common-lisp/step1_read_print.asd +++ b/common-lisp/step1_read_print.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step2_eval.asd b/common-lisp/step2_eval.asd index 06b1b8074d..319157d3cf 100644 --- a/common-lisp/step2_eval.asd +++ b/common-lisp/step2_eval.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step3_env.asd b/common-lisp/step3_env.asd index 5120a3c54b..025644622d 100644 --- a/common-lisp/step3_env.asd +++ b/common-lisp/step3_env.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step4_if_fn_do.asd b/common-lisp/step4_if_fn_do.asd index 902f99a242..8af7349f4b 100644 --- a/common-lisp/step4_if_fn_do.asd +++ b/common-lisp/step4_if_fn_do.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step5_tco.asd b/common-lisp/step5_tco.asd index 08ebfaddb6..0fb40bce43 100644 --- a/common-lisp/step5_tco.asd +++ b/common-lisp/step5_tco.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step6_file.asd b/common-lisp/step6_file.asd index f8937b2109..671641c924 100644 --- a/common-lisp/step6_file.asd +++ b/common-lisp/step6_file.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step7_quote.asd b/common-lisp/step7_quote.asd index 73df642a2c..96ab0191a2 100644 --- a/common-lisp/step7_quote.asd +++ b/common-lisp/step7_quote.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step8_macros.asd b/common-lisp/step8_macros.asd index e0b4c41a32..4cab290143 100644 --- a/common-lisp/step8_macros.asd +++ b/common-lisp/step8_macros.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step9_try.asd b/common-lisp/step9_try.asd index b1ea4a08fd..4788e6298d 100644 --- a/common-lisp/step9_try.asd +++ b/common-lisp/step9_try.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/stepA_mal.asd b/common-lisp/stepA_mal.asd index b9aca81c7e..22d5e6f165 100644 --- a/common-lisp/stepA_mal.asd +++ b/common-lisp/stepA_mal.asd @@ -8,6 +8,7 @@ (ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) (defpackage #:mal-asd (:use :cl :asdf)) From 448f74e072041bd016a27475806c3c082d28b2c9 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 12:54:23 +0530 Subject: [PATCH 0095/1998] Common Lisp: Refactor reader to reduce redundant error checks --- common-lisp/src/reader.lisp | 104 ++++++++++++++++-------------------- 1 file changed, 46 insertions(+), 58 deletions(-) diff --git a/common-lisp/src/reader.lisp b/common-lisp/src/reader.lisp index d088453476..5391b4dd89 100644 --- a/common-lisp/src/reader.lisp +++ b/common-lisp/src/reader.lisp @@ -31,7 +31,7 @@ ((context :initarg :context :reader context)) (:report (lambda (condition stream) (format stream - "EOF encountered while reading ~a" + "EOF encountered while reading '~a'" (context condition)))) (:documentation "Error raised when EOF is encountered while reading.")) @@ -98,17 +98,6 @@ raised" ")) (error 'eof :context "string"))) -(defun read-form-with-meta (reader) - (consume reader) - (let ((meta (read-form reader)) - (value (read-form reader))) - - (when (or (null meta) - (null value)) - (error 'eof :context "object metadata")) - - (make-mal-list (list (make-mal-symbol "with-meta") value meta)))) - (defun expand-quote (reader) (let ((quote-sym (make-mal-symbol (switch ((next reader) :test #'string=) ("'" "quote") @@ -118,66 +107,61 @@ raised" ("@" "deref"))))) (make-mal-list (list quote-sym (read-form reader))))) -(defun read-mal-sequence (reader &optional (delimiter ")") (constructor 'list)) - ;; Consume the opening brace - (consume reader) - (let (forms) - (loop - for token = (peek reader) - while (cond - ((null token) (error 'eof :context (if (string= delimiter ")") - "list" - "vector"))) - ((string= token delimiter) (return)) - (t (push (read-form reader) forms)))) +(defun read-mal-sequence (reader &optional (type 'list) &aux forms) + (let ((context (string-downcase (symbol-name type))) + (delimiter (if (equal type 'list) ")" "]"))) + + ;; Consume the opening brace + (consume reader) + + (setf forms (loop + until (string= (peek reader) delimiter) + collect (read-form-or-eof reader context))) + ;; Consume the closing brace (consume reader) - (apply constructor (nreverse forms)))) + + (apply type forms))) (defun read-hash-map (reader) - ;; Consume the open brace - (consume reader) - (let (forms - (hash-map (types:make-mal-value-hash-table))) + (let ((map (make-mal-value-hash-table)) + (context "hash-map")) + + ;; Consume the open brace + (consume reader) + (loop - for token = (peek reader) - while (cond - ((null token) (error 'eof :context "hash-map")) - ((string= token "}") (return)) - (t (let ((key (read-form reader)) - (value (read-form reader))) - (if (null value) - (error 'eof :context "hash-map") - (push (cons key value) forms)))))) + until (string= (peek reader) "}") + do (setf (hashref (read-form-or-eof reader context) map) + (read-form-or-eof reader context))) + ;; Consume the closing brace (consume reader) - ;; Construct the hash table - (dolist (key-value (nreverse forms)) - (setf (genhash:hashref (car key-value) hash-map) (cdr key-value))) - hash-map)) + + map)) (defun read-atom (reader) (let ((token (next reader))) - (cond - ((string= token "false") - mal-false) - ((string= token "true") - mal-true) - ((string= token "nil") - mal-nil) - ((char= (char token 0) #\") - (make-mal-string (parse-string token))) - ((char= (char token 0) #\:) - (make-mal-keyword token)) - ((scan *number-re* token) - (make-mal-number (read-from-string token))) - (t (make-mal-symbol token))))) + (cond ((string= token "false") mal-false) + ((string= token "true") mal-true) + ((string= token "nil") mal-nil) + ((char= (char token 0) #\") (make-mal-string (parse-string token))) + ((char= (char token 0) #\:) (make-mal-keyword token)) + ((scan *number-re* token) (make-mal-number (read-from-string token))) + (t (make-mal-symbol token))))) + +(defun read-form-with-meta (reader) + (consume reader) + + (let ((meta (read-form-or-eof reader "object meta")) + (value (read-form-or-eof reader "object meta"))) + (make-mal-list (list (make-mal-symbol "with-meta") value meta)))) (defun read-form (reader) (switch ((peek reader) :test #'equal) (nil nil) - ("(" (make-mal-list (read-mal-sequence reader ")" 'list))) - ("[" (make-mal-vector (read-mal-sequence reader "]" 'vector))) + ("(" (make-mal-list (read-mal-sequence reader 'list))) + ("[" (make-mal-vector (read-mal-sequence reader 'vector))) ("{" (make-mal-hash-map (read-hash-map reader))) ("^" (read-form-with-meta reader)) ("'" (expand-quote reader)) @@ -187,5 +171,9 @@ raised" ("@" (expand-quote reader)) (t (read-atom reader)))) +(defun read-form-or-eof (reader context) + (or (read-form reader) + (error 'eof :context context))) + (defun read-str (string) (read-form (make-token-reader :tokens (tokenize string)))) From a658bfa6d970ff401043db97855b4e85d8ccf3fe Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 13:15:00 +0530 Subject: [PATCH 0096/1998] Common Lisp: Use mal-nil and listify wherever applicable --- common-lisp/src/core.lisp | 38 ++++++++++++-------------------------- 1 file changed, 12 insertions(+), 26 deletions(-) diff --git a/common-lisp/src/core.lisp b/common-lisp/src/core.lisp index e333c8cdd4..03933d33ad 100644 --- a/common-lisp/src/core.lisp +++ b/common-lisp/src/core.lisp @@ -10,9 +10,7 @@ (in-package :core) (defmacro wrap-boolean (form) - `(if ,form - types:mal-true - types:mal-false)) + `(if ,form mal-true mal-false)) (define-condition index-error (types:mal-error) ((size :initarg :size :reader index-error-size) @@ -46,7 +44,7 @@ "~{~a~^ ~}" (mapcar (lambda (string) (printer:pr-str string t)) strings))) - (types:make-mal-nil nil)) + mal-nil) (defun mal-println (&rest strings) ;; Using write-line instead of (format *standard-output* ... ) since the later prints @@ -56,7 +54,7 @@ "~{~a~^ ~}" (mapcar (lambda (string) (printer:pr-str string nil)) strings))) - (types:make-mal-nil nil)) + mal-nil) (defun mal-pr-str (&rest strings) (types:make-mal-string (format nil @@ -131,10 +129,7 @@ args)))) (defun mal-cons (element list) - (types:make-mal-list (cons element - (map 'list - #'identity - (types:mal-data-value list))))) + (types:make-mal-list (cons element (listify (types:mal-data-value list))))) (defun mal-concat (&rest lists) (types:make-mal-list (apply #'concatenate @@ -143,37 +138,30 @@ (defun mal-nth (sequence index) (or (nth (types:mal-data-value index) - (map 'list #'identity (types:mal-data-value sequence))) + (listify (types:mal-data-value sequence))) (error 'index-error :size (length (types:mal-data-value sequence)) :index (types:mal-data-value index) :sequence sequence))) (defun mal-first (sequence) - (or (first (map 'list #'identity (types:mal-data-value sequence))) - (types:make-mal-nil nil))) + (or (first (listify (types:mal-data-value sequence))) mal-nil)) (defun mal-rest (sequence) - (types:make-mal-list (rest (map 'list - #'identity - (types:mal-data-value sequence))))) + (types:make-mal-list (rest (listify (types:mal-data-value sequence))))) (defun mal-throw (value) (error 'types:mal-user-exception :data value)) (defun mal-apply (fn &rest values) - (let ((final-arg (map 'list - #'identity - (types:mal-data-value (car (last values))))) - (butlast-args (butlast values))) + (let ((last (listify (types:mal-data-value (car (last values))))) + (butlast (butlast values))) (apply (types:mal-data-value fn) - (append butlast-args final-arg)))) + (append butlast last)))) (defun mal-map (fn sequence) - (let ((applicants (map 'list - #'identity - (types:mal-data-value sequence)))) + (let ((applicants (listify (types:mal-data-value sequence)))) (types:make-mal-list (mapcar (types:mal-data-value fn) applicants)))) @@ -311,9 +299,7 @@ (cond ((types:mal-list-p value) value) ((types:mal-vector-p value) - (types:make-mal-list (map 'list - #'identity - (types:mal-data-value value)))) + (types:make-mal-list (listify (types:mal-data-value value)))) ((types:mal-string-p value) (types:make-mal-list (map 'list (lambda (char) From 5de0a3ee95fb84dfdc5597a26413e9c295d9f6f6 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 13:15:48 +0530 Subject: [PATCH 0097/1998] Common Lisp: Do not export make-mal-boolean and make-mal-nil --- common-lisp/src/types.lisp | 2 -- 1 file changed, 2 deletions(-) diff --git a/common-lisp/src/types.lisp b/common-lisp/src/types.lisp index 2447da518b..700258171a 100644 --- a/common-lisp/src/types.lisp +++ b/common-lisp/src/types.lisp @@ -15,11 +15,9 @@ :mal-number-p :boolean - :make-mal-boolean :mal-boolean-p :nil - :make-mal-nil :mal-nil-p :string From f989ef2747425f63ce1c24601ca4bcbcc82f642c Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 13:49:24 +0530 Subject: [PATCH 0098/1998] Common Lisp: Abstract definition of mal level functions in defmal macro --- common-lisp/src/core.lisp | 375 +++++++++++++++++--------------------- 1 file changed, 163 insertions(+), 212 deletions(-) diff --git a/common-lisp/src/core.lisp b/common-lisp/src/core.lisp index 03933d33ad..a66929f128 100644 --- a/common-lisp/src/core.lisp +++ b/common-lisp/src/core.lisp @@ -4,14 +4,12 @@ :types :reader :printer - :genhash) + :genhash + :alexandria) (:export :ns)) (in-package :core) -(defmacro wrap-boolean (form) - `(if ,form mal-true mal-false)) - (define-condition index-error (types:mal-error) ((size :initarg :size :reader index-error-size) (index :initarg :index :reader index-error-index) @@ -23,20 +21,37 @@ (index-error-size condition) (index-error-index condition))))) -(defun mal-add (value1 value2) - (types:apply-unwrapped-values '+ value1 value2)) +(defmacro wrap-boolean (form) + `(if ,form mal-true mal-false)) + +(defvar ns nil) + +(defmacro defmal (name arglist &rest body) + (let* ((symbol-name (if (stringp name) + name + ;; Since common lisp intern all the symbols in + ;; uppercase (by default) we need to convert the + ;; symbol to lowercase while introducing it in MAL + ;; environment + (string-downcase (symbol-name name)))) + (internal-name (format nil "MAL-~a" (string-upcase symbol-name)))) + `(push (cons (make-mal-symbol ,symbol-name) + (make-mal-builtin-fn (defun ,(intern internal-name) ,arglist ,@body))) + ns))) -(defun mal-sub (value1 value2) - (types:apply-unwrapped-values '- value1 value2)) +(defmal + (value1 value2) + (apply-unwrapped-values '+ value1 value2)) -(defun mal-mul (value1 value2) - (types:apply-unwrapped-values '* value1 value2)) +(defmal - (value1 value2) + (apply-unwrapped-values '- value1 value2)) -(defun mal-div (value1 value2) - (types:make-mal-number (round (/ (types:mal-data-value value1) - (types:mal-data-value value2))))) +(defmal * (value1 value2) + (apply-unwrapped-values '* value1 value2)) -(defun mal-prn (&rest strings) +(defmal / (value1 value2) + (make-mal-number (round (/ (mal-data-value value1) (mal-data-value value2))))) + +(defmal prn (&rest strings) ;; Using write-line instead of (format *standard-output* ... ) since the later prints ;; and extra newline at start in GNU CLISP, if environment variable PERL_RL is true ;; or terminal is dumb @@ -46,7 +61,7 @@ strings))) mal-nil) -(defun mal-println (&rest strings) +(defmal println (&rest strings) ;; Using write-line instead of (format *standard-output* ... ) since the later prints ;; and extra newline at start in GNU CLISP, if environment variable PERL_RL is true ;; or terminal is dumb @@ -56,87 +71,75 @@ strings))) mal-nil) -(defun mal-pr-str (&rest strings) - (types:make-mal-string (format nil - "~{~a~^ ~}" - (mapcar (lambda (string) (printer:pr-str string t)) - strings)))) +(defmal pr-str (&rest strings) + (make-mal-string (format nil + "~{~a~^ ~}" + (mapcar (lambda (string) (printer:pr-str string t)) + strings)))) -(defun mal-str (&rest strings) - (types:make-mal-string (format nil - "~{~a~}" - (mapcar (lambda (string) (printer:pr-str string nil)) - strings)))) +(defmal str (&rest strings) + (make-mal-string (format nil + "~{~a~}" + (mapcar (lambda (string) (printer:pr-str string nil)) + strings)))) -(defun mal-list (&rest values) +(defmal list (&rest values) (make-mal-list values)) -(defun mal-list? (value) - (wrap-boolean (or (types:mal-nil-p value) - (types:mal-list-p value)))) +(defmal list? (value) + (wrap-boolean (or (types:mal-nil-p value) (types:mal-list-p value)))) -(defun mal-empty? (value) +(defmal empty? (value) (wrap-boolean (zerop (length (types:mal-data-value value))))) -(defun mal-length (value) +(defmal count (value) (types:apply-unwrapped-values 'length value)) -(defun mal-= (value1 value2) +(defmal = (value1 value2) (wrap-boolean (types:mal-data-value= value1 value2))) -(defun mal-< (value1 value2) - (types:apply-unwrapped-values-prefer-bool '< - value1 - value2)) +(defmal < (value1 value2) + (wrap-boolean (< (mal-data-value value1) (mal-data-value value2)))) -(defun mal-> (value1 value2) - (types:apply-unwrapped-values-prefer-bool '> - value1 - value2)) +(defmal > (value1 value2) + (wrap-boolean (> (mal-data-value value1) (mal-data-value value2)))) -(defun mal-<= (value1 value2) - (types:apply-unwrapped-values-prefer-bool '<= - value1 - value2)) +(defmal <= (value1 value2) + (wrap-boolean (<= (mal-data-value value1) (mal-data-value value2)))) -(defun mal->= (value1 value2) - (types:apply-unwrapped-values-prefer-bool '>= - value1 - value2)) +(defmal >= (value1 value2) + (wrap-boolean (>= (mal-data-value value1) (mal-data-value value2)))) -(defun mal-read-string (value) +(defmal read-string (value) (reader:read-str (types:mal-data-value value))) -(defun mal-slurp (filename) +(defmal slurp (filename) (types:apply-unwrapped-values 'read-file-string filename)) -(defun mal-atom (value) +(defmal atom (value) (types:make-mal-atom value)) -(defun mal-atom? (value) +(defmal atom? (value) (wrap-boolean (types:mal-atom-p value))) -(defun mal-deref (atom) +(defmal deref (atom) (types:mal-data-value atom)) -(defun mal-reset! (atom value) +(defmal reset! (atom value) (setf (types:mal-data-value atom) value)) -(defun mal-swap! (atom fn &rest args) +(defmal swap! (atom fn &rest args) (setf (types:mal-data-value atom) (apply (types:mal-data-value fn) - (append (list (types:mal-data-value atom)) - args)))) + (append (list (types:mal-data-value atom)) args)))) -(defun mal-cons (element list) +(defmal cons (element list) (types:make-mal-list (cons element (listify (types:mal-data-value list))))) -(defun mal-concat (&rest lists) - (types:make-mal-list (apply #'concatenate - 'list - (mapcar #'types:mal-data-value lists)))) +(defmal concat (&rest lists) + (types:make-mal-list (apply #'concatenate 'list (mapcar #'types:mal-data-value lists)))) -(defun mal-nth (sequence index) +(defmal nth (sequence index) (or (nth (types:mal-data-value index) (listify (types:mal-data-value sequence))) (error 'index-error @@ -144,70 +147,64 @@ :index (types:mal-data-value index) :sequence sequence))) -(defun mal-first (sequence) +(defmal first (sequence) (or (first (listify (types:mal-data-value sequence))) mal-nil)) -(defun mal-rest (sequence) +(defmal rest (sequence) (types:make-mal-list (rest (listify (types:mal-data-value sequence))))) -(defun mal-throw (value) - (error 'types:mal-user-exception - :data value)) +(defmal throw (value) + (error 'types:mal-user-exception :data value)) -(defun mal-apply (fn &rest values) +(defmal apply (fn &rest values) (let ((last (listify (types:mal-data-value (car (last values))))) (butlast (butlast values))) - (apply (types:mal-data-value fn) - (append butlast last)))) + (apply (types:mal-data-value fn) (append butlast last)))) -(defun mal-map (fn sequence) +(defmal map (fn sequence) (let ((applicants (listify (types:mal-data-value sequence)))) - (types:make-mal-list (mapcar (types:mal-data-value fn) - applicants)))) + (types:make-mal-list (mapcar (types:mal-data-value fn) applicants)))) -(defun mal-nil? (value) +(defmal nil? (value) (wrap-boolean (types:mal-nil-p value))) -(defun mal-true? (value) - (wrap-boolean (and (types:mal-boolean-p value) - (types:mal-data-value value)))) +(defmal true? (value) + (wrap-boolean (and (types:mal-boolean-p value) (types:mal-data-value value)))) -(defun mal-false? (value) - (wrap-boolean (and (types:mal-boolean-p value) - (not (types:mal-data-value value))))) +(defmal false? (value) + (wrap-boolean (and (types:mal-boolean-p value) (not (types:mal-data-value value))))) -(defun mal-symbol (string) +(defmal symbol (string) (types:make-mal-symbol (types:mal-data-value string))) -(defun mal-symbol? (value) +(defmal symbol? (value) (wrap-boolean (types:mal-symbol-p value))) -(defun mal-keyword (keyword) +(defmal keyword (keyword) (if (types:mal-keyword-p keyword) keyword (types:make-mal-keyword (format nil ":~a" (types:mal-data-value keyword))))) -(defun mal-keyword? (value) +(defmal keyword? (value) (wrap-boolean (types:mal-keyword-p value))) -(defun mal-vector (&rest elements) +(defmal vector (&rest elements) (types:make-mal-vector (map 'vector #'identity elements))) -(defun mal-vector? (value) +(defmal vector? (value) (wrap-boolean (types:mal-vector-p value))) -(defun mal-hash-map (&rest elements) +(defmal hash-map (&rest elements) (let ((hash-map (types:make-mal-value-hash-table))) - (loop - for (key value) on elements + (loop for (key value) on elements by #'cddr do (setf (genhash:hashref key hash-map) value)) (types:make-mal-hash-map hash-map))) -(defun mal-map? (value) +(defmal map? (value) (wrap-boolean (types:mal-hash-map-p value))) -(defun mal-assoc (hash-map &rest elements) +(defmal assoc (hash-map &rest elements) (let ((hash-map-value (types:mal-data-value hash-map)) (new-hash-map (types:make-mal-value-hash-table))) @@ -217,73 +214,71 @@ (genhash:hashref key hash-map-value))) hash-map-value) - (loop - for (key value) on elements + (loop for (key value) on elements by #'cddr do (setf (genhash:hashref key new-hash-map) value)) (types:make-mal-hash-map new-hash-map))) -(defun mal-dissoc (hash-map &rest elements) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-map (types:make-mal-value-hash-table))) +(defmal dissoc (hash-map &rest elements) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-map (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (declare (ignorable value)) - (when (not (member key - elements - :test #'types:mal-data-value=)) - (setf (genhash:hashref key new-hash-map) - (genhash:hashref key hash-map-value)))) - hash-map-value) - (types:make-mal-hash-map new-hash-map))) + (hashmap (lambda (key value) + (declare (ignorable value)) + (when (not (member key elements :test #'mal-data-value=)) + (setf (hashref key new-hash-map) + (hashref key hash-map-value)))) + hash-map-value) + + (make-mal-hash-map new-hash-map))) -(defun mal-get (hash-map key) - (or (and (types:mal-hash-map-p hash-map) - (genhash:hashref key (types:mal-data-value hash-map))) +(defmal get (hash-map key) + (or (and (types:mal-hash-map-p hash-map) (genhash:hashref key (types:mal-data-value hash-map))) types:mal-nil)) -(defun mal-contains? (hash-map key) - (if (genhash:hashref key (types:mal-data-value hash-map)) - types:mal-true - types:mal-false)) +(defmal contains? (hash-map key) + (if (genhash:hashref key (types:mal-data-value hash-map)) types:mal-true types:mal-false)) -(defun mal-keys (hash-map) +(defmal keys (hash-map) (let ((hash-map-value (types:mal-data-value hash-map)) keys) - (genhash:hashmap (lambda (key value) - (declare (ignorable value)) - (push key keys)) - hash-map-value) - (types:make-mal-list (nreverse keys)))) -(defun mal-vals (hash-map) + (hashmap (lambda (key value) + (declare (ignorable value)) + (push key keys)) + hash-map-value) + + (make-mal-list (nreverse keys)))) + +(defmal vals (hash-map) (let ((hash-map-value (types:mal-data-value hash-map)) values) - (genhash:hashmap (lambda (key value) - (declare (ignorable key)) - (push value values)) - hash-map-value) - (types:make-mal-list (nreverse values)))) -(defun mal-sequential? (value) - (wrap-boolean (or (types:mal-vector-p value) - (types:mal-list-p value)))) + (hashmap (lambda (key value) + (declare (ignorable key)) + (push value values)) + hash-map-value) + + (make-mal-list (nreverse values)))) -(defun mal-readline (prompt) +(defmal sequential? (value) + (wrap-boolean (or (types:mal-vector-p value) (types:mal-list-p value)))) + +(defmal readline (prompt) (format *standard-output* (types:mal-data-value prompt)) (force-output *standard-output*) (types:wrap-value (read-line *standard-input* nil))) -(defun mal-string? (value) +(defmal string? (value) (wrap-boolean (types:mal-string-p value))) -(defun mal-time-ms () +(defmal time-ms () (types:make-mal-number (round (/ (get-internal-real-time) (/ internal-time-units-per-second 1000))))) -(defun mal-conj (value &rest elements) +(defmal conj (value &rest elements) (cond ((types:mal-list-p value) (types:make-mal-list (append (nreverse elements) (types:mal-data-value value)))) @@ -293,21 +288,18 @@ elements))) (t (error 'types:mal-user-exception)))) -(defun mal-seq (value) - (if (zerop (length (types:mal-data-value value))) - types:mal-nil - (cond ((types:mal-list-p value) - value) - ((types:mal-vector-p value) - (types:make-mal-list (listify (types:mal-data-value value)))) - ((types:mal-string-p value) - (types:make-mal-list (map 'list - (lambda (char) - (types:make-mal-string (make-string 1 :initial-element char))) - (types:mal-data-value value)))) - (t (error 'types:mal-user-exception))))) - -(defun mal-with-meta (value meta) +(defmal seq (value) + (if (zerop (length (mal-data-value value))) + mal-nil + (cond ((mal-list-p value) value) + ((mal-vector-p value) + (make-mal-list (listify (mal-data-value value)))) + ((mal-string-p value) + (make-mal-list (mapcar (alexandria:compose #'make-mal-string #'string) + (coerce (mal-data-value value) 'list)))) + (t (error 'mal-user-exception))))) + +(defmal with-meta (value meta) (funcall (switch-mal-type value (types:string #'types:make-mal-string) (types:symbol #'types:make-mal-symbol) @@ -320,75 +312,34 @@ :meta meta :attrs (types:mal-data-attrs value))) -(defun mal-meta (value) - (or (types:mal-data-meta value) - types:mal-nil)) +(defmal meta (value) + (or (types:mal-data-meta value) types:mal-nil)) + +(defun wrap-value (value &optional booleanp listp) + (typecase value + (number (make-mal-number value)) + ;; This needs to be before symbol since nil is a symbol + (null (cond (booleanp mal-false) + (listp (make-mal-list value)) + (t mal-nil))) + ;; This needs to before symbol since t, nil are symbols + (boolean (if value mal-true mal-nil)) + (keyword (make-mal-keyword value)) + (symbol (make-mal-symbol (symbol-name value))) + (string (make-mal-string value)) + (list (make-mal-list (map 'list #'wrap-value value))) + (vector (make-mal-vector (map 'vector #'wrap-value value))) + (hash-table (make-mal-hash-map (let ((new-hash-table (make-mal-value-hash-table))) + (hashmap (lambda (key value) + (setf (hashref (wrap-value key) new-hash-table) + (wrap-value value))) + value) + new-hash-table))))) ;; Since a nil in Common LISP may mean an empty list or boolean false or ;; simply nil, the caller can specify the preferred type while evaluating an ;; expression -(defun mal-cl-eval (code &optional booleanp listp) +(defmal cl-eval (code &optional booleanp listp) (types:wrap-value (eval (read-from-string (types:mal-data-value code))) :booleanp (and booleanp (types:mal-data-value booleanp)) :listp (and listp (types:mal-data-value listp)))) - -(defvar ns - (list - (cons (types:make-mal-symbol "+") (types:make-mal-builtin-fn #'mal-add)) - (cons (types:make-mal-symbol "-") (types:make-mal-builtin-fn #'mal-sub)) - (cons (types:make-mal-symbol "*") (types:make-mal-builtin-fn #'mal-mul)) - (cons (types:make-mal-symbol "/") (types:make-mal-builtin-fn #'mal-div)) - (cons (types:make-mal-symbol "prn") (types:make-mal-builtin-fn #'mal-prn)) - (cons (types:make-mal-symbol "println") (types:make-mal-builtin-fn #'mal-println)) - (cons (types:make-mal-symbol "pr-str") (types:make-mal-builtin-fn #'mal-pr-str)) - (cons (types:make-mal-symbol "str") (types:make-mal-builtin-fn #'mal-str)) - (cons (types:make-mal-symbol "list") (types:make-mal-builtin-fn #'mal-list)) - (cons (types:make-mal-symbol "list?") (types:make-mal-builtin-fn #'mal-list?)) - (cons (types:make-mal-symbol "empty?") (types:make-mal-builtin-fn #'mal-empty?)) - (cons (types:make-mal-symbol "count") (types:make-mal-builtin-fn #'mal-length)) - (cons (types:make-mal-symbol "=") (types:make-mal-builtin-fn #'mal-=)) - (cons (types:make-mal-symbol "<") (types:make-mal-builtin-fn #'mal-<)) - (cons (types:make-mal-symbol ">") (types:make-mal-builtin-fn #'mal->)) - (cons (types:make-mal-symbol "<=") (types:make-mal-builtin-fn #'mal-<=)) - (cons (types:make-mal-symbol ">=") (types:make-mal-builtin-fn #'mal->=)) - (cons (types:make-mal-symbol "read-string") (types:make-mal-builtin-fn #'mal-read-string)) - (cons (types:make-mal-symbol "slurp") (types:make-mal-builtin-fn #'mal-slurp)) - (cons (types:make-mal-symbol "atom") (types:make-mal-builtin-fn #'mal-atom)) - (cons (types:make-mal-symbol "atom?") (types:make-mal-builtin-fn #'mal-atom?)) - (cons (types:make-mal-symbol "deref") (types:make-mal-builtin-fn #'mal-deref)) - (cons (types:make-mal-symbol "reset!") (types:make-mal-builtin-fn #'mal-reset!)) - (cons (types:make-mal-symbol "swap!") (types:make-mal-builtin-fn #'mal-swap!)) - (cons (types:make-mal-symbol "cons") (types:make-mal-builtin-fn #'mal-cons)) - (cons (types:make-mal-symbol "concat") (types:make-mal-builtin-fn #'mal-concat)) - (cons (types:make-mal-symbol "nth") (types:make-mal-builtin-fn #'mal-nth)) - (cons (types:make-mal-symbol "first") (types:make-mal-builtin-fn #'mal-first)) - (cons (types:make-mal-symbol "rest") (types:make-mal-builtin-fn #'mal-rest)) - (cons (types:make-mal-symbol "throw") (types:make-mal-builtin-fn #'mal-throw)) - (cons (types:make-mal-symbol "apply") (types:make-mal-builtin-fn #'mal-apply)) - (cons (types:make-mal-symbol "map") (types:make-mal-builtin-fn #'mal-map)) - (cons (types:make-mal-symbol "nil?") (types:make-mal-builtin-fn #'mal-nil?)) - (cons (types:make-mal-symbol "true?") (types:make-mal-builtin-fn #'mal-true?)) - (cons (types:make-mal-symbol "false?") (types:make-mal-builtin-fn #'mal-false?)) - (cons (types:make-mal-symbol "symbol") (types:make-mal-builtin-fn #'mal-symbol)) - (cons (types:make-mal-symbol "symbol?") (types:make-mal-builtin-fn #'mal-symbol?)) - (cons (types:make-mal-symbol "keyword") (types:make-mal-builtin-fn #'mal-keyword)) - (cons (types:make-mal-symbol "keyword?") (types:make-mal-builtin-fn #'mal-keyword?)) - (cons (types:make-mal-symbol "vector") (types:make-mal-builtin-fn #'mal-vector)) - (cons (types:make-mal-symbol "vector?") (types:make-mal-builtin-fn #'mal-vector?)) - (cons (types:make-mal-symbol "hash-map") (types:make-mal-builtin-fn #'mal-hash-map)) - (cons (types:make-mal-symbol "map?") (types:make-mal-builtin-fn #'mal-map?)) - (cons (types:make-mal-symbol "assoc") (types:make-mal-builtin-fn #'mal-assoc)) - (cons (types:make-mal-symbol "dissoc") (types:make-mal-builtin-fn #'mal-dissoc)) - (cons (types:make-mal-symbol "get") (types:make-mal-builtin-fn #'mal-get)) - (cons (types:make-mal-symbol "contains?") (types:make-mal-builtin-fn #'mal-contains?)) - (cons (types:make-mal-symbol "keys") (types:make-mal-builtin-fn #'mal-keys)) - (cons (types:make-mal-symbol "vals") (types:make-mal-builtin-fn #'mal-vals)) - (cons (types:make-mal-symbol "sequential?") (types:make-mal-builtin-fn #'mal-sequential?)) - (cons (types:make-mal-symbol "readline") (types:make-mal-builtin-fn #'mal-readline)) - (cons (types:make-mal-symbol "string?") (types:make-mal-builtin-fn #'mal-string?)) - (cons (types:make-mal-symbol "time-ms") (types:make-mal-builtin-fn #'mal-time-ms)) - (cons (types:make-mal-symbol "conj") (types:make-mal-builtin-fn #'mal-conj)) - (cons (types:make-mal-symbol "seq") (types:make-mal-builtin-fn #'mal-seq)) - (cons (types:make-mal-symbol "with-meta") (types:make-mal-builtin-fn #'mal-with-meta)) - (cons (types:make-mal-symbol "meta") (types:make-mal-builtin-fn #'mal-meta)) - (cons (types:make-mal-symbol "cl-eval") (types:make-mal-builtin-fn #'mal-cl-eval)))) From 8202dbf815defba66d4af9c7a0b84bd6cb15dde6 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 16:01:11 +0530 Subject: [PATCH 0099/1998] Common Lisp: Get rid of apply-uwrapped-values and friends --- common-lisp/src/core.lisp | 18 +++++------ common-lisp/src/step2_eval.lisp | 20 +++++-------- common-lisp/src/step3_env.lisp | 20 +++++-------- common-lisp/src/step6_file.lisp | 2 +- common-lisp/src/step7_quote.lisp | 2 +- common-lisp/src/step8_macros.lisp | 2 +- common-lisp/src/step9_try.lisp | 2 +- common-lisp/src/stepA_mal.lisp | 6 ++-- common-lisp/src/types.lisp | 50 +------------------------------ 9 files changed, 33 insertions(+), 89 deletions(-) diff --git a/common-lisp/src/core.lisp b/common-lisp/src/core.lisp index a66929f128..e8a4efcf01 100644 --- a/common-lisp/src/core.lisp +++ b/common-lisp/src/core.lisp @@ -40,13 +40,13 @@ ns))) (defmal + (value1 value2) - (apply-unwrapped-values '+ value1 value2)) + (make-mal-number (+ (mal-data-value value1) (mal-data-value value2)))) (defmal - (value1 value2) - (apply-unwrapped-values '- value1 value2)) + (make-mal-number (- (mal-data-value value1) (mal-data-value value2)))) (defmal * (value1 value2) - (apply-unwrapped-values '* value1 value2)) + (make-mal-number (* (mal-data-value value1) (mal-data-value value2)))) (defmal / (value1 value2) (make-mal-number (round (/ (mal-data-value value1) (mal-data-value value2))))) @@ -93,7 +93,7 @@ (wrap-boolean (zerop (length (types:mal-data-value value))))) (defmal count (value) - (types:apply-unwrapped-values 'length value)) + (make-mal-number (length (mal-data-value value)))) (defmal = (value1 value2) (wrap-boolean (types:mal-data-value= value1 value2))) @@ -114,7 +114,7 @@ (reader:read-str (types:mal-data-value value))) (defmal slurp (filename) - (types:apply-unwrapped-values 'read-file-string filename)) + (make-mal-string (read-file-string (mal-data-value filename)))) (defmal atom (value) (types:make-mal-atom value)) @@ -268,7 +268,7 @@ (defmal readline (prompt) (format *standard-output* (types:mal-data-value prompt)) (force-output *standard-output*) - (types:wrap-value (read-line *standard-input* nil))) + (make-mal-string (read-line *standard-input* nil))) (defmal string? (value) (wrap-boolean (types:mal-string-p value))) @@ -340,6 +340,6 @@ ;; simply nil, the caller can specify the preferred type while evaluating an ;; expression (defmal cl-eval (code &optional booleanp listp) - (types:wrap-value (eval (read-from-string (types:mal-data-value code))) - :booleanp (and booleanp (types:mal-data-value booleanp)) - :listp (and listp (types:mal-data-value listp)))) + (wrap-value (eval (read-from-string (mal-data-value code))) + (and booleanp (mal-data-value booleanp)) + (and listp (mal-data-value listp)))) diff --git a/common-lisp/src/step2_eval.lisp b/common-lisp/src/step2_eval.lisp index e3d33b5a31..70fbf4d5d8 100644 --- a/common-lisp/src/step2_eval.lisp +++ b/common-lisp/src/step2_eval.lisp @@ -17,27 +17,23 @@ (setf (genhash:hashref (types:make-mal-symbol "+") *repl-env*) (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '+ - value1 - value2)))) + (make-mal-number (+ (mal-data-value value1) + (mal-data-value value2)))))) (setf (genhash:hashref (types:make-mal-symbol "-") *repl-env*) (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '- - value1 - value2)))) + (make-mal-number (- (mal-data-value value1) + (mal-data-value value2)))))) (setf (genhash:hashref (types:make-mal-symbol "*") *repl-env*) (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '* - value1 - value2)))) + (make-mal-number (* (mal-data-value value1) + (mal-data-value value2)))))) (setf (genhash:hashref (types:make-mal-symbol "/") *repl-env*) (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '/ - value1 - value2)))) + (make-mal-number (/ (mal-data-value value1) + (mal-data-value value2)))))) (defun lookup-env (symbol env) (let ((value (genhash:hashref symbol env))) diff --git a/common-lisp/src/step3_env.lisp b/common-lisp/src/step3_env.lisp index 3365a72f65..d988f12c41 100644 --- a/common-lisp/src/step3_env.lisp +++ b/common-lisp/src/step3_env.lisp @@ -19,30 +19,26 @@ (env:set-env *repl-env* (types:make-mal-symbol "+") (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '+ - value1 - value2)))) + (make-mal-number (+ (mal-data-value value1) + (mal-data-value value2)))))) (env:set-env *repl-env* (types:make-mal-symbol "-") (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '- - value1 - value2)))) + (make-mal-number (- (mal-data-value value1) + (mal-data-value value2)))))) (env:set-env *repl-env* (types:make-mal-symbol "*") (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '* - value1 - value2)))) + (make-mal-number (* (mal-data-value value1) + (mal-data-value value2)))))) (env:set-env *repl-env* (types:make-mal-symbol "/") (types:make-mal-builtin-fn (lambda (value1 value2) - (types:apply-unwrapped-values '/ - value1 - value2)))) + (make-mal-number (/ (mal-data-value value1) + (mal-data-value value2)))))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) diff --git a/common-lisp/src/step6_file.lisp b/common-lisp/src/step6_file.lisp index b474aac53c..e9585c63b2 100644 --- a/common-lisp/src/step6_file.lisp +++ b/common-lisp/src/step6_file.lisp @@ -190,7 +190,7 @@ (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* (types:make-mal-symbol "*ARGV*") - (types:wrap-value (cdr args) :listp t)) + (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) (run-file (car args))))) diff --git a/common-lisp/src/step7_quote.lisp b/common-lisp/src/step7_quote.lisp index 26d4a57ba6..46ab36c369 100644 --- a/common-lisp/src/step7_quote.lisp +++ b/common-lisp/src/step7_quote.lisp @@ -226,7 +226,7 @@ (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* (types:make-mal-symbol "*ARGV*") - (types:wrap-value (cdr args) :listp t)) + (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) (run-file (car args))))) diff --git a/common-lisp/src/step8_macros.lisp b/common-lisp/src/step8_macros.lisp index 4ae36f87b2..805de19516 100644 --- a/common-lisp/src/step8_macros.lisp +++ b/common-lisp/src/step8_macros.lisp @@ -285,7 +285,7 @@ (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* (types:make-mal-symbol "*ARGV*") - (types:wrap-value (cdr args) :listp t)) + (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) (run-file (car args))))) diff --git a/common-lisp/src/step9_try.lisp b/common-lisp/src/step9_try.lisp index c03be8f2af..ecccf8ebbc 100644 --- a/common-lisp/src/step9_try.lisp +++ b/common-lisp/src/step9_try.lisp @@ -313,7 +313,7 @@ (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* (types:make-mal-symbol "*ARGV*") - (types:wrap-value (cdr args) :listp t)) + (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) (run-file (car args))))) diff --git a/common-lisp/src/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp index fa629aa7ac..628e675a31 100644 --- a/common-lisp/src/stepA_mal.lisp +++ b/common-lisp/src/stepA_mal.lisp @@ -260,11 +260,11 @@ (env:set-env *repl-env* (types:make-mal-symbol "*cl-implementation*") - (types:wrap-value (lisp-implementation-type))) + (make-mal-string (lisp-implementation-type))) (env:set-env *repl-env* (types:make-mal-symbol "*cl-version*") - (types:wrap-value (lisp-implementation-version))) + (make-mal-string (lisp-implementation-version))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -325,7 +325,7 @@ (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* (types:make-mal-symbol "*ARGV*") - (types:wrap-value (cdr args) :listp t)) + (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) (run-file (car args))))) diff --git a/common-lisp/src/types.lisp b/common-lisp/src/types.lisp index 700258171a..a6c3830230 100644 --- a/common-lisp/src/types.lisp +++ b/common-lisp/src/types.lisp @@ -73,13 +73,7 @@ ;; Exception raised by user code :mal-user-exception ;; Error - :mal-error - - ;; Utilities - :wrap-value - :unwrap-value - :apply-unwrapped-values - :apply-unwrapped-values-prefer-bool)) + :mal-error)) (in-package :types) @@ -201,45 +195,3 @@ hash-function #'mal-data-value=))) (genhash:make-generic-hash-table :test 'mal-data-value-hash)) - -(defun wrap-value (value &key booleanp listp) - (typecase value - (number (make-mal-number value)) - ;; This needs to be before symbol since nil is a symbol - (null (funcall (cond - (booleanp #'make-mal-boolean) - (listp #'make-mal-list) - (t #'make-mal-nil)) - value)) - ;; This needs to before symbol since t, nil are symbols - (boolean (make-mal-boolean value)) - (keyword (make-mal-keyword value)) - (symbol (make-mal-symbol (symbol-name value))) - (string (make-mal-string value)) - (list (make-mal-list (map 'list #'wrap-value value))) - (vector (make-mal-vector (map 'vector #'wrap-value value))) - (hash-table (make-mal-hash-map (let ((new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref (wrap-value key) new-hash-table) - (wrap-value value))) - value) - new-hash-table))))) - -(defun unwrap-value (value) - (switch-mal-type value - (list (mapcar #'unwrap-value (mal-data-value value))) - (vector (map 'vector #'unwrap-value (mal-data-value value))) - (hash-map (let ((hash-table (make-hash-table)) - (hash-map-value (mal-data-value value))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref (mal-data-value key) hash-table) - (mal-data-value value))) - hash-map-value) - hash-table)) - (any (mal-data-value value)))) - -(defun apply-unwrapped-values (op &rest values) - (wrap-value (apply op (mapcar #'unwrap-value values)))) - -(defun apply-unwrapped-values-prefer-bool (op &rest values) - (wrap-value (apply op (mapcar #'unwrap-value values)) :booleanp t)) From baa3c3af1a0176993ac22fabdad3a8805563a89f Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 16:18:31 +0530 Subject: [PATCH 0100/1998] Common Lisp: Do not prefix symbols with package name unnecessarily --- common-lisp/src/core.lisp | 148 ++++++++++----------- common-lisp/src/env.lisp | 8 +- common-lisp/src/printer.lisp | 30 ++--- common-lisp/src/step0_repl.lisp | 2 +- common-lisp/src/step1_read_print.lisp | 9 +- common-lisp/src/step2_eval.lisp | 43 +++---- common-lisp/src/step3_env.lisp | 59 ++++----- common-lisp/src/step4_if_fn_do.lisp | 37 +++--- common-lisp/src/step5_tco.lisp | 51 ++++---- common-lisp/src/step6_file.lisp | 47 +++---- common-lisp/src/step7_quote.lisp | 77 +++++------ common-lisp/src/step8_macros.lisp | 141 ++++++++++---------- common-lisp/src/step9_try.lisp | 173 ++++++++++++------------- common-lisp/src/stepA_mal.lisp | 178 ++++++++++++-------------- common-lisp/src/types.lisp | 52 ++++---- 15 files changed, 488 insertions(+), 567 deletions(-) diff --git a/common-lisp/src/core.lisp b/common-lisp/src/core.lisp index e8a4efcf01..06c7a03596 100644 --- a/common-lisp/src/core.lisp +++ b/common-lisp/src/core.lisp @@ -10,7 +10,7 @@ (in-package :core) -(define-condition index-error (types:mal-error) +(define-condition index-error (mal-error) ((size :initarg :size :reader index-error-size) (index :initarg :index :reader index-error-index) (sequence :initarg :sequence :reader index-error-sequence)) @@ -87,16 +87,16 @@ (make-mal-list values)) (defmal list? (value) - (wrap-boolean (or (types:mal-nil-p value) (types:mal-list-p value)))) + (wrap-boolean (or (mal-nil-p value) (mal-list-p value)))) (defmal empty? (value) - (wrap-boolean (zerop (length (types:mal-data-value value))))) + (wrap-boolean (zerop (length (mal-data-value value))))) (defmal count (value) (make-mal-number (length (mal-data-value value)))) (defmal = (value1 value2) - (wrap-boolean (types:mal-data-value= value1 value2))) + (wrap-boolean (mal-data-value= value1 value2))) (defmal < (value1 value2) (wrap-boolean (< (mal-data-value value1) (mal-data-value value2)))) @@ -111,114 +111,114 @@ (wrap-boolean (>= (mal-data-value value1) (mal-data-value value2)))) (defmal read-string (value) - (reader:read-str (types:mal-data-value value))) + (reader:read-str (mal-data-value value))) (defmal slurp (filename) (make-mal-string (read-file-string (mal-data-value filename)))) (defmal atom (value) - (types:make-mal-atom value)) + (make-mal-atom value)) (defmal atom? (value) - (wrap-boolean (types:mal-atom-p value))) + (wrap-boolean (mal-atom-p value))) (defmal deref (atom) - (types:mal-data-value atom)) + (mal-data-value atom)) (defmal reset! (atom value) - (setf (types:mal-data-value atom) value)) + (setf (mal-data-value atom) value)) (defmal swap! (atom fn &rest args) - (setf (types:mal-data-value atom) - (apply (types:mal-data-value fn) - (append (list (types:mal-data-value atom)) args)))) + (setf (mal-data-value atom) + (apply (mal-data-value fn) + (append (list (mal-data-value atom)) args)))) (defmal cons (element list) - (types:make-mal-list (cons element (listify (types:mal-data-value list))))) + (make-mal-list (cons element (listify (mal-data-value list))))) (defmal concat (&rest lists) - (types:make-mal-list (apply #'concatenate 'list (mapcar #'types:mal-data-value lists)))) + (make-mal-list (apply #'concatenate 'list (mapcar #'mal-data-value lists)))) (defmal nth (sequence index) - (or (nth (types:mal-data-value index) - (listify (types:mal-data-value sequence))) + (or (nth (mal-data-value index) + (listify (mal-data-value sequence))) (error 'index-error - :size (length (types:mal-data-value sequence)) - :index (types:mal-data-value index) + :size (length (mal-data-value sequence)) + :index (mal-data-value index) :sequence sequence))) (defmal first (sequence) - (or (first (listify (types:mal-data-value sequence))) mal-nil)) + (or (first (listify (mal-data-value sequence))) mal-nil)) (defmal rest (sequence) - (types:make-mal-list (rest (listify (types:mal-data-value sequence))))) + (make-mal-list (rest (listify (mal-data-value sequence))))) (defmal throw (value) - (error 'types:mal-user-exception :data value)) + (error 'mal-user-exception :data value)) (defmal apply (fn &rest values) - (let ((last (listify (types:mal-data-value (car (last values))))) + (let ((last (listify (mal-data-value (car (last values))))) (butlast (butlast values))) - (apply (types:mal-data-value fn) (append butlast last)))) + (apply (mal-data-value fn) (append butlast last)))) (defmal map (fn sequence) - (let ((applicants (listify (types:mal-data-value sequence)))) - (types:make-mal-list (mapcar (types:mal-data-value fn) applicants)))) + (let ((applicants (listify (mal-data-value sequence)))) + (make-mal-list (mapcar (mal-data-value fn) applicants)))) (defmal nil? (value) - (wrap-boolean (types:mal-nil-p value))) + (wrap-boolean (mal-nil-p value))) (defmal true? (value) - (wrap-boolean (and (types:mal-boolean-p value) (types:mal-data-value value)))) + (wrap-boolean (and (mal-boolean-p value) (mal-data-value value)))) (defmal false? (value) - (wrap-boolean (and (types:mal-boolean-p value) (not (types:mal-data-value value))))) + (wrap-boolean (and (mal-boolean-p value) (not (mal-data-value value))))) (defmal symbol (string) - (types:make-mal-symbol (types:mal-data-value string))) + (make-mal-symbol (mal-data-value string))) (defmal symbol? (value) - (wrap-boolean (types:mal-symbol-p value))) + (wrap-boolean (mal-symbol-p value))) (defmal keyword (keyword) - (if (types:mal-keyword-p keyword) + (if (mal-keyword-p keyword) keyword - (types:make-mal-keyword (format nil ":~a" (types:mal-data-value keyword))))) + (make-mal-keyword (format nil ":~a" (mal-data-value keyword))))) (defmal keyword? (value) - (wrap-boolean (types:mal-keyword-p value))) + (wrap-boolean (mal-keyword-p value))) (defmal vector (&rest elements) - (types:make-mal-vector (map 'vector #'identity elements))) + (make-mal-vector (map 'vector #'identity elements))) (defmal vector? (value) - (wrap-boolean (types:mal-vector-p value))) + (wrap-boolean (mal-vector-p value))) (defmal hash-map (&rest elements) - (let ((hash-map (types:make-mal-value-hash-table))) + (let ((hash-map (make-mal-value-hash-table))) (loop for (key value) on elements by #'cddr - do (setf (genhash:hashref key hash-map) value)) - (types:make-mal-hash-map hash-map))) + do (setf (hashref key hash-map) value)) + (make-mal-hash-map hash-map))) (defmal map? (value) - (wrap-boolean (types:mal-hash-map-p value))) + (wrap-boolean (mal-hash-map-p value))) (defmal assoc (hash-map &rest elements) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-map (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-map (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (declare (ignorable value)) - (setf (genhash:hashref key new-hash-map) - (genhash:hashref key hash-map-value))) - hash-map-value) + (hashmap (lambda (key value) + (declare (ignorable value)) + (setf (hashref key new-hash-map) + (hashref key hash-map-value))) + hash-map-value) (loop for (key value) on elements by #'cddr - do (setf (genhash:hashref key new-hash-map) value)) + do (setf (hashref key new-hash-map) value)) - (types:make-mal-hash-map new-hash-map))) + (make-mal-hash-map new-hash-map))) (defmal dissoc (hash-map &rest elements) (let ((hash-map-value (mal-data-value hash-map)) @@ -234,14 +234,14 @@ (make-mal-hash-map new-hash-map))) (defmal get (hash-map key) - (or (and (types:mal-hash-map-p hash-map) (genhash:hashref key (types:mal-data-value hash-map))) + (or (and (mal-hash-map-p hash-map) (hashref key (mal-data-value hash-map))) types:mal-nil)) (defmal contains? (hash-map key) (if (genhash:hashref key (types:mal-data-value hash-map)) types:mal-true types:mal-false)) (defmal keys (hash-map) - (let ((hash-map-value (types:mal-data-value hash-map)) + (let ((hash-map-value (mal-data-value hash-map)) keys) (hashmap (lambda (key value) @@ -252,7 +252,7 @@ (make-mal-list (nreverse keys)))) (defmal vals (hash-map) - (let ((hash-map-value (types:mal-data-value hash-map)) + (let ((hash-map-value (mal-data-value hash-map)) values) (hashmap (lambda (key value) @@ -263,30 +263,30 @@ (make-mal-list (nreverse values)))) (defmal sequential? (value) - (wrap-boolean (or (types:mal-vector-p value) (types:mal-list-p value)))) + (wrap-boolean (or (mal-vector-p value) (mal-list-p value)))) (defmal readline (prompt) - (format *standard-output* (types:mal-data-value prompt)) + (format *standard-output* (mal-data-value prompt)) (force-output *standard-output*) (make-mal-string (read-line *standard-input* nil))) (defmal string? (value) - (wrap-boolean (types:mal-string-p value))) + (wrap-boolean (mal-string-p value))) (defmal time-ms () - (types:make-mal-number (round (/ (get-internal-real-time) - (/ internal-time-units-per-second - 1000))))) + (make-mal-number (round (/ (get-internal-real-time) + (/ internal-time-units-per-second + 1000))))) (defmal conj (value &rest elements) - (cond ((types:mal-list-p value) - (types:make-mal-list (append (nreverse elements) - (types:mal-data-value value)))) - ((types:mal-vector-p value) - (types:make-mal-vector (concatenate 'vector - (types:mal-data-value value) - elements))) - (t (error 'types:mal-user-exception)))) + (cond ((mal-list-p value) + (make-mal-list (append (nreverse elements) + (mal-data-value value)))) + ((mal-vector-p value) + (make-mal-vector (concatenate 'vector + (mal-data-value value) + elements))) + (t (error 'mal-user-exception)))) (defmal seq (value) (if (zerop (length (mal-data-value value))) @@ -301,16 +301,16 @@ (defmal with-meta (value meta) (funcall (switch-mal-type value - (types:string #'types:make-mal-string) - (types:symbol #'types:make-mal-symbol) - (types:list #'types:make-mal-list) - (types:vector #'types:make-mal-vector) - (types:hash-map #'types:make-mal-hash-map) - (types:fn #'types:make-mal-fn) - (types:builtin-fn #'types:make-mal-builtin-fn)) - (types:mal-data-value value) + (types:string #'make-mal-string) + (types:symbol #'make-mal-symbol) + (types:list #'make-mal-list) + (types:vector #'make-mal-vector) + (types:hash-map #'make-mal-hash-map) + (types:fn #'make-mal-fn) + (types:builtin-fn #'make-mal-builtin-fn)) + (mal-data-value value) :meta meta - :attrs (types:mal-data-attrs value))) + :attrs (mal-data-attrs value))) (defmal meta (value) (or (types:mal-data-meta value) types:mal-nil)) diff --git a/common-lisp/src/env.lisp b/common-lisp/src/env.lisp index b28d984189..0a2ff05cae 100644 --- a/common-lisp/src/env.lisp +++ b/common-lisp/src/env.lisp @@ -9,14 +9,14 @@ (in-package :env) -(define-condition undefined-symbol (types:mal-runtime-exception) +(define-condition undefined-symbol (mal-runtime-exception) ((symbol :initarg :symbol :reader symbol)) (:report (lambda (condition stream) (format stream "'~a' not found" (symbol condition))))) -(define-condition arity-mismatch (types:mal-runtime-exception) +(define-condition arity-mismatch (mal-runtime-exception) ((required :initarg :required :reader required) (provided :initarg :provided :reader provided)) (:report (lambda (condition stream) @@ -41,9 +41,7 @@ :symbol (format nil "~a" (mal-data-value symbol))))) (defun set-env (env symbol value) - (setf (gethash (types:mal-data-value symbol) - (mal-env-bindings env)) - value)) + (setf (gethash (mal-data-value symbol) (mal-env-bindings env)) value)) (defun create-mal-env (&key parent binds exprs) (let ((env (make-mal-env :parent parent)) diff --git a/common-lisp/src/printer.lisp b/common-lisp/src/printer.lisp index a6833d0ef8..e6c8de6651 100644 --- a/common-lisp/src/printer.lisp +++ b/common-lisp/src/printer.lisp @@ -18,36 +18,36 @@ start-delimiter (mapcar (lambda (value) (pr-str value print-readably)) - (utils:listify (types:mal-data-value sequence))) + (listify (mal-data-value sequence))) end-delimiter)) (defun pr-mal-hash-map (hash-map &optional (print-readably t) &aux repr) - (genhash:hashmap (lambda (key value) - (push (pr-str value print-readably) repr) - (push (pr-str key print-readably) repr)) - (types:mal-data-value hash-map)) + (hashmap (lambda (key value) + (push (pr-str value print-readably) repr) + (push (pr-str key print-readably) repr)) + (mal-data-value hash-map)) (format nil "{~{~a ~a~^ ~}}" repr)) (defun pr-string (ast &optional (print-readably t)) - (if print-readably - (utils:replace-all (prin1-to-string (types:mal-data-value ast)) - " + (if print-readably + (replace-all (prin1-to-string (mal-data-value ast)) + " " - "\\n") - (types:mal-data-value ast))) + "\\n") + (mal-data-value ast))) (defun pr-str (ast &optional (print-readably t)) (when ast (switch-mal-type ast - (types:number (format nil "~d" (types:mal-data-value ast))) - (types:boolean (if (types:mal-data-value ast) "true" "false")) + (types:number (format nil "~d" (mal-data-value ast))) + (types:boolean (if (mal-data-value ast) "true" "false")) (types:nil "nil") (types:string (pr-string ast print-readably)) - (types:symbol (format nil "~a" (types:mal-data-value ast))) - (types:keyword (format nil "~a" (types:mal-data-value ast))) + (types:symbol (format nil "~a" (mal-data-value ast))) + (types:keyword (format nil "~a" (mal-data-value ast))) (types:list (pr-mal-sequence "(" ast ")" print-readably)) (types:vector (pr-mal-sequence "[" ast "]" print-readably)) (types:hash-map (pr-mal-hash-map ast print-readably)) - (types:atom (format nil "(atom ~a)" (pr-str (types:mal-data-value ast)))) + (types:atom (format nil "(atom ~a)" (pr-str (mal-data-value ast)))) (types:builtin-fn "#") (types:builtin-fn "#")))) diff --git a/common-lisp/src/step0_repl.lisp b/common-lisp/src/step0_repl.lisp index c881dd5a75..79d180056d 100644 --- a/common-lisp/src/step0_repl.lisp +++ b/common-lisp/src/step0_repl.lisp @@ -27,7 +27,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) diff --git a/common-lisp/src/step1_read_print.lisp b/common-lisp/src/step1_read_print.lisp index b16578b629..1c0bd248a2 100644 --- a/common-lisp/src/step1_read_print.lisp +++ b/common-lisp/src/step1_read_print.lisp @@ -20,12 +20,9 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - (make-hash-table :test #'equal))) + (mal-print (mal-eval (mal-read string) (make-hash-table :test #'equal))) (reader:eof (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (defvar *use-readline-p* nil) @@ -36,7 +33,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) diff --git a/common-lisp/src/step2_eval.lisp b/common-lisp/src/step2_eval.lisp index 70fbf4d5d8..ecfaedb4b4 100644 --- a/common-lisp/src/step2_eval.lisp +++ b/common-lisp/src/step2_eval.lisp @@ -13,25 +13,25 @@ (in-package :mal) -(defvar *repl-env* (types:make-mal-value-hash-table)) +(defvar *repl-env* (make-mal-value-hash-table)) -(setf (genhash:hashref (types:make-mal-symbol "+") *repl-env*) - (types:make-mal-builtin-fn (lambda (value1 value2) +(setf (genhash:hashref (make-mal-symbol "+") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) (make-mal-number (+ (mal-data-value value1) (mal-data-value value2)))))) -(setf (genhash:hashref (types:make-mal-symbol "-") *repl-env*) - (types:make-mal-builtin-fn (lambda (value1 value2) +(setf (genhash:hashref (make-mal-symbol "-") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) (make-mal-number (- (mal-data-value value1) (mal-data-value value2)))))) -(setf (genhash:hashref (types:make-mal-symbol "*") *repl-env*) - (types:make-mal-builtin-fn (lambda (value1 value2) +(setf (genhash:hashref (make-mal-symbol "*") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) (make-mal-number (* (mal-data-value value1) (mal-data-value value2)))))) -(setf (genhash:hashref (types:make-mal-symbol "/") *repl-env*) - (types:make-mal-builtin-fn (lambda (value1 value2) +(setf (genhash:hashref (make-mal-symbol "/") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) (make-mal-number (/ (mal-data-value value1) (mal-data-value value2)))))) @@ -40,21 +40,21 @@ (if value value (error 'env:undefined-symbol - :symbol (format nil "~a" (types:mal-data-value symbol)))))) + :symbol (format nil "~a" (mal-data-value symbol)))))) (defun eval-sequence (sequence env) (map 'list (lambda (ast) (mal-eval ast env)) - (types:mal-data-value sequence))) + (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -69,11 +69,11 @@ (defun mal-eval (ast env) (cond - ((not (types:mal-list-p ast)) (eval-ast ast env)) - ((zerop (length (types:mal-data-value ast))) ast) + ((not (mal-list-p ast)) (eval-ast ast env)) + ((zerop (length (mal-data-value ast))) ast) (t (progn (let ((evaluated-list (eval-ast ast env))) - (apply (types:mal-data-value (car evaluated-list)) + (apply (mal-data-value (car evaluated-list)) (cdr evaluated-list))))))) (defun mal-print (expression) @@ -81,12 +81,9 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) + (mal-print (mal-eval (mal-read string) *repl-env*)) (error (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (defvar *use-readline-p* nil) @@ -97,7 +94,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) diff --git a/common-lisp/src/step3_env.lisp b/common-lisp/src/step3_env.lisp index d988f12c41..ff34662223 100644 --- a/common-lisp/src/step3_env.lisp +++ b/common-lisp/src/step3_env.lisp @@ -17,28 +17,28 @@ (defvar *repl-env* (env:create-mal-env)) (env:set-env *repl-env* - (types:make-mal-symbol "+") - (types:make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (+ (mal-data-value value1) - (mal-data-value value2)))))) + (make-mal-symbol "+") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (+ (mal-data-value value1) + (mal-data-value value2)))))) (env:set-env *repl-env* - (types:make-mal-symbol "-") - (types:make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (- (mal-data-value value1) - (mal-data-value value2)))))) + (make-mal-symbol "-") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (- (mal-data-value value1) + (mal-data-value value2)))))) (env:set-env *repl-env* - (types:make-mal-symbol "*") - (types:make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (* (mal-data-value value1) - (mal-data-value value2)))))) + (make-mal-symbol "*") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (* (mal-data-value value1) + (mal-data-value value2)))))) (env:set-env *repl-env* - (types:make-mal-symbol "/") - (types:make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (/ (mal-data-value value1) - (mal-data-value value2)))))) + (make-mal-symbol "/") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (/ (mal-data-value value1) + (mal-data-value value2)))))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -46,16 +46,16 @@ (defun eval-sequence (sequence env) (map 'list (lambda (ast) (mal-eval ast env)) - (types:mal-data-value sequence))) + (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -67,13 +67,13 @@ (defun eval-let* (forms env) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -90,7 +90,7 @@ ((mal-data-value= mal-let* (first forms)) (eval-let* forms env)) (t (let ((evaluated-list (eval-ast ast env))) - (apply (types:mal-data-value (car evaluated-list)) + (apply (mal-data-value (car evaluated-list)) (cdr evaluated-list))))))) (defun mal-read (string) @@ -98,8 +98,8 @@ (defun mal-eval (ast env) (cond - ((null ast) types:mal-nil) - ((not (types:mal-list-p ast)) (eval-ast ast env)) + ((null ast) mal-nil) + ((not (mal-list-p ast)) (eval-ast ast env)) ((zerop (length (mal-data-value ast))) ast) (t (eval-list ast env)))) @@ -108,12 +108,9 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) + (mal-print (mal-eval (mal-read string) *repl-env*)) (error (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (defvar *use-readline-p* nil) @@ -124,7 +121,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) diff --git a/common-lisp/src/step4_if_fn_do.lisp b/common-lisp/src/step4_if_fn_do.lisp index 52b3a934bf..99fca65be4 100644 --- a/common-lisp/src/step4_if_fn_do.lisp +++ b/common-lisp/src/step4_if_fn_do.lisp @@ -18,9 +18,7 @@ (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -34,13 +32,13 @@ (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -52,13 +50,13 @@ (defun eval-let* (forms env) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -79,19 +77,17 @@ (cdr forms))))) ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (mal-eval (if (or (mal-data-value= predicate types:mal-nil) - (mal-data-value= predicate types:mal-false)) + (mal-eval (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms)) env))) ((mal-data-value= mal-fn* (first forms)) - (types:make-mal-fn (let ((arglist (second forms)) + (make-mal-fn (let ((arglist (second forms)) (body (third forms))) (lambda (&rest args) (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (mal-data-value arglist)) + :binds (listify (mal-data-value arglist)) :exprs args)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) @@ -104,8 +100,8 @@ (defun mal-eval (ast env) (cond - ((null ast) types:mal-nil) - ((not (types:mal-list-p ast)) (eval-ast ast env)) + ((null ast) mal-nil) + ((not (mal-list-p ast)) (eval-ast ast env)) ((zerop (length (mal-data-value ast))) ast) (t (eval-list ast env)))) @@ -114,12 +110,9 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) + (mal-print (mal-eval (mal-read string) *repl-env*)) (error (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (rep "(def! not (fn* (a) (if a false true)))") @@ -132,7 +125,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) diff --git a/common-lisp/src/step5_tco.lisp b/common-lisp/src/step5_tco.lisp index 181bfab623..18150d6df2 100644 --- a/common-lisp/src/step5_tco.lisp +++ b/common-lisp/src/step5_tco.lisp @@ -18,9 +18,7 @@ (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -34,13 +32,13 @@ (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -56,8 +54,8 @@ (defun mal-eval (ast env) (loop do (cond - ((null ast) (return types:mal-nil)) - ((not (types:mal-list-p ast)) (return (eval-ast ast env))) + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) ((zerop (length (mal-data-value ast))) (return ast)) (t (let ((forms (mal-data-value ast))) (cond @@ -66,13 +64,13 @@ ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -88,31 +86,29 @@ ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate types:mal-nil) - (mal-data-value= predicate types:mal-false)) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms))))) ((mal-data-value= mal-fn* (first forms)) (return (let ((arglist (second forms)) (body (third forms))) - (types:make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env)))))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons 'params arglist) + (cons 'ast body) + (cons 'env env)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it - (if (not (types:mal-fn-p function)) + (if (not (mal-fn-p function)) (return (apply (mal-data-value function) (cdr evaluated-list))) - (let* ((attrs (types:mal-data-attrs function))) + (let* ((attrs (mal-data-attrs function))) (setf ast (cdr (assoc 'ast attrs)) env (env:create-mal-env :parent (cdr (assoc 'env attrs)) :binds (map 'list @@ -125,12 +121,9 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) + (mal-print (mal-eval (mal-read string) *repl-env*)) (error (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (rep "(def! not (fn* (a) (if a false true)))") @@ -143,7 +136,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) diff --git a/common-lisp/src/step6_file.lisp b/common-lisp/src/step6_file.lisp index e9585c63b2..152a9af6f8 100644 --- a/common-lisp/src/step6_file.lisp +++ b/common-lisp/src/step6_file.lisp @@ -18,9 +18,7 @@ (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -34,13 +32,13 @@ (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -56,8 +54,8 @@ (defun mal-eval (ast env) (loop do (cond - ((null ast) (return types:mal-nil)) - ((not (types:mal-list-p ast)) (return (eval-ast ast env))) + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) ((zerop (length (mal-data-value ast))) (return ast)) (t (let ((forms (mal-data-value ast))) (cond @@ -66,13 +64,13 @@ ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -88,19 +86,17 @@ ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate types:mal-nil) - (mal-data-value= predicate types:mal-false)) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms))))) ((mal-data-value= mal-fn* (first forms)) (return (let ((arglist (second forms)) (body (third forms))) - (types:make-mal-fn (lambda (&rest args) + (make-mal-fn (lambda (&rest args) (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (mal-data-value arglist)) + :binds (listify (mal-data-value arglist)) :exprs args))) :attrs (list (cons 'params arglist) (cons 'ast body) @@ -109,10 +105,10 @@ (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it - (if (not (types:mal-fn-p function)) + (if (not (mal-fn-p function)) (return (apply (mal-data-value function) (cdr evaluated-list))) - (let* ((attrs (types:mal-data-attrs function))) + (let* ((attrs (mal-data-attrs function))) (setf ast (cdr (assoc 'ast attrs)) env (env:create-mal-env :parent (cdr (assoc 'env attrs)) :binds (map 'list @@ -125,16 +121,13 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) + (mal-print (mal-eval (mal-read string) *repl-env*)) (error (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (env:set-env *repl-env* - (types:make-mal-symbol "eval") - (types:make-mal-builtin-fn (lambda (ast) + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) (mal-eval ast *repl-env*)))) (rep "(def! not (fn* (a) (if a false true)))") @@ -149,7 +142,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) @@ -189,7 +182,7 @@ argv (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* - (types:make-mal-symbol "*ARGV*") + (make-mal-symbol "*ARGV*") (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) diff --git a/common-lisp/src/step7_quote.lisp b/common-lisp/src/step7_quote.lisp index 46ab36c369..956b0bcf01 100644 --- a/common-lisp/src/step7_quote.lisp +++ b/common-lisp/src/step7_quote.lisp @@ -18,9 +18,7 @@ (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -40,13 +38,13 @@ (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -59,11 +57,11 @@ (defun is-pair (value) (and (or (mal-list-p value) (mal-vector-p value)) - (< 0 (length (types:mal-data-value value))))) + (< 0 (length (mal-data-value value))))) (defun quasiquote (ast) (if (not (is-pair ast)) - (types:make-mal-list (list mal-quote ast)) + (make-mal-list (list mal-quote ast)) (let ((forms (map 'list #'identity (mal-data-value ast)))) (cond ((mal-data-value= mal-unquote (first forms)) @@ -71,14 +69,14 @@ ((and (is-pair (first forms)) (mal-data-value= mal-splice-unquote - (first (mal-data-value (first forms))))) - (types:make-mal-list (list mal-concat - (second (mal-data-value (first forms))) - (quasiquote (make-mal-list (cdr forms)))))) + (first (mal-data-value (first forms))))) + (make-mal-list (list mal-concat + (second (mal-data-value (first forms))) + (quasiquote (make-mal-list (cdr forms)))))) - (t (types:make-mal-list (list mal-cons - (quasiquote (first forms)) - (quasiquote (make-mal-list (cdr forms)))))))))) + (t (make-mal-list (list mal-cons + (quasiquote (first forms)) + (quasiquote (make-mal-list (cdr forms)))))))))) (defun mal-read (string) (reader:read-str string)) @@ -86,8 +84,8 @@ (defun mal-eval (ast env) (loop do (cond - ((null ast) (return types:mal-nil)) - ((not (types:mal-list-p ast)) (return (eval-ast ast env))) + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) ((zerop (length (mal-data-value ast))) (return ast)) (t (let ((forms (mal-data-value ast))) (cond @@ -102,13 +100,13 @@ ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -124,31 +122,29 @@ ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate types:mal-nil) - (mal-data-value= predicate types:mal-false)) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms))))) ((mal-data-value= mal-fn* (first forms)) (return (let ((arglist (second forms)) (body (third forms))) - (types:make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env)))))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons 'params arglist) + (cons 'ast body) + (cons 'env env)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it - (if (not (types:mal-fn-p function)) + (if (not (mal-fn-p function)) (return (apply (mal-data-value function) (cdr evaluated-list))) - (let* ((attrs (types:mal-data-attrs function))) + (let* ((attrs (mal-data-attrs function))) (setf ast (cdr (assoc 'ast attrs)) env (env:create-mal-env :parent (cdr (assoc 'env attrs)) :binds (map 'list @@ -161,17 +157,14 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) + (mal-print (mal-eval (mal-read string) *repl-env*)) (error (condition) - (format nil - "~a" - condition)))) + (format nil "~a" condition)))) (env:set-env *repl-env* - (types:make-mal-symbol "eval") - (types:make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -185,7 +178,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) @@ -225,7 +218,7 @@ argv (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* - (types:make-mal-symbol "*ARGV*") + (make-mal-symbol "*ARGV*") (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) diff --git a/common-lisp/src/step8_macros.lisp b/common-lisp/src/step8_macros.lisp index 805de19516..0c2c214e41 100644 --- a/common-lisp/src/step8_macros.lisp +++ b/common-lisp/src/step8_macros.lisp @@ -15,7 +15,7 @@ (in-package :mal) -(define-condition invalid-function (types:mal-runtime-exception) +(define-condition invalid-function (mal-runtime-exception) ((form :initarg :form :reader form) (context :initarg :context :reader context)) (:report (lambda (condition stream) @@ -30,9 +30,7 @@ (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -51,16 +49,16 @@ (defun eval-sequence (sequence env) (map 'list (lambda (ast) (mal-eval ast env)) - (types:mal-data-value sequence))) + (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -73,42 +71,42 @@ (defun is-pair (value) (and (or (mal-list-p value) (mal-vector-p value)) - (< 0 (length (types:mal-data-value value))))) + (< 0 (length (mal-data-value value))))) (defun quasiquote (ast) (if (not (is-pair ast)) - (types:make-mal-list (list mal-quote ast)) - (let ((forms (map 'list #'identity (types:mal-data-value ast)))) + (make-mal-list (list mal-quote ast)) + (let ((forms (map 'list #'identity (mal-data-value ast)))) (cond - ((types:mal-data-value= mal-unquote (first forms)) + ((mal-data-value= mal-unquote (first forms)) (second forms)) ((and (is-pair (first forms)) - (types:mal-data-value= mal-splice-unquote - (first (types:mal-data-value (first forms))))) - (types:make-mal-list (list mal-concat - (second (types:mal-data-value (first forms))) - (quasiquote (make-mal-list (cdr forms)))))) + (mal-data-value= mal-splice-unquote + (first (mal-data-value (first forms))))) + (make-mal-list (list mal-concat + (second (mal-data-value (first forms))) + (quasiquote (make-mal-list (cdr forms)))))) - (t (types:make-mal-list (list mal-cons - (quasiquote (first forms)) - (quasiquote (make-mal-list (cdr forms)))))))))) + (t (make-mal-list (list mal-cons + (quasiquote (first forms)) + (quasiquote (make-mal-list (cdr forms)))))))))) (defun is-macro-call (ast env) - (when (types:mal-list-p ast) - (let* ((func-symbol (first (types:mal-data-value ast))) - (func (when (types:mal-symbol-p func-symbol) + (when (mal-list-p ast) + (let* ((func-symbol (first (mal-data-value ast))) + (func (when (mal-symbol-p func-symbol) (env:find-env env func-symbol)))) (and func - (types:mal-fn-p func) - (cdr (assoc 'is-macro (types:mal-data-attrs func))))))) + (mal-fn-p func) + (cdr (assoc 'is-macro (mal-data-attrs func))))))) (defun mal-macroexpand (ast env) (loop while (is-macro-call ast env) - do (let* ((forms (types:mal-data-value ast)) + do (let* ((forms (mal-data-value ast)) (func (env:get-env env (first forms)))) - (setf ast (apply (types:mal-data-value func) + (setf ast (apply (mal-data-value func) (cdr forms))))) ast) @@ -119,44 +117,44 @@ (loop do (setf ast (mal-macroexpand ast env)) do (cond - ((null ast) (return types:mal-nil)) - ((not (types:mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (types:mal-data-value ast))) (return ast)) - (t (let ((forms (types:mal-data-value ast))) + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) (cond - ((types:mal-data-value= mal-quote (first forms)) + ((mal-data-value= mal-quote (first forms)) (return (second forms))) - ((types:mal-data-value= mal-quasiquote (first forms)) + ((mal-data-value= mal-quasiquote (first forms)) (setf ast (quasiquote (second forms)))) - ((types:mal-data-value= mal-macroexpand (first forms)) + ((mal-data-value= mal-macroexpand (first forms)) (return (mal-macroexpand (second forms) env))) - ((types:mal-data-value= mal-def! (first forms)) + ((mal-data-value= mal-def! (first forms)) (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - ((types:mal-data-value= mal-defmacro! (first forms)) + ((mal-data-value= mal-defmacro! (first forms)) (let ((value (mal-eval (third forms) env))) - (return (if (types:mal-fn-p value) + (return (if (mal-fn-p value) (env:set-env env (second forms) (progn - (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t) + (setf (cdr (assoc 'is-macro (mal-data-attrs value))) t) value)) (error 'invalid-function :form value :context "macro"))))) - ((types:mal-data-value= mal-let* (first forms)) + ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -165,45 +163,43 @@ (setf ast (third forms) env new-env))) - ((types:mal-data-value= mal-do (first forms)) + ((mal-data-value= mal-do (first forms)) (mapc (lambda (form) (mal-eval form env)) (butlast (cdr forms))) (setf ast (car (last forms)))) - ((types:mal-data-value= mal-if (first forms)) + ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (types:mal-data-value= predicate types:mal-nil) - (types:mal-data-value= predicate types:mal-false)) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms))))) - ((types:mal-data-value= mal-fn* (first forms)) + ((mal-data-value= mal-fn* (first forms)) (return (let ((arglist (second forms)) (body (third forms))) - (types:make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (types:mal-data-value arglist)) - :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env) - (cons 'is-macro nil)))))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons 'params arglist) + (cons 'ast body) + (cons 'env env) + (cons 'is-macro nil)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it - (cond ((types:mal-fn-p function) - (let* ((attrs (types:mal-data-attrs function))) + (cond ((mal-fn-p function) + (let* ((attrs (mal-data-attrs function))) (setf ast (cdr (assoc 'ast attrs)) env (env:create-mal-env :parent (cdr (assoc 'env attrs)) :binds (map 'list #'identity - (types:mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc 'params attrs)))) :exprs (cdr evaluated-list))))) - ((types:mal-builtin-fn-p function) - (return (apply (types:mal-data-value function) + ((mal-builtin-fn-p function) + (return (apply (mal-data-value function) (cdr evaluated-list)))) (t (error 'invalid-function :form function @@ -214,21 +210,16 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) - (types:mal-error (condition) - (format nil - "~a" - condition)) + (mal-print (mal-eval (mal-read string) *repl-env*)) + (mal-error (condition) + (format nil "~a" condition)) (error (condition) - (format nil - "Internal error: ~a" - condition)))) + (format nil "Internal error: ~a" condition)))) (env:set-env *repl-env* - (types:make-mal-symbol "eval") - (types:make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -244,7 +235,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) @@ -284,7 +275,7 @@ argv (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* - (types:make-mal-symbol "*ARGV*") + (make-mal-symbol "*ARGV*") (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) diff --git a/common-lisp/src/step9_try.lisp b/common-lisp/src/step9_try.lisp index ecccf8ebbc..bc3600150a 100644 --- a/common-lisp/src/step9_try.lisp +++ b/common-lisp/src/step9_try.lisp @@ -15,7 +15,7 @@ (in-package :mal) -(define-condition invalid-function (types:mal-runtime-exception) +(define-condition invalid-function (mal-runtime-exception) ((form :initarg :form :reader form) (context :initarg :context :reader context)) (:report (lambda (condition stream) @@ -30,9 +30,7 @@ (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -54,16 +52,16 @@ (defun eval-sequence (sequence env) (map 'list (lambda (ast) (mal-eval ast env)) - (types:mal-data-value sequence))) + (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -76,42 +74,42 @@ (defun is-pair (value) (and (or (mal-list-p value) (mal-vector-p value)) - (< 0 (length (types:mal-data-value value))))) + (< 0 (length (mal-data-value value))))) (defun quasiquote (ast) (if (not (is-pair ast)) - (types:make-mal-list (list mal-quote ast)) - (let ((forms (map 'list #'identity (types:mal-data-value ast)))) + (make-mal-list (list mal-quote ast)) + (let ((forms (map 'list #'identity (mal-data-value ast)))) (cond - ((types:mal-data-value= mal-unquote (first forms)) + ((mal-data-value= mal-unquote (first forms)) (second forms)) ((and (is-pair (first forms)) - (types:mal-data-value= mal-splice-unquote - (first (types:mal-data-value (first forms))))) - (types:make-mal-list (list mal-concat - (second (types:mal-data-value (first forms))) - (quasiquote (make-mal-list (cdr forms)))))) + (mal-data-value= mal-splice-unquote + (first (mal-data-value (first forms))))) + (make-mal-list (list mal-concat + (second (mal-data-value (first forms))) + (quasiquote (make-mal-list (cdr forms)))))) - (t (types:make-mal-list (list mal-cons - (quasiquote (first forms)) - (quasiquote (make-mal-list (cdr forms)))))))))) + (t (make-mal-list (list mal-cons + (quasiquote (first forms)) + (quasiquote (make-mal-list (cdr forms)))))))))) (defun is-macro-call (ast env) - (when (types:mal-list-p ast) - (let* ((func-symbol (first (types:mal-data-value ast))) - (func (when (types:mal-symbol-p func-symbol) + (when (mal-list-p ast) + (let* ((func-symbol (first (mal-data-value ast))) + (func (when (mal-symbol-p func-symbol) (env:find-env env func-symbol)))) (and func - (types:mal-fn-p func) - (cdr (assoc 'is-macro (types:mal-data-attrs func))))))) + (mal-fn-p func) + (cdr (assoc 'is-macro (mal-data-attrs func))))))) (defun mal-macroexpand (ast env) (loop while (is-macro-call ast env) - do (let* ((forms (types:mal-data-value ast)) + do (let* ((forms (mal-data-value ast)) (func (env:get-env env (first forms)))) - (setf ast (apply (types:mal-data-value func) + (setf ast (apply (mal-data-value func) (cdr forms))))) ast) @@ -122,44 +120,44 @@ (loop do (setf ast (mal-macroexpand ast env)) do (cond - ((null ast) (return types:mal-nil)) - ((not (types:mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (types:mal-data-value ast))) (return ast)) - (t (let ((forms (types:mal-data-value ast))) + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) (cond - ((types:mal-data-value= mal-quote (first forms)) + ((mal-data-value= mal-quote (first forms)) (return (second forms))) - ((types:mal-data-value= mal-quasiquote (first forms)) + ((mal-data-value= mal-quasiquote (first forms)) (setf ast (quasiquote (second forms)))) - ((types:mal-data-value= mal-macroexpand (first forms)) + ((mal-data-value= mal-macroexpand (first forms)) (return (mal-macroexpand (second forms) env))) - ((types:mal-data-value= mal-def! (first forms)) + ((mal-data-value= mal-def! (first forms)) (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - ((types:mal-data-value= mal-defmacro! (first forms)) + ((mal-data-value= mal-defmacro! (first forms)) (let ((value (mal-eval (third forms) env))) - (return (if (types:mal-fn-p value) + (return (if (mal-fn-p value) (env:set-env env (second forms) (progn - (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t) + (setf (cdr (assoc 'is-macro (mal-data-attrs value))) t) value)) (error 'invalid-function :form value :context "macro"))))) - ((types:mal-data-value= mal-let* (first forms)) + ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -168,62 +166,60 @@ (setf ast (third forms) env new-env))) - ((types:mal-data-value= mal-do (first forms)) + ((mal-data-value= mal-do (first forms)) (mapc (lambda (form) (mal-eval form env)) (butlast (cdr forms))) (setf ast (car (last forms)))) - ((types:mal-data-value= mal-if (first forms)) + ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (types:mal-data-value= predicate types:mal-nil) - (types:mal-data-value= predicate types:mal-false)) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms))))) - ((types:mal-data-value= mal-fn* (first forms)) + ((mal-data-value= mal-fn* (first forms)) (return (let ((arglist (second forms)) (body (third forms))) - (types:make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (types:mal-data-value arglist)) - :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env) - (cons 'is-macro nil)))))) - - ((types:mal-data-value= mal-try* (first forms)) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons 'params arglist) + (cons 'ast body) + (cons 'env env) + (cons 'is-macro nil)))))) + + ((mal-data-value= mal-try* (first forms)) (handler-case (return (mal-eval (second forms) env)) - ((or types:mal-exception types:mal-error) (condition) + ((or mal-exception mal-error) (condition) (when (third forms) - (let ((catch-forms (types:mal-data-value (third forms)))) - (when (types:mal-data-value= mal-catch* - (first catch-forms)) + (let ((catch-forms (mal-data-value (third forms)))) + (when (mal-data-value= mal-catch* + (first catch-forms)) (return (mal-eval (third catch-forms) (env:create-mal-env :parent env :binds (list (second catch-forms)) - :exprs (list (if (or (typep condition 'types:mal-runtime-exception) - (typep condition 'types:mal-error)) - (types:make-mal-string (format nil "~a" condition)) - (types::mal-exception-data condition))))))))) + :exprs (list (if (or (typep condition 'mal-runtime-exception) + (typep condition 'mal-error)) + (make-mal-string (format nil "~a" condition)) + (mal-exception-data condition))))))))) (error condition)))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it - (cond ((types:mal-fn-p function) - (let* ((attrs (types:mal-data-attrs function))) + (cond ((mal-fn-p function) + (let* ((attrs (mal-data-attrs function))) (setf ast (cdr (assoc 'ast attrs)) env (env:create-mal-env :parent (cdr (assoc 'env attrs)) :binds (map 'list #'identity - (types:mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc 'params attrs)))) :exprs (cdr evaluated-list))))) - ((types:mal-builtin-fn-p function) - (return (apply (types:mal-data-value function) + ((mal-builtin-fn-p function) + (return (apply (mal-data-value function) (cdr evaluated-list)))) (t (error 'invalid-function :form function @@ -234,29 +230,20 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) - (types:mal-error (condition) - (format nil - "Error: ~a" - condition)) - (types:mal-runtime-exception (condition) - (format nil - "Exception: ~a" - condition)) - (types:mal-user-exception (condition) - (format nil - "Exception: ~a" - (pr-str (types::mal-exception-data condition)))) + (mal-print (mal-eval (mal-read string) *repl-env*)) + (mal-error (condition) + (format nil "Error: ~a" condition)) + (mal-runtime-exception (condition) + (format nil "Exception: ~a" condition)) + (mal-user-exception (condition) + (format nil "Exception: ~a" (pr-str (mal-exception-data condition)))) (error (condition) - (format nil - "Internal error: ~a" - condition)))) + (format nil "Internal error: ~a" condition)))) (env:set-env *repl-env* - (types:make-mal-symbol "eval") - (types:make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -272,7 +259,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) @@ -312,7 +299,7 @@ argv (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* - (types:make-mal-symbol "*ARGV*") + (make-mal-symbol "*ARGV*") (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) diff --git a/common-lisp/src/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp index 628e675a31..82c6c7fca4 100644 --- a/common-lisp/src/stepA_mal.lisp +++ b/common-lisp/src/stepA_mal.lisp @@ -15,7 +15,7 @@ (in-package :mal) -(define-condition invalid-function (types:mal-runtime-exception) +(define-condition invalid-function (mal-runtime-exception) ((form :initarg :form :reader form) (context :initarg :context :reader context)) (:report (lambda (condition stream) @@ -26,13 +26,10 @@ "applying" "defining macro"))))) - (defvar *repl-env* (env:create-mal-env)) (dolist (binding core:ns) - (env:set-env *repl-env* - (car binding) - (cdr binding))) + (env:set-env *repl-env* (car binding) (cdr binding))) (defvar mal-def! (make-mal-symbol "def!")) (defvar mal-let* (make-mal-symbol "let*")) @@ -54,16 +51,16 @@ (defun eval-sequence (sequence env) (map 'list (lambda (ast) (mal-eval ast env)) - (types:mal-data-value sequence))) + (mal-data-value sequence))) (defun eval-hash-map (hash-map env) - (let ((hash-map-value (types:mal-data-value hash-map)) - (new-hash-table (types:make-mal-value-hash-table))) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) (genhash:hashmap (lambda (key value) (setf (genhash:hashref (mal-eval key env) new-hash-table) (mal-eval value env))) hash-map-value) - (types:make-mal-hash-map new-hash-table))) + (make-mal-hash-map new-hash-table))) (defun eval-ast (ast env) (switch-mal-type ast @@ -76,42 +73,42 @@ (defun is-pair (value) (and (or (mal-list-p value) (mal-vector-p value)) - (< 0 (length (types:mal-data-value value))))) + (< 0 (length (mal-data-value value))))) (defun quasiquote (ast) (if (not (is-pair ast)) - (types:make-mal-list (list mal-quote ast)) - (let ((forms (map 'list #'identity (types:mal-data-value ast)))) + (make-mal-list (list mal-quote ast)) + (let ((forms (map 'list #'identity (mal-data-value ast)))) (cond - ((types:mal-data-value= mal-unquote (first forms)) + ((mal-data-value= mal-unquote (first forms)) (second forms)) ((and (is-pair (first forms)) - (types:mal-data-value= mal-splice-unquote - (first (types:mal-data-value (first forms))))) - (types:make-mal-list (list mal-concat - (second (types:mal-data-value (first forms))) - (quasiquote (make-mal-list (cdr forms)))))) + (mal-data-value= mal-splice-unquote + (first (mal-data-value (first forms))))) + (make-mal-list (list mal-concat + (second (mal-data-value (first forms))) + (quasiquote (make-mal-list (cdr forms)))))) - (t (types:make-mal-list (list mal-cons - (quasiquote (first forms)) - (quasiquote (make-mal-list (cdr forms)))))))))) + (t (make-mal-list (list mal-cons + (quasiquote (first forms)) + (quasiquote (make-mal-list (cdr forms)))))))))) (defun is-macro-call (ast env) - (when (types:mal-list-p ast) - (let* ((func-symbol (first (types:mal-data-value ast))) - (func (when (types:mal-symbol-p func-symbol) + (when (mal-list-p ast) + (let* ((func-symbol (first (mal-data-value ast))) + (func (when (mal-symbol-p func-symbol) (env:find-env env func-symbol)))) (and func - (types:mal-fn-p func) - (cdr (assoc 'is-macro (types:mal-data-attrs func))))))) + (mal-fn-p func) + (cdr (assoc 'is-macro (mal-data-attrs func))))))) (defun mal-macroexpand (ast env) (loop while (is-macro-call ast env) - do (let* ((forms (types:mal-data-value ast)) + do (let* ((forms (mal-data-value ast)) (func (env:get-env env (first forms)))) - (setf ast (apply (types:mal-data-value func) + (setf ast (apply (mal-data-value func) (cdr forms))))) ast) @@ -122,44 +119,44 @@ (loop do (setf ast (mal-macroexpand ast env)) do (cond - ((null ast) (return types:mal-nil)) - ((not (types:mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (types:mal-data-value ast))) (return ast)) - (t (let ((forms (types:mal-data-value ast))) + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) (cond - ((types:mal-data-value= mal-quote (first forms)) + ((mal-data-value= mal-quote (first forms)) (return (second forms))) - ((types:mal-data-value= mal-quasiquote (first forms)) + ((mal-data-value= mal-quasiquote (first forms)) (setf ast (quasiquote (second forms)))) - ((types:mal-data-value= mal-macroexpand (first forms)) + ((mal-data-value= mal-macroexpand (first forms)) (return (mal-macroexpand (second forms) env))) - ((types:mal-data-value= mal-def! (first forms)) + ((mal-data-value= mal-def! (first forms)) (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - ((types:mal-data-value= mal-defmacro! (first forms)) + ((mal-data-value= mal-defmacro! (first forms)) (let ((value (mal-eval (third forms) env))) - (return (if (types:mal-fn-p value) + (return (if (mal-fn-p value) (env:set-env env (second forms) (progn - (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t) + (setf (cdr (assoc 'is-macro (mal-data-attrs value))) t) value)) (error 'invalid-function :form value :context "macro"))))) - ((types:mal-data-value= mal-let* (first forms)) + ((mal-data-value= mal-let* (first forms)) (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (types:mal-data-value (second forms))))) + (bindings (utils:listify (mal-data-value (second forms))))) (mapcar (lambda (binding) (env:set-env new-env (car binding) (mal-eval (or (cdr binding) - types:mal-nil) + mal-nil) new-env))) (loop for (symbol value) on bindings @@ -168,62 +165,60 @@ (setf ast (third forms) env new-env))) - ((types:mal-data-value= mal-do (first forms)) + ((mal-data-value= mal-do (first forms)) (mapc (lambda (form) (mal-eval form env)) (butlast (cdr forms))) (setf ast (car (last forms)))) - ((types:mal-data-value= mal-if (first forms)) + ((mal-data-value= mal-if (first forms)) (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (types:mal-data-value= predicate types:mal-nil) - (types:mal-data-value= predicate types:mal-false)) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) (fourth forms) (third forms))))) - ((types:mal-data-value= mal-fn* (first forms)) + ((mal-data-value= mal-fn* (first forms)) (return (let ((arglist (second forms)) (body (third forms))) - (types:make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (map 'list - #'identity - (types:mal-data-value arglist)) - :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env) - (cons 'is-macro nil)))))) - - ((types:mal-data-value= mal-try* (first forms)) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons 'params arglist) + (cons 'ast body) + (cons 'env env) + (cons 'is-macro nil)))))) + + ((mal-data-value= mal-try* (first forms)) (handler-case (return (mal-eval (second forms) env)) - ((or types:mal-exception types:mal-error) (condition) + ((or mal-exception mal-error) (condition) (when (third forms) - (let ((catch-forms (types:mal-data-value (third forms)))) - (when (types:mal-data-value= mal-catch* - (first catch-forms)) + (let ((catch-forms (mal-data-value (third forms)))) + (when (mal-data-value= mal-catch* + (first catch-forms)) (return (mal-eval (third catch-forms) (env:create-mal-env :parent env :binds (list (second catch-forms)) - :exprs (list (if (or (typep condition 'types:mal-runtime-exception) - (typep condition 'types:mal-error)) - (types:make-mal-string (format nil "~a" condition)) - (types::mal-exception-data condition))))))))) + :exprs (list (if (or (typep condition 'mal-runtime-exception) + (typep condition 'mal-error)) + (make-mal-string (format nil "~a" condition)) + (mal-exception-data condition))))))))) (error condition)))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it - (cond ((types:mal-fn-p function) - (let* ((attrs (types:mal-data-attrs function))) + (cond ((mal-fn-p function) + (let* ((attrs (mal-data-attrs function))) (setf ast (cdr (assoc 'ast attrs)) env (env:create-mal-env :parent (cdr (assoc 'env attrs)) :binds (map 'list #'identity - (types:mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc 'params attrs)))) :exprs (cdr evaluated-list))))) - ((types:mal-builtin-fn-p function) - (return (apply (types:mal-data-value function) + ((mal-builtin-fn-p function) + (return (apply (mal-data-value function) (cdr evaluated-list)))) (t (error 'invalid-function :form function @@ -234,36 +229,27 @@ (defun rep (string) (handler-case - (mal-print (mal-eval (mal-read string) - *repl-env*)) - (types:mal-error (condition) - (format nil - "Error: ~a" - condition)) - (types:mal-runtime-exception (condition) - (format nil - "Exception: ~a" - condition)) - (types:mal-user-exception (condition) - (format nil - "Exception: ~a" - (pr-str (types::mal-exception-data condition)))) + (mal-print (mal-eval (mal-read string) *repl-env*)) + (mal-error (condition) + (format nil "Error: ~a" condition)) + (mal-runtime-exception (condition) + (format nil "Exception: ~a" condition)) + (mal-user-exception (condition) + (format nil "Exception: ~a" (pr-str (mal-exception-data condition)))) (error (condition) - (format nil - "Internal error: ~a" - condition)))) + (format nil "Internal error: ~a" condition)))) (env:set-env *repl-env* - (types:make-mal-symbol "eval") - (types:make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) (env:set-env *repl-env* - (types:make-mal-symbol "*cl-implementation*") + (make-mal-symbol "*cl-implementation*") (make-mal-string (lisp-implementation-type))) (env:set-env *repl-env* - (types:make-mal-symbol "*cl-version*") + (make-mal-symbol "*cl-version*") (make-mal-string (lisp-implementation-version))) (rep "(def! not (fn* (a) (if a false true)))") @@ -283,7 +269,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (cl-readline:readline :prompt prompt + (rl:readline :prompt prompt :add-history t :novelty-check (lambda (old new) (not (string= old new)))) @@ -324,7 +310,7 @@ argv (cdr (utils:raw-command-line-arguments))))) (env:set-env *repl-env* - (types:make-mal-symbol "*ARGV*") + (make-mal-symbol "*ARGV*") (make-mal-list (mapcar #'make-mal-string (cdr args)))) (if (null args) (repl) diff --git a/common-lisp/src/types.lisp b/common-lisp/src/types.lisp index a6c3830230..57e5e6bca6 100644 --- a/common-lisp/src/types.lisp +++ b/common-lisp/src/types.lisp @@ -68,6 +68,7 @@ :make-mal-value-hash-table ;; Error types :mal-exception + :mal-exception-data ;; Exceptions raised by the runtime :mal-runtime-exception ;; Exception raised by user code @@ -77,14 +78,11 @@ (in-package :types) -(define-condition mal-error (error) - nil) +(define-condition mal-error (error) nil) -(define-condition mal-exception (error) - nil) +(define-condition mal-exception (error) nil) -(define-condition mal-runtime-exception (mal-exception) - nil) +(define-condition mal-runtime-exception (mal-exception) nil) (define-condition mal-user-exception (mal-exception) ((data :accessor mal-exception-data :initarg :data))) @@ -136,35 +134,33 @@ `(let ((type (mal-data-type ,ast))) (cond ,@(mapcar (lambda (form) - (list (if (or (equal (car form) t) - (equal (car form) 'any)) - t + (list (or (equal (car form) t) + (equal (car form) 'any) (list 'equal (list 'quote (car form)) 'type)) (cadr form))) forms)))) (defun mal-sequence= (value1 value2) - (let ((sequence1 (utils:listify (mal-data-value value1))) - (sequence2 (utils:listify (mal-data-value value2)))) + (let ((sequence1 (listify (mal-data-value value1))) + (sequence2 (listify (mal-data-value value2)))) + (when (= (length sequence1) (length sequence2)) - (every #'identity - (loop - for x in sequence1 - for y in sequence2 - collect (mal-data-value= x y)))))) + (every #'identity (loop for x in sequence1 + for y in sequence2 + collect (mal-data-value= x y)))))) (defun mal-hash-map= (value1 value2) (let ((map1 (mal-data-value value1)) (map2 (mal-data-value value2)) (identical t)) - (when (= (genhash:generic-hash-table-count map1) - (genhash:generic-hash-table-count map2)) - (genhash:hashmap (lambda (key value) - (declare (ignorable value)) - (setf identical - (and identical (mal-data-value= (genhash:hashref key map1) - (genhash:hashref key map2))))) - map1) + (when (= (generic-hash-table-count map1) + (generic-hash-table-count map2)) + (hashmap (lambda (key value) + (declare (ignorable value)) + (setf identical + (and identical (mal-data-value= (hashref key map1) + (hashref key map2))))) + map1) identical))) (defun mal-data-value= (value1 value2) @@ -191,7 +187,7 @@ ;; instead (let ((hash-function #+(or ecl abcl) #'mal-sxhash #-(or ecl abcl) #'sxhash)) - (genhash:register-test-designator 'mal-data-value-hash - hash-function - #'mal-data-value=))) - (genhash:make-generic-hash-table :test 'mal-data-value-hash)) + (register-test-designator 'mal-data-value-hash + hash-function + #'mal-data-value=))) + (make-generic-hash-table :test 'mal-data-value-hash)) From 3da6a0cb09a6fb85d323a0d16e04d4da3990235e Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 16:53:03 +0530 Subject: [PATCH 0101/1998] Common Lisp: Fix printing of user defined functions --- common-lisp/src/printer.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common-lisp/src/printer.lisp b/common-lisp/src/printer.lisp index e6c8de6651..2187bca7a0 100644 --- a/common-lisp/src/printer.lisp +++ b/common-lisp/src/printer.lisp @@ -49,5 +49,5 @@ (types:vector (pr-mal-sequence "[" ast "]" print-readably)) (types:hash-map (pr-mal-hash-map ast print-readably)) (types:atom (format nil "(atom ~a)" (pr-str (mal-data-value ast)))) - (types:builtin-fn "#") + (types:fn "#") (types:builtin-fn "#")))) From 774d5cf8b879bb52f9c7661a32c8055d9c011853 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Tue, 22 Aug 2017 18:28:50 +0530 Subject: [PATCH 0102/1998] Common Lisp: Add basic completion for toplevel symbols to the REPL --- common-lisp/src/env.lisp | 3 ++- common-lisp/src/step0_repl.lisp | 7 +++---- common-lisp/src/step1_read_print.lisp | 7 +++---- common-lisp/src/step2_eval.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step3_env.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step4_if_fn_do.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step5_tco.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step6_file.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step7_quote.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step8_macros.lisp | 27 +++++++++++++++++++++----- common-lisp/src/step9_try.lisp | 28 ++++++++++++++++++++++----- common-lisp/src/stepA_mal.lisp | 27 +++++++++++++++++++++----- common-lisp/src/utils.lisp | 15 +++++++++++++- 13 files changed, 221 insertions(+), 55 deletions(-) diff --git a/common-lisp/src/env.lisp b/common-lisp/src/env.lisp index 0a2ff05cae..771b72cf53 100644 --- a/common-lisp/src/env.lisp +++ b/common-lisp/src/env.lisp @@ -5,7 +5,8 @@ :create-mal-env :get-env :find-env - :set-env)) + :set-env + :mal-env-bindings)) (in-package :env) diff --git a/common-lisp/src/step0_repl.lisp b/common-lisp/src/step0_repl.lisp index 79d180056d..17ba1619c7 100644 --- a/common-lisp/src/step0_repl.lisp +++ b/common-lisp/src/step0_repl.lisp @@ -2,6 +2,8 @@ (:use :common-lisp) (:import-from :uiop :getenv) + (:import-from :cl-readline + :readline) (:export :main)) (in-package :mal) @@ -27,10 +29,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) diff --git a/common-lisp/src/step1_read_print.lisp b/common-lisp/src/step1_read_print.lisp index 1c0bd248a2..871ffbdb02 100644 --- a/common-lisp/src/step1_read_print.lisp +++ b/common-lisp/src/step1_read_print.lisp @@ -4,6 +4,8 @@ :printer) (:import-from :utils :getenv) + (:import-from :cl-readline + :readline) (:export :main)) (in-package :mal) @@ -33,10 +35,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) diff --git a/common-lisp/src/step2_eval.lisp b/common-lisp/src/step2_eval.lisp index ecfaedb4b4..13723d5823 100644 --- a/common-lisp/src/step2_eval.lisp +++ b/common-lisp/src/step2_eval.lisp @@ -4,11 +4,15 @@ :env :reader :printer) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -87,6 +91,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of *repl-env* + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -94,10 +110,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -122,6 +135,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (loop do (let ((line (mal-readline "user> "))) (if line (mal-writeline (rep line)) (return))))) diff --git a/common-lisp/src/step3_env.lisp b/common-lisp/src/step3_env.lisp index ff34662223..2aa091312b 100644 --- a/common-lisp/src/step3_env.lisp +++ b/common-lisp/src/step3_env.lisp @@ -5,11 +5,15 @@ :reader :printer :genhash) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -114,6 +118,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -121,10 +137,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -149,6 +162,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (loop do (let ((line (mal-readline "user> "))) (if line (mal-writeline (rep line)) (return))))) diff --git a/common-lisp/src/step4_if_fn_do.lisp b/common-lisp/src/step4_if_fn_do.lisp index 99fca65be4..0d865a8326 100644 --- a/common-lisp/src/step4_if_fn_do.lisp +++ b/common-lisp/src/step4_if_fn_do.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -118,6 +122,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -125,10 +141,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -153,6 +166,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (loop do (let ((line (mal-readline "user> "))) (if line (mal-writeline (rep line)) (return))))) diff --git a/common-lisp/src/step5_tco.lisp b/common-lisp/src/step5_tco.lisp index 18150d6df2..b0d9ece2d5 100644 --- a/common-lisp/src/step5_tco.lisp +++ b/common-lisp/src/step5_tco.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -129,6 +133,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -136,10 +152,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -164,6 +177,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (loop do (let ((line (mal-readline "user> "))) (if line (mal-writeline (rep line)) (return))))) diff --git a/common-lisp/src/step6_file.lisp b/common-lisp/src/step6_file.lisp index 152a9af6f8..361305ccdd 100644 --- a/common-lisp/src/step6_file.lisp +++ b/common-lisp/src/step6_file.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -135,6 +139,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -142,10 +158,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -178,6 +191,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (let ((args (if argv-provided-p argv (cdr (utils:raw-command-line-arguments))))) diff --git a/common-lisp/src/step7_quote.lisp b/common-lisp/src/step7_quote.lisp index 956b0bcf01..ea7d53d28e 100644 --- a/common-lisp/src/step7_quote.lisp +++ b/common-lisp/src/step7_quote.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -171,6 +175,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -178,10 +194,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -214,6 +227,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (let ((args (if argv-provided-p argv (cdr (utils:raw-command-line-arguments))))) diff --git a/common-lisp/src/step8_macros.lisp b/common-lisp/src/step8_macros.lisp index 0c2c214e41..cbf47eb78b 100644 --- a/common-lisp/src/step8_macros.lisp +++ b/common-lisp/src/step8_macros.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -228,6 +232,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -235,10 +251,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -271,6 +284,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (let ((args (if argv-provided-p argv (cdr (utils:raw-command-line-arguments))))) diff --git a/common-lisp/src/step9_try.lisp b/common-lisp/src/step9_try.lisp index bc3600150a..18e0060047 100644 --- a/common-lisp/src/step9_try.lisp +++ b/common-lisp/src/step9_try.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -252,6 +256,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -259,10 +275,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -295,6 +308,11 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (let ((args (if argv-provided-p argv (cdr (utils:raw-command-line-arguments))))) diff --git a/common-lisp/src/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp index 82c6c7fca4..046dd9f43d 100644 --- a/common-lisp/src/stepA_mal.lisp +++ b/common-lisp/src/stepA_mal.lisp @@ -5,12 +5,16 @@ :reader :printer :core) + (:import-from :cl-readline + :readline + :register-function) (:import-from :genhash :hashref :hashmap) (:import-from :utils :listify - :getenv) + :getenv + :common-prefix) (:export :main)) (in-package :mal) @@ -262,6 +266,18 @@ (defvar *use-readline-p* nil) +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + (defun raw-input (prompt) (format *standard-output* prompt) (force-output *standard-output*) @@ -269,10 +285,7 @@ (defun mal-readline (prompt) (if *use-readline-p* - (rl:readline :prompt prompt - :add-history t - :novelty-check (lambda (old new) - (not (string= old new)))) + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) (raw-input prompt))) (defun mal-writeline (string) @@ -306,6 +319,10 @@ *standard-output* (ext:make-stream :output :buffered t) *error-output* (ext:make-stream :error :buffered t)) + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + (let ((args (if argv-provided-p argv (cdr (utils:raw-command-line-arguments))))) diff --git a/common-lisp/src/utils.lisp b/common-lisp/src/utils.lisp index 8845f2048b..95eadf5dab 100644 --- a/common-lisp/src/utils.lisp +++ b/common-lisp/src/utils.lisp @@ -5,7 +5,8 @@ :getenv :read-file-string :raw-command-line-arguments - :listify)) + :listify + :common-prefix)) (in-package :utils) @@ -27,3 +28,15 @@ is replaced with replacement." (defun listify (sequence) "Convert a sequence to a list" (map 'list #'identity sequence)) + +(defun common-prefix (&rest strings) + (if (not strings) + "" + (let* ((char-lists (mapcar (lambda (string) (coerce string 'list)) strings)) + (char-tuples (apply #'mapcar #'list char-lists)) + (count 0)) + (loop for char-tuple in char-tuples + while (every (lambda (char) (equal char (car char-tuple))) char-tuple) + do (incf count)) + + (subseq (car strings) 0 count)))) From 31a77c4c14701b9c1985490b0e3d863efa028619 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Wed, 23 Aug 2017 23:45:05 +0530 Subject: [PATCH 0103/1998] Common Lisp: Create standalone executables for supported Lisps --- common-lisp/Makefile | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/common-lisp/Makefile b/common-lisp/Makefile index d6d8437d0f..9c614c4d20 100644 --- a/common-lisp/Makefile +++ b/common-lisp/Makefile @@ -11,11 +11,14 @@ define steps stepA_mal) endef +LISP ?= sbcl +ABCL ?= abcl + +STANDALONE_EXE = sbcl clisp ccl ecl cmucl + ROOT_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) SOURCES_LISP := src/env.lisp src/core.lisp src/stepA_mal.lisp SOURCES := src/utils.lisp src/types.lisp src/reader.lisp src/printer.lisp $(SOURCES_LISP) -LISP ?= sbcl -ABCL ?= abcl # Record the Common Lisp implementation used for all steps built in this # invocation This is used in the targets to rebuild the step if the @@ -34,7 +37,18 @@ hist/%_impl: ; # image even if invoked from some directory different from where it # currently resides step% : src/step%.lisp src/utils.lisp src/types.lisp src/env.lisp src/printer.lisp src/reader.lisp src/core.lisp hist/%_impl -ifeq ($(LISP),abcl) + +ifeq ($(LISP),clisp) + @echo "==============================================================" + @echo "WARNING: This build might fail since GNU Clisp does not have bundled version of asdf (yet)" + @echo "Please do something like below to make it work" + @echo "(mkdir -p ~/common-lisp/ && cd ~/common-lisp && git clone -b release https://gitlab.common-lisp.net/asdf/asdf.git && cd asdf && make)" + @echo "==============================================================" +endif + +ifneq ($(filter $(LISP),$(STANDALONE_EXE)),) + cl-launch --wrap 'if [ -z "$$CL_LAUNCH_VERSION" ] ; then cd "$$(dirname $$CL_LAUNCH_FILE)" ; fi' --verbose --lisp $(LISP) --source-registry $(ROOT_DIR) --system $@ --dump '!' -o $@ --entry 'mal:main' +else ifeq ($(LISP),abcl) echo -n '#!/bin/sh\ncd `dirname $$0` ; $(ABCL) --noinform --noinit --nosystem --load run-abcl.lisp -- $@ $$@' > $@ chmod +x $@ else From df020af215b2163f3e1153947fb1bbf08e62383f Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Wed, 23 Aug 2017 23:49:52 +0530 Subject: [PATCH 0104/1998] Common Lisp: Simplify the clean task --- common-lisp/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common-lisp/Makefile b/common-lisp/Makefile index 9c614c4d20..77b1530e30 100644 --- a/common-lisp/Makefile +++ b/common-lisp/Makefile @@ -56,7 +56,7 @@ else endif clean: - find . -name 'step*' -executable -exec git check-ignore \{\} \; -delete + find . -maxdepth 1 -name 'step*' -executable -delete rm -f *.lib *.fas[l] images/* hist/*_impl stats: $(SOURCES) From 269ce7ffb715d568a481d313621009cbd3d65e64 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Thu, 24 Aug 2017 18:58:17 +0530 Subject: [PATCH 0105/1998] Common Lisp: Add support for running MAL using MKCL --- common-lisp/Makefile | 12 +++++++++++- common-lisp/README.org | 14 ++++++++++---- common-lisp/fake-readline.lisp | 18 ++++++++++++++++++ common-lisp/run-mkcl.lisp | 21 +++++++++++++++++++++ common-lisp/src/types.lisp | 10 +++++----- common-lisp/step0_repl.asd | 3 ++- common-lisp/step1_read_print.asd | 4 +++- common-lisp/step2_eval.asd | 4 +++- common-lisp/step3_env.asd | 4 +++- common-lisp/step4_if_fn_do.asd | 4 +++- common-lisp/step5_tco.asd | 4 +++- common-lisp/step6_file.asd | 4 +++- common-lisp/step7_quote.asd | 4 +++- common-lisp/step8_macros.asd | 4 +++- common-lisp/step9_try.asd | 4 +++- common-lisp/stepA_mal.asd | 4 +++- 16 files changed, 97 insertions(+), 21 deletions(-) create mode 100644 common-lisp/fake-readline.lisp create mode 100644 common-lisp/run-mkcl.lisp diff --git a/common-lisp/Makefile b/common-lisp/Makefile index 77b1530e30..a80f34f58c 100644 --- a/common-lisp/Makefile +++ b/common-lisp/Makefile @@ -13,7 +13,10 @@ endef LISP ?= sbcl ABCL ?= abcl +MKCL ?= mkcl +# TODO: In theory cl-launch should be able to build standalone executable using +# MKCL unfortunately the executable crashes on startup STANDALONE_EXE = sbcl clisp ccl ecl cmucl ROOT_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) @@ -51,8 +54,15 @@ ifneq ($(filter $(LISP),$(STANDALONE_EXE)),) else ifeq ($(LISP),abcl) echo -n '#!/bin/sh\ncd `dirname $$0` ; $(ABCL) --noinform --noinit --nosystem --load run-abcl.lisp -- $@ $$@' > $@ chmod +x $@ -else +else ifeq ($(LISP),mkcl) + $(MKCL) -eval '(progn (require "asdf") (push *default-pathname-defaults* asdf:*central-registry*) (asdf:load-system "$@") (quit))' + echo -n '#!/bin/sh\ncd `dirname $$0` ; $(MKCL) -q -load run-mkcl.lisp -- $@ $$@' > $@ + chmod +x $@ +else ifeq ($(LISP),allegro) cl-launch --wrap 'if [ -z "$$CL_LAUNCH_VERSION" ] ; then cd "$$(dirname $$CL_LAUNCH_FILE)" ; fi' --verbose --lisp $(LISP) --source-registry $(ROOT_DIR) --system $@ --dump images/$@.$(LISP).image -o $@ --entry 'mal:main' +else + @echo "Unsupported Lisp implementation $(LISP)" + @exit 1 endif clean: diff --git a/common-lisp/README.org b/common-lisp/README.org index 97a494d4eb..b29f73a7fa 100644 --- a/common-lisp/README.org +++ b/common-lisp/README.org @@ -2,19 +2,19 @@ ** Introduction -This is a reasonably portable implementation of MAL in Common Lisp. It has been -tested to work with following Common Lisp implementations +This is a portable implementation of MAL in Common Lisp. It has been tested to +work with following Common Lisp implementations - Steel Bank Common Lisp [[http://sbcl.org/]] - Clozure Common Lisp [[http://ccl.clozure.com/]] - CMU Common Lisp [[https://www.cons.org/cmucl/]] - GNU CLISP [[http://www.clisp.org/]] - Embeddable Common Lisp [[https://common-lisp.net/project/ecl/]] +- ManKai Common Lisp https://common-lisp.net/project/mkcl/ - Allegro CL [[http://franz.com/products/allegro-common-lisp/]] - Armed Bear Common Lisp [[http://abcl.org/]] -[[http://www.cliki.net/cl-launch][cl-launch]] to build command line runnable scripts/images for most of the above -implementations. +[[http://www.cliki.net/cl-launch][cl-launch]] to build executable/wrapper scripts for most of the above implementations. ** Dependencies @@ -49,6 +49,7 @@ implementation. The nicknames that work currently are | CMU Common Lisp | cmucl | | GNU CLISP | clisp | | Embeddable Common Lisp | ecl | +| ManKai Common Lisp | mkcl | | Allegro CL | allegro | | Armed Bear Common Lisp | abcl | |------------------------+----------| @@ -71,6 +72,7 @@ be the capitalization of the given nickname. | CMU Common Lisp | CMUCL | | GNU CLISP | CLISP | | Embeddable Common Lisp | ECL | +| ManKai Common Lisp | MKCL | | Allegro CL | ALLEGRO | | Armed Bear Common Lisp | ABCL | |------------------------+-------------| @@ -92,3 +94,7 @@ building it. There is some basic interop in the form ~cl-eval~ which takes a string and evaluates it as Common Lisp code, the result is returned in form of a MAL value, as such you are limited to code that produces values that have MAL counterparts. + +** Known Issues + ABCL takes a long to boot as such it needs to be run with ~TEST_OPTS~ set to + ~--start-timeout 120~ diff --git a/common-lisp/fake-readline.lisp b/common-lisp/fake-readline.lisp new file mode 100644 index 0000000000..9895c6ed5b --- /dev/null +++ b/common-lisp/fake-readline.lisp @@ -0,0 +1,18 @@ +;; For some reason MKCL fails to find libreadline.so as a result cl-readline +;; fails. To avoid conditionals in the code we fake the cl-readline interface +;; and use it in asdf definitions when running under MKCL +(defpackage :cl-readline + (:nicknames :rl) + (:use :common-lisp)) + +(in-package :cl-readline) + +(defun readline (&keys prompt already-prompted num-chars + erase-empty-line add-history novelty-check) + (declare (ignorable ignored)) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun register-function (&rest ignored) + (declare (ignorable ignored))) diff --git a/common-lisp/run-mkcl.lisp b/common-lisp/run-mkcl.lisp new file mode 100644 index 0000000000..8d751a0814 --- /dev/null +++ b/common-lisp/run-mkcl.lisp @@ -0,0 +1,21 @@ +(require 'asdf) +(push *default-pathname-defaults* asdf:*central-registry*) + +(defvar *raw-command-line-args* (loop + :for index + :from 1 + :below (mkcl:argc) + :collect (mkcl:argv index))) + +(defvar *command-line-args* (subseq *raw-command-line-args* + (min (1+ (position "--" *raw-command-line-args* :test #'string=)) + (length *raw-command-line-args*)))) + +;; Suppress compilation output +(let ((*error-output* (make-broadcast-stream)) + (*standard-output* (make-broadcast-stream))) + (format *standard-output* "~a" *command-line-args*) + (asdf:load-system (car *command-line-args*) :verbose nil)) + +(mal:main (cdr *command-line-args*)) +(quit) diff --git a/common-lisp/src/types.lisp b/common-lisp/src/types.lisp index 57e5e6bca6..f9f05a232d 100644 --- a/common-lisp/src/types.lisp +++ b/common-lisp/src/types.lisp @@ -182,11 +182,11 @@ (defun make-mal-value-hash-table () (unless (gethash 'mal-data-value-hash genhash::*hash-test-designator-map*) - ;; ECL and ABCL's implementations of sxhash do not work well with compound - ;; types, use a custom hash function which hashes the underlying value - ;; instead - (let ((hash-function #+(or ecl abcl) #'mal-sxhash - #-(or ecl abcl) #'sxhash)) + ;; ECL, ABCL and MKCL's implementations of sxhash do not work well with + ;; compound types, use a custom hash function which hashes the underlying + ;; value instead + (let ((hash-function #+(or ecl abcl mkcl) #'mal-sxhash + #-(or ecl abcl mkcl) #'sxhash)) (register-test-designator 'mal-data-value-hash hash-function #'mal-data-value=))) diff --git a/common-lisp/step0_repl.asd b/common-lisp/step0_repl.asd index fbad7d602c..57f978b66a 100644 --- a/common-lisp/step0_repl.asd +++ b/common-lisp/step0_repl.asd @@ -5,7 +5,8 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step1_read_print.asd b/common-lisp/step1_read_print.asd index c3719f155e..814538c6db 100644 --- a/common-lisp/step1_read_print.asd +++ b/common-lisp/step1_read_print.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step2_eval.asd b/common-lisp/step2_eval.asd index 319157d3cf..f83e21e5fe 100644 --- a/common-lisp/step2_eval.asd +++ b/common-lisp/step2_eval.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step3_env.asd b/common-lisp/step3_env.asd index 025644622d..804921a499 100644 --- a/common-lisp/step3_env.asd +++ b/common-lisp/step3_env.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step4_if_fn_do.asd b/common-lisp/step4_if_fn_do.asd index 8af7349f4b..a2a7f44c08 100644 --- a/common-lisp/step4_if_fn_do.asd +++ b/common-lisp/step4_if_fn_do.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step5_tco.asd b/common-lisp/step5_tco.asd index 0fb40bce43..aa684ab52f 100644 --- a/common-lisp/step5_tco.asd +++ b/common-lisp/step5_tco.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step6_file.asd b/common-lisp/step6_file.asd index 671641c924..594ad8969b 100644 --- a/common-lisp/step6_file.asd +++ b/common-lisp/step6_file.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step7_quote.asd b/common-lisp/step7_quote.asd index 96ab0191a2..cf0ca7bff5 100644 --- a/common-lisp/step7_quote.asd +++ b/common-lisp/step7_quote.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step8_macros.asd b/common-lisp/step8_macros.asd index 4cab290143..5d6fdc7912 100644 --- a/common-lisp/step8_macros.asd +++ b/common-lisp/step8_macros.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/step9_try.asd b/common-lisp/step9_try.asd index 4788e6298d..2a07db6cf4 100644 --- a/common-lisp/step9_try.asd +++ b/common-lisp/step9_try.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) diff --git a/common-lisp/stepA_mal.asd b/common-lisp/stepA_mal.asd index 22d5e6f165..d8dc2774b4 100644 --- a/common-lisp/stepA_mal.asd +++ b/common-lisp/stepA_mal.asd @@ -5,11 +5,13 @@ (load quicklisp-init))) (ql:quickload :uiop :silent t :verbose nil) -(ql:quickload :cl-readline :silent t) (ql:quickload :cl-ppcre :silent t) (ql:quickload :genhash :silent t) (ql:quickload :alexandria :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + (defpackage #:mal-asd (:use :cl :asdf)) From 95648aadb3bdcbaad5df4692856fb04a14e9e04a Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Sat, 26 Aug 2017 13:03:26 +0530 Subject: [PATCH 0106/1998] Common Lisp: Fix try* to catch all errors --- common-lisp/src/step9_try.lisp | 10 ++++------ common-lisp/src/stepA_mal.lisp | 10 ++++------ 2 files changed, 8 insertions(+), 12 deletions(-) diff --git a/common-lisp/src/step9_try.lisp b/common-lisp/src/step9_try.lisp index 18e0060047..268e50dab6 100644 --- a/common-lisp/src/step9_try.lisp +++ b/common-lisp/src/step9_try.lisp @@ -197,7 +197,7 @@ ((mal-data-value= mal-try* (first forms)) (handler-case (return (mal-eval (second forms) env)) - ((or mal-exception mal-error) (condition) + (error (condition) (when (third forms) (let ((catch-forms (mal-data-value (third forms)))) (when (mal-data-value= mal-catch* @@ -205,11 +205,9 @@ (return (mal-eval (third catch-forms) (env:create-mal-env :parent env :binds (list (second catch-forms)) - :exprs (list (if (or (typep condition 'mal-runtime-exception) - (typep condition 'mal-error)) - (make-mal-string (format nil "~a" condition)) - (mal-exception-data condition))))))))) - (error condition)))) + :exprs (list (if (typep condition 'mal-user-exception) + (mal-exception-data condition) + (make-mal-string (format nil "~a" condition))))))))))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) diff --git a/common-lisp/src/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp index 046dd9f43d..ec189dd30a 100644 --- a/common-lisp/src/stepA_mal.lisp +++ b/common-lisp/src/stepA_mal.lisp @@ -196,7 +196,7 @@ ((mal-data-value= mal-try* (first forms)) (handler-case (return (mal-eval (second forms) env)) - ((or mal-exception mal-error) (condition) + (error (condition) (when (third forms) (let ((catch-forms (mal-data-value (third forms)))) (when (mal-data-value= mal-catch* @@ -204,11 +204,9 @@ (return (mal-eval (third catch-forms) (env:create-mal-env :parent env :binds (list (second catch-forms)) - :exprs (list (if (or (typep condition 'mal-runtime-exception) - (typep condition 'mal-error)) - (make-mal-string (format nil "~a" condition)) - (mal-exception-data condition))))))))) - (error condition)))) + :exprs (list (if (typep condition 'mal-user-exception) + (mal-exception-data condition) + (make-mal-string (format nil "~a" condition))))))))))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) From 244ac2d6d2b424a928116a4663408ae20b0d73ed Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 2 Sep 2017 00:46:52 +0200 Subject: [PATCH 0107/1998] Implement step 0 --- Makefile | 5 +++-- scm/Makefile | 17 +++++++++++++++++ scm/run | 12 ++++++++++++ scm/step0_repl.scm | 33 +++++++++++++++++++++++++++++++++ 4 files changed, 65 insertions(+), 2 deletions(-) create mode 100644 scm/Makefile create mode 100755 scm/run create mode 100644 scm/step0_repl.scm diff --git a/Makefile b/Makefile index 20a663629d..ee6d07ab72 100644 --- a/Makefile +++ b/Makefile @@ -81,8 +81,8 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ - python r racket rexx rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ - vimscript livescript elm + python r racket rexx rpython ruby rust scala scm skew swift swift3 tcl \ + ts vb vhdl vimscript livescript elm EXTENSION = .mal @@ -208,6 +208,7 @@ rpython_STEP_TO_PROG = rpython/$($(1)) ruby_STEP_TO_PROG = ruby/$($(1)).rb rust_STEP_TO_PROG = rust/target/release/$($(1)) scala_STEP_TO_PROG = scala/target/scala-2.11/classes/$($(1)).class +scm_STEP_TO_PROG = scm/$($(1)).scm skew_STEP_TO_PROG = skew/$($(1)).js swift_STEP_TO_PROG = swift/$($(1)) swift3_STEP_TO_PROG = swift3/$($(1)) diff --git a/scm/Makefile b/scm/Makefile new file mode 100644 index 0000000000..02e2630df3 --- /dev/null +++ b/scm/Makefile @@ -0,0 +1,17 @@ +SOURCES_BASE = reader.scm printer.scm types.scm +SOURCES_LISP = env.scm func.scm core.scm stepA_mal.scm +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + +clean: + +.PHONY: stats tests $(TESTS) + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" + diff --git a/scm/run b/scm/run new file mode 100755 index 0000000000..258c023b67 --- /dev/null +++ b/scm/run @@ -0,0 +1,12 @@ +#!/bin/bash +case ${SCM_MODE:-chibi} in + chibi) exec chibi-scheme $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + kawa) exec kawa --r7rs $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + chicken) exec csi -R r7rs -s $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + gauche) exec gosh $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + picrin) exec picrin $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + sagittarius) exec sagittarius -n $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + cyclone) exec icyc -s $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + foment) exec foment $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + *) echo "Invalid SCM_MODE: ${SCM_MODE}"; exit 2 ;; +esac diff --git a/scm/step0_repl.scm b/scm/step0_repl.scm new file mode 100644 index 0000000000..c02c11ea9d --- /dev/null +++ b/scm/step0_repl.scm @@ -0,0 +1,33 @@ +(import (scheme base)) +(import (scheme write)) + +(define (READ input) + input) + +(define (EVAL input) + input) + +(define (PRINT input) + input) + +(define (rep input) + (PRINT (EVAL (READ input)))) + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (display (rep input)) + (newline) + (loop)))) + (newline)) + +(main) From 4fc912a2fb8b51ca5fa7534b8a3edff2b4149579 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 2 Sep 2017 21:50:26 +0200 Subject: [PATCH 0108/1998] Add notes --- scm/notes.rst | 106 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) create mode 100644 scm/notes.rst diff --git a/scm/notes.rst b/scm/notes.rst new file mode 100644 index 0000000000..fd1bce6049 --- /dev/null +++ b/scm/notes.rst @@ -0,0 +1,106 @@ +Key +=== + +- Chibi: c +- Kawa: k +- CHICKEN: C +- Gauche: g +- Picrin: p +- Sagitarrius: s +- Cyclone: § +- Foment: f +- Guile: G +- Racket: r +- Larceny: l + +- Works: y +- Doesn't: n +- Sort of: x +- Unknown: ? + +Matrix +====== + +======================== === === === === === === === === === === === + Scheme implementations c k C g p s § f G r l +======================== === === === === === === === === === === === + R7RS support y y y y y y y y n ? x +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Console I/O y y y y y y x n ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Step #0 y y y y y y y n ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Modules y y y y n y y y ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Automatic library load y y x y n y x y ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + (scheme char) y y y y n y y y ? ? ? +======================== === === === === === === === === === === === + +Notes +===== + +R7RS Support +------------ + +This is about whether I can write a script in R7RS Scheme and +successfully execute it with the implementation. Guile didn't pass +this test and the manual merely mentions it implements a few +R7RS-features (which is far from sufficient), Racket supposedly has +inofficial support for it, Larceny refuses loading up anything else +than a R7RS library. + +Console I/O +----------- + +In step 0 a REPL is implemented that echoes back user input and quits +on EOF (signalled by ``C-d``). Cyclone is weird here because its +``read-line`` procedure includes the trailing newline (fixed +upstream), Foment doesn't recognize EOF from console, but does so fine +with input redirection (as in ``(with-input-from-file "..." +read-line)``), a bug report for that is still pending. + +Step #0 +------- + +This is about whether the tests for step #0 have been passed +successfully. Foment fails this as it detects it's wired up to a tty +and probes for its cursor position before initializing its readline +implementation. This makes the test rig fail detecting a prompt. A +bug has been submitted upstream to rectify this. + +Modules +------- + +MAL requires a certain amount of modularization by splitting the +interpreter up into multiple files, for this R7RS libraries are a +natural fit. This is purely about whether the implementation allows +using code from a library file inside a script file. The only one not +passing this requirement is Picrin as it neither allows loading up +multiple files nor automatically loads up extra files. This leaves me +with just ``load`` as primitive, but this is not sufficient because I +need a relative load facility and the details on how its argument is +treated are implementation-specific. + +Automatic library load +---------------------- + +R7RS libraries are specified as a list of identifiers, commonly +translated to a nested path (for example ``(foo bar)`` translates to +``foo/bar.sld``) that is looked up in the include locations and loaded +automatically. CHICKEN translates them to ``foo.bar.scm`` and doesn't +load up source files automatically, instead you'll have to compile +libraries to importable shared libraries. Similarly, Cyclone only +loads up libraries after they've been compiled. Picrin doesn't do +anything in this regard, so only something like concatenating source +files (hello JS!) might work out. + +(scheme char) +------------- + +R7RS is split up into many base libraries, including one for char +procedures. This is necessary for tokenization of user input, +unfortunately Picrin doesn't implement this namespace at all and +throws parts of it into ``(scheme base)`` instead, without the +mandatory unicode support. This and the preceding failures are reason +enough for me to exclude it from this comparison. From 6ca835670b4cb89ac1b27823a159208285bd6282 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 3 Sep 2017 23:30:37 +0200 Subject: [PATCH 0109/1998] Implement step 1 --- scm/Makefile | 47 +++++++++-- scm/lib/printer.sld | 43 ++++++++++ scm/lib/reader.sld | 178 +++++++++++++++++++++++++++++++++++++++ scm/lib/types.sld | 49 +++++++++++ scm/lib/util.sld | 85 +++++++++++++++++++ scm/notes.rst | 38 +++++++++ scm/run | 15 ++-- scm/step1_read_print.scm | 44 ++++++++++ 8 files changed, 485 insertions(+), 14 deletions(-) create mode 100644 scm/lib/printer.sld create mode 100644 scm/lib/reader.sld create mode 100644 scm/lib/types.sld create mode 100644 scm/lib/util.sld create mode 100644 scm/step1_read_print.scm diff --git a/scm/Makefile b/scm/Makefile index 02e2630df3..9959074cd3 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -1,12 +1,48 @@ -SOURCES_BASE = reader.scm printer.scm types.scm -SOURCES_LISP = env.scm func.scm core.scm stepA_mal.scm +SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld +SOURCES_LISP = lib/env.sld lib/func.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) +BINS = step0_repl step1_read_print -all: +SYMLINK = ln -sfr +RM = rm -f -clean: +CSC = csc -O2 -R r7rs +CSCSO = csc -O2 -R r7rs -sJ +CYCLONE = cyclone -O2 + +all: symlinks + +.PHONY: symlinks chicken cyclone clean stats stats-lisp + +symlinks: + $(SYMLINK) lib/util.sld lib/util.scm + $(SYMLINK) lib/util.sld lib.util.scm + $(SYMLINK) lib/types.sld lib/types.scm + $(SYMLINK) lib/types.sld lib.types.scm + $(SYMLINK) lib/reader.sld lib/reader.scm + $(SYMLINK) lib/reader.sld lib.reader.scm + $(SYMLINK) lib/printer.sld lib/printer.scm + $(SYMLINK) lib/printer.sld lib.printer.scm -.PHONY: stats tests $(TESTS) +chicken: + $(CSCSO) lib.util.scm + $(CSCSO) lib.types.scm + $(CSCSO) lib.reader.scm + $(CSCSO) lib.printer.scm + $(CSC) step0_repl.scm + $(CSC) step1_read_print.scm + +cyclone: + $(CYCLONE) lib/util.sld + $(CYCLONE) lib/types.sld + $(CYCLONE) lib/reader.sld + $(CYCLONE) lib/printer.sld + $(CYCLONE) step0_repl.scm + $(CYCLONE) step1_read_print.scm + +clean: + $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta + $(RM) lib.*.scm *.so *.c *.o $(BINS) stats: $(SOURCES) @wc $^ @@ -14,4 +50,3 @@ stats: $(SOURCES) stats-lisp: $(SOURCES_LISP) @wc $^ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/scm/lib/printer.sld b/scm/lib/printer.sld new file mode 100644 index 0000000000..f7badab876 --- /dev/null +++ b/scm/lib/printer.sld @@ -0,0 +1,43 @@ +(define-library (lib printer) + +(export pr-str) + +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib types)) + +(begin + +(define (pr-str ast print-readably) + (let* ((type (and (mal-object? ast) (mal-type ast))) + (value (and type (mal-value ast)))) + (case type + ((true) "true") + ((false) "false") + ((nil) "nil") + ((number) (number->string value)) + ((string) (call-with-output-string + (lambda (port) + (if print-readably + (write value port) + (display value port))))) + ((keyword) (string-append ":" (symbol->string value))) + ((symbol) (symbol->string value)) + ((list) (pr-list value "(" ")" print-readably)) + ((vector) (pr-list (vector->list value) "[" "]" print-readably)) + ((map) (pr-list (alist->list value) "{" "}" print-readably)) + (else (error "unknown type"))))) + +(define (pr-list items starter ender print-readably) + (call-with-output-string + (lambda (port) + (display starter port) + (let ((reprs (map (lambda (item) (pr-str item print-readably)) items))) + (display (string-intersperse reprs " ") port)) + (display ender port)))) + +) + +) diff --git a/scm/lib/reader.sld b/scm/lib/reader.sld new file mode 100644 index 0000000000..c697f1da41 --- /dev/null +++ b/scm/lib/reader.sld @@ -0,0 +1,178 @@ +(define-library (lib reader) + +(export read-str) + +(import (scheme base)) +(import (scheme char)) +(import (scheme read)) +(import (scheme write)) + +(import (lib util)) +(import (lib types)) + +(begin + +(define-record-type reader + (%make-reader tokens position) + reader? + (tokens %reader-tokens) + (position %reader-position %reader-position-set!)) + +(define (make-reader tokens) + (%make-reader (list->vector tokens) 0)) + +(define (peek reader) + (let ((tokens (%reader-tokens reader)) + (position (%reader-position reader))) + (if (>= position (vector-length tokens)) + #f + (vector-ref tokens position)))) + +(define (next reader) + (let ((token (peek reader))) + (when token + (%reader-position-set! reader (+ (%reader-position reader) 1))) + token)) + +(define (read-str input) + (let* ((tokens (tokenizer input)) + (reader (make-reader tokens))) + (read-form reader))) + +(define (whitespace-char? char) + (or (char-whitespace? char) (char=? char #\,))) + +(define (special-char? char) + (memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\` #\~ #\^ #\@))) + +(define (non-word-char? char) + (or (whitespace-char? char) + (memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\" #\` #\;)))) + +(define (tokenizer input) + (call-with-input-string input + (lambda (port) + (let loop ((tokens '())) + (if (eof-object? (peek-char port)) + (reverse tokens) + (let ((char (read-char port))) + (cond + ((whitespace-char? char) + (loop tokens)) + ((and (char=? char #\~) + (char=? (peek-char port) #\@)) + (read-char port) ; remove @ token + (loop (cons "~@" tokens))) + ((char=? char #\") + (loop (cons (tokenize-string port) tokens))) + ((char=? char #\;) + (skip-comment port) + (loop tokens)) + ((special-char? char) + (loop (cons (list->string (list char)) tokens))) + (else + (loop (cons (tokenize-word port char) tokens)))))))))) + +(define (tokenize-string port) + (let loop ((chars '(#\"))) + (let ((char (read-char port))) + (cond + ((eof-object? char) + (list->string (reverse chars))) + ((char=? char #\\) + (let ((char (read-char port))) + (when (not (eof-object? char)) + (loop (cons char (cons #\\ chars)))))) + ((not (char=? char #\")) + (loop (cons char chars))) + ((char=? char #\") + (list->string (reverse (cons #\" chars)))))))) + +(define (skip-comment port) + (let loop () + (let ((char (peek-char port))) + (when (not (or (eof-object? char) + (char=? char #\newline))) + (read-char port) + (loop))))) + +(define (tokenize-word port char) + (let loop ((chars (list char))) + (let ((char (peek-char port))) + (if (or (eof-object? char) + (non-word-char? char)) + (list->string (reverse chars)) + (loop (cons (read-char port) chars)))))) + +(define (read-form reader) + (let ((token (peek reader))) + (cond + ((equal? token "'") + (read-macro reader 'quote)) + ((equal? token "`") + (read-macro reader 'quasiquote)) + ((equal? token "~") + (read-macro reader 'unquote)) + ((equal? token "~@") + (read-macro reader 'splice-unquote)) + ((equal? token "@") + (read-macro reader 'deref)) + ((equal? token "^") + (read-meta reader)) + ((equal? token "(") + (read-list reader ")" mal-list)) + ((equal? token "[") + (read-list reader "]" (lambda (items) (mal-vector (list->vector items))))) + ((equal? token "{") + (read-list reader "}" (lambda (items) (mal-map (list->alist items))))) + (else + (read-atom reader))))) + +(define (read-macro reader symbol) + (next reader) ; pop macro token + (mal-list (list (mal-symbol symbol) (read-form reader)))) + +(define (read-meta reader) + (next reader) ; pop macro token + (let ((form (read-form reader))) + (mal-list (list (mal-symbol 'with-meta) (read-form reader) form)))) + +(define (read-list reader ender proc) + (next reader) ; pop list start + (let loop ((items '())) + (let ((token (peek reader))) + (cond + ((equal? token ender) + (next reader) + (proc (reverse items))) + ((not token) + (error (str "expected '" ender "', got EOF"))) + (else + (loop (cons (read-form reader) items))))))) + +(define (read-atom reader) + (let ((token (next reader))) + (cond + ((not token) + (error "end of token stream" 'empty-input)) + ((equal? token "true") + mal-true) + ((equal? token "false") + mal-false) + ((equal? token "nil") + mal-nil) + ((string->number token) + => mal-number) + ((char=? (string-ref token 0) #\") + (let ((last (- (string-length token) 1))) + (if (char=? (string-ref token last) #\") + (mal-string (call-with-input-string token read)) + (error (str "expected '" #\" "', got EOF"))))) + ((char=? (string-ref token 0) #\:) + (mal-keyword (string->symbol (string-copy token 1)))) + (else + (mal-symbol (string->symbol token)))))) + +) + +) diff --git a/scm/lib/types.sld b/scm/lib/types.sld new file mode 100644 index 0000000000..e4702ce510 --- /dev/null +++ b/scm/lib/types.sld @@ -0,0 +1,49 @@ +(define-library (lib types) + +(export mal-object? mal-type mal-value mal-value-set! + mal-true mal-false mal-nil + mal-number mal-string mal-symbol mal-keyword + mal-list mal-vector mal-map mal-atom) + +(import (scheme base)) + +(begin + +(define-record-type mal-object + (make-mal-object type value meta) + mal-object? + (type mal-type) + (value mal-value mal-value-set!) + (meta mal-meta mal-meta-set!)) + +(define mal-true (make-mal-object 'true #t #f)) +(define mal-false (make-mal-object 'false #f #f)) +(define mal-nil (make-mal-object 'nil #f #f)) + +(define (mal-number n) + (make-mal-object 'number n #f)) + +(define (mal-string string) + (make-mal-object 'string string #f)) + +(define (mal-symbol name) + (make-mal-object 'symbol name #f)) + +(define (mal-keyword name) + (make-mal-object 'keyword name #f)) + +(define (mal-list items) + (make-mal-object 'list items #f)) + +(define (mal-vector items) + (make-mal-object 'vector items #f)) + +(define (mal-map items) + (make-mal-object 'map items #f)) + +(define (mal-atom item) + (make-mal-object 'atom item #f)) + +) + +) diff --git a/scm/lib/util.sld b/scm/lib/util.sld new file mode 100644 index 0000000000..1ed063cfcf --- /dev/null +++ b/scm/lib/util.sld @@ -0,0 +1,85 @@ +(define-library (lib util) + +(export call-with-input-string call-with-output-string + str prn debug + + ;; HACK: cyclone doesn't have those + error-object? error-object-message error-object-irritants) + +(import (scheme base)) +(import (scheme write)) + +(begin + +;; HACK: cyclone currently implements error the SICP way +(cond-expand + (cyclone + (define error-object? pair?) + (define error-object-message car) + (define error-object-irritants cdr)) + (else)) + +(define (call-with-input-string string proc) + (let ((port (open-input-string string))) + (dynamic-wind + (lambda () #t) + (lambda () (proc port)) + (lambda () (close-input-port port))))) + +(define (call-with-output-string proc) + (let ((port (open-output-string))) + (dynamic-wind + (lambda () #t) + (lambda () (proc port) (get-output-string port)) + (lambda () (close-output-port port))))) + +(define (str . items) + (call-with-output-string + (lambda (port) + (for-each (lambda (item) (display item port)) items)))) + +(define (prn . items) + (for-each write items) + (newline)) + +(define (debug . items) + (parameterize ((current-output-port (current-error-port))) + (apply prn items))) + +(define (intersperse items sep) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (let ((tail (cdr items))) + (if (null? tail) + (loop (cdr items) (cons (car items) acc)) + (loop (cdr items) (cons sep (cons (car items) acc)))))))) + +(define (string-intersperse items sep) + (apply string-append (intersperse items sep))) + +(define (list->alist items) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (let ((key (car items))) + (when (null? (cdr items)) + (error "unbalanced list")) + (let ((value (cadr items))) + (loop (cddr items) + (cons (cons key value) acc))))))) + +(define (alist->list items) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (let ((kv (car items))) + (loop (cdr items) + (cons (cdr kv) (cons (car kv) acc))))))) + +) + +) diff --git a/scm/notes.rst b/scm/notes.rst index fd1bce6049..31ca602e5b 100644 --- a/scm/notes.rst +++ b/scm/notes.rst @@ -35,6 +35,10 @@ Matrix Automatic library load y y x y n y x y ? ? ? ------------------------ --- --- --- --- --- --- --- --- --- --- --- (scheme char) y y y y n y y y ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Error objects y y y y ? y n y ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Step #1 y y y y ? y n n ? ? ? ======================== === === === === === === === === === === === Notes @@ -104,3 +108,37 @@ unfortunately Picrin doesn't implement this namespace at all and throws parts of it into ``(scheme base)`` instead, without the mandatory unicode support. This and the preceding failures are reason enough for me to exclude it from this comparison. + +Error objects +------------- + +While there is an exception system, there is no need to use ``raise`` +when the more convenient ``error`` is available. Cyclone doesn't yet +support its helper procedures though, so I've written my own +replacements for them for its current internal representation (a list +of the message and the arguments). This will most certainly break +once it actually starts supporting them... + +Step #1 +------- + +This is about whether the tests for step #1 have been passed +successfully. Foment fails here as it sends ANSI escapes to the test +rig, but works again after a recent bugfix. Cyclone had a +show-stopping bug where the last symbol token had one garbage byte too +many, I've fixed this and another bug about the write representation +locally for now. + +Bug reports +=========== + +- https://github.com/justinethier/cyclone/issues/216 +- https://github.com/justinethier/cyclone/issues/217 +- https://github.com/justinethier/cyclone/issues/219 +- https://github.com/justinethier/cyclone/issues/220 +- https://github.com/justinethier/cyclone/issues/221 +- https://github.com/leftmike/foment/issues/14 +- https://github.com/leftmike/foment/issues/15 +- https://github.com/leftmike/foment/issues/16 +- https://github.com/leftmike/foment/issues/17 +- https://github.com/leftmike/foment/issues/18 diff --git a/scm/run b/scm/run index 258c023b67..4537671a1f 100755 --- a/scm/run +++ b/scm/run @@ -1,12 +1,11 @@ #!/bin/bash case ${SCM_MODE:-chibi} in - chibi) exec chibi-scheme $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - kawa) exec kawa --r7rs $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - chicken) exec csi -R r7rs -s $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - gauche) exec gosh $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - picrin) exec picrin $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - sagittarius) exec sagittarius -n $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - cyclone) exec icyc -s $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - foment) exec foment $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + chibi) exec chibi-scheme $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + kawa) exec kawa --r7rs $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + chicken) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; + gauche) exec gosh -I. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + sagittarius) exec sagittarius -n -L. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + cyclone) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; + foment) exec foment $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; *) echo "Invalid SCM_MODE: ${SCM_MODE}"; exit 2 ;; esac diff --git a/scm/step1_read_print.scm b/scm/step1_read_print.scm new file mode 100644 index 0000000000..8c2026f06a --- /dev/null +++ b/scm/step1_read_print.scm @@ -0,0 +1,44 @@ +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) + +(define (READ input) + (read-str input)) + +(define (EVAL ast) + ast) + +(define (PRINT ast) + (pr-str ast #t)) + +(define (rep input) + (PRINT (EVAL (READ input)))) + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) From 99b66d704f1d1391ac68db91aa8f7089e967f6c5 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 4 Sep 2017 17:51:38 +0200 Subject: [PATCH 0110/1998] Implement step 2 --- scm/Makefile | 4 ++- scm/lib/util.sld | 14 ++++++++++ scm/step2_eval.scm | 70 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 87 insertions(+), 1 deletion(-) create mode 100644 scm/step2_eval.scm diff --git a/scm/Makefile b/scm/Makefile index 9959074cd3..fd4249d2f6 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -1,7 +1,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/func.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -BINS = step0_repl step1_read_print +BINS = step0_repl step1_read_print step2_eval SYMLINK = ln -sfr RM = rm -f @@ -31,6 +31,7 @@ chicken: $(CSCSO) lib.printer.scm $(CSC) step0_repl.scm $(CSC) step1_read_print.scm + $(CSC) step2_eval.scm cyclone: $(CYCLONE) lib/util.sld @@ -39,6 +40,7 @@ cyclone: $(CYCLONE) lib/printer.sld $(CYCLONE) step0_repl.scm $(CYCLONE) step1_read_print.scm + $(CYCLONE) step2_eval.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/util.sld b/scm/lib/util.sld index 1ed063cfcf..ea671f1079 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -2,6 +2,8 @@ (export call-with-input-string call-with-output-string str prn debug + string-intersperse + list->alist alist->list alist-ref alist-map ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -80,6 +82,18 @@ (loop (cdr items) (cons (cdr kv) (cons (car kv) acc))))))) +(define (alist-ref key alist) + (let loop ((items alist)) + (if (pair? items) + (let ((item (car items))) + (if (eqv? (car item) key) + (cdr item) + (loop (cdr items)))) + #f))) + +(define (alist-map proc items) + (map (lambda (item) (proc (car item) (cdr item))) items)) + ) ) diff --git a/scm/step2_eval.scm b/scm/step2_eval.scm new file mode 100644 index 0000000000..26f9038779 --- /dev/null +++ b/scm/step2_eval.scm @@ -0,0 +1,70 @@ +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (or (alist-ref value env) + (error (str "'" value "' not found")))) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (apply op ops))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env + `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) + (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) + (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) + (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))))) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) From f409e200b6a7805c3cb4d292109991778df46215 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 4 Sep 2017 19:49:02 +0200 Subject: [PATCH 0111/1998] Implement step 3 --- scm/Makefile | 8 +++- scm/lib/env.sld | 44 ++++++++++++++++++++++ scm/lib/printer.sld | 38 ++++++++++--------- scm/step3_env.scm | 91 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 162 insertions(+), 19 deletions(-) create mode 100644 scm/lib/env.sld create mode 100644 scm/step3_env.scm diff --git a/scm/Makefile b/scm/Makefile index fd4249d2f6..f0f62bdcfe 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -1,7 +1,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/func.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -BINS = step0_repl step1_read_print step2_eval +BINS = step0_repl step1_read_print step2_eval step3_env SYMLINK = ln -sfr RM = rm -f @@ -23,24 +23,30 @@ symlinks: $(SYMLINK) lib/reader.sld lib.reader.scm $(SYMLINK) lib/printer.sld lib/printer.scm $(SYMLINK) lib/printer.sld lib.printer.scm + $(SYMLINK) lib/env.sld lib/env.scm + $(SYMLINK) lib/env.sld lib.env.scm chicken: $(CSCSO) lib.util.scm $(CSCSO) lib.types.scm $(CSCSO) lib.reader.scm $(CSCSO) lib.printer.scm + $(CSCSO) lib.env.scm $(CSC) step0_repl.scm $(CSC) step1_read_print.scm $(CSC) step2_eval.scm + $(CSC) step3_env.scm cyclone: $(CYCLONE) lib/util.sld $(CYCLONE) lib/types.sld $(CYCLONE) lib/reader.sld $(CYCLONE) lib/printer.sld + $(CYCLONE) lib/env.sld $(CYCLONE) step0_repl.scm $(CYCLONE) step1_read_print.scm $(CYCLONE) step2_eval.scm + $(CYCLONE) step3_env.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/env.sld b/scm/lib/env.sld new file mode 100644 index 0000000000..cbbd1b5b8d --- /dev/null +++ b/scm/lib/env.sld @@ -0,0 +1,44 @@ +(define-library (lib env) + +(export make-env env-set env-find env-get) + +(import (scheme base)) + +(import (lib util)) + +(begin + +(define-record-type env + (%make-env outer data) + env? + (outer env-outer) + (data env-data env-data-set!)) + +(define (make-env outer . rest) + (let ((env (%make-env outer '()))) + (when (pair? rest) + (let ((binds (car rest)) + (exprs (cadr rest))) + (for-each (lambda (bind expr) (env-set env bind expr)) + binds + exprs))) + env)) + +(define (env-set env key value) + (env-data-set! env (cons (cons key value) (env-data env)))) + +(define (env-find env key) + (cond + ((alist-ref key (env-data env)) env) + ((env-outer env) => (lambda (outer) (env-find outer key))) + (else #f))) + +(define (env-get env key) + (let ((env (env-find env key))) + (if env + (alist-ref key (env-data env)) + (error (str "'" key "' not found"))))) + +) + +) diff --git a/scm/lib/printer.sld b/scm/lib/printer.sld index f7badab876..8391c24ab6 100644 --- a/scm/lib/printer.sld +++ b/scm/lib/printer.sld @@ -11,24 +11,26 @@ (begin (define (pr-str ast print-readably) - (let* ((type (and (mal-object? ast) (mal-type ast))) - (value (and type (mal-value ast)))) - (case type - ((true) "true") - ((false) "false") - ((nil) "nil") - ((number) (number->string value)) - ((string) (call-with-output-string - (lambda (port) - (if print-readably - (write value port) - (display value port))))) - ((keyword) (string-append ":" (symbol->string value))) - ((symbol) (symbol->string value)) - ((list) (pr-list value "(" ")" print-readably)) - ((vector) (pr-list (vector->list value) "[" "]" print-readably)) - ((map) (pr-list (alist->list value) "{" "}" print-readably)) - (else (error "unknown type"))))) + (if (procedure? ast) + "#" + (let* ((type (and (mal-object? ast) (mal-type ast))) + (value (and type (mal-value ast)))) + (case type + ((true) "true") + ((false) "false") + ((nil) "nil") + ((number) (number->string value)) + ((string) (call-with-output-string + (lambda (port) + (if print-readably + (write value port) + (display value port))))) + ((keyword) (string-append ":" (symbol->string value))) + ((symbol) (symbol->string value)) + ((list) (pr-list value "(" ")" print-readably)) + ((vector) (pr-list (vector->list value) "[" "]" print-readably)) + ((map) (pr-list (alist->list value) "{" "}" print-readably)) + (else (error "unknown type")))))) (define (pr-list items starter ender print-readably) (call-with-output-string diff --git a/scm/step3_env.scm b/scm/step3_env.scm new file mode 100644 index 0000000000..9046380d64 --- /dev/null +++ b/scm/step3_env.scm @@ -0,0 +1,91 @@ +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (case (mal-value (car items)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let* ((env* (make-env env)) + (binds (mal-value (cadr items))) + (binds (if (vector? binds) (vector->list binds) binds)) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (apply op ops))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) +(env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) +(env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) +(env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) From fd7da503ae11d2aaae2050a9cda53f5d51e7d59e Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 5 Sep 2017 08:33:36 +0200 Subject: [PATCH 0112/1998] Add gitignore --- scm/.gitignore | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 scm/.gitignore diff --git a/scm/.gitignore b/scm/.gitignore new file mode 100644 index 0000000000..844f88703e --- /dev/null +++ b/scm/.gitignore @@ -0,0 +1,9 @@ +lib/*.scm +lib/*.so +lib/*.c +lib/*.o +lib/*.meta +lib.*.scm +*.so +*.c +*.o From 1d20dc6b7723803ab2919e180486c651b25f72bb Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 6 Sep 2017 01:24:34 +0200 Subject: [PATCH 0113/1998] Implement step 4 --- scm/Makefile | 8 ++- scm/lib/core.sld | 84 +++++++++++++++++++++++++++++ scm/lib/env.sld | 15 ++++-- scm/lib/printer.sld | 12 ++++- scm/lib/util.sld | 7 ++- scm/notes.rst | 27 ++++++++++ scm/step4_if_fn_do.scm | 119 +++++++++++++++++++++++++++++++++++++++++ 7 files changed, 264 insertions(+), 8 deletions(-) create mode 100644 scm/lib/core.sld create mode 100644 scm/step4_if_fn_do.scm diff --git a/scm/Makefile b/scm/Makefile index f0f62bdcfe..1b3bce49c3 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -1,7 +1,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/func.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -BINS = step0_repl step1_read_print step2_eval step3_env +BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do SYMLINK = ln -sfr RM = rm -f @@ -25,6 +25,8 @@ symlinks: $(SYMLINK) lib/printer.sld lib.printer.scm $(SYMLINK) lib/env.sld lib/env.scm $(SYMLINK) lib/env.sld lib.env.scm + $(SYMLINK) lib/core.sld lib/core.scm + $(SYMLINK) lib/core.sld lib.core.scm chicken: $(CSCSO) lib.util.scm @@ -32,10 +34,12 @@ chicken: $(CSCSO) lib.reader.scm $(CSCSO) lib.printer.scm $(CSCSO) lib.env.scm + $(CSCSO) lib.core.scm $(CSC) step0_repl.scm $(CSC) step1_read_print.scm $(CSC) step2_eval.scm $(CSC) step3_env.scm + $(CSC) step4_if_fn_do.scm cyclone: $(CYCLONE) lib/util.sld @@ -43,10 +47,12 @@ cyclone: $(CYCLONE) lib/reader.sld $(CYCLONE) lib/printer.sld $(CYCLONE) lib/env.sld + $(CYCLONE) lib/core.sld $(CYCLONE) step0_repl.scm $(CYCLONE) step1_read_print.scm $(CYCLONE) step2_eval.scm $(CYCLONE) step3_env.scm + $(CYCLONE) step4_if_fn_do.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/core.sld b/scm/lib/core.sld new file mode 100644 index 0000000000..876bd0726d --- /dev/null +++ b/scm/lib/core.sld @@ -0,0 +1,84 @@ +(define-library (lib core) + +(export ns) + +(import (scheme base)) +(import (scheme write)) + +(import (lib types)) +(import (lib util)) +(import (lib printer)) + +(begin + +(define (coerce x) + (if x mal-true mal-false)) + +(define (->printed-string args print-readably sep) + (let ((items (map (lambda (arg) (pr-str arg print-readably)) args))) + (string-intersperse items sep))) + +(define (mal-equal? a b) + (let ((a-type (and (mal-object? a) (mal-type a))) + (a-value (and (mal-object? a) (mal-value a))) + (b-type (and (mal-object? b) (mal-type b))) + (b-value (and (mal-object? b) (mal-value b)))) + (cond + ((or (not a-type) (not b-type)) + mal-false) + ((and (memq a-type '(list vector)) + (memq b-type '(list vector))) + (mal-list-equal? (->list a-value) (->list b-value))) + ((and (eq? a-type 'map) (eq? b-type 'map)) + (error "TODO")) + (else + (and (eq? a-type b-type) + (equal? a-value b-value)))))) + +(define (mal-list-equal? as bs) + (let loop ((as as) + (bs bs)) + (cond + ((and (null? as) (null? bs)) #t) + ((or (null? as) (null? bs)) #f) + (else + (if (mal-equal? (car as) (car bs)) + (loop (cdr as) (cdr bs)) + #f))))) + +(define ns + `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) + (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) + (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) + (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) + + (list . ,(lambda args (mal-list args))) + (list? . ,(lambda (x) (coerce (and (mal-object? x) (eq? (mal-type x) 'list))))) + (empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis)))))) + (count . ,(lambda (lis) (mal-number + (if (eq? lis mal-nil) + 0 + (length (->list (mal-value lis))))))) + + (< . ,(lambda (a b) (coerce (< (mal-value a) (mal-value b))))) + (<= . ,(lambda (a b) (coerce (<= (mal-value a) (mal-value b))))) + (> . ,(lambda (a b) (coerce (> (mal-value a) (mal-value b))))) + (>= . ,(lambda (a b) (coerce (>= (mal-value a) (mal-value b))))) + (= . ,(lambda (a b) (coerce (mal-equal? a b)))) + + (pr-str . ,(lambda args (mal-string (->printed-string args #t " ")))) + (str . ,(lambda args (mal-string (->printed-string args #f "")))) + (prn . ,(lambda args + (display (->printed-string args #t " ")) + (newline) + mal-nil)) + (println . ,(lambda args + (display (->printed-string args #f " ")) + (newline) + mal-nil)) + + )) + +) + +) diff --git a/scm/lib/env.sld b/scm/lib/env.sld index cbbd1b5b8d..1804d78128 100644 --- a/scm/lib/env.sld +++ b/scm/lib/env.sld @@ -5,6 +5,7 @@ (import (scheme base)) (import (lib util)) +(import (lib types)) (begin @@ -17,11 +18,15 @@ (define (make-env outer . rest) (let ((env (%make-env outer '()))) (when (pair? rest) - (let ((binds (car rest)) - (exprs (cadr rest))) - (for-each (lambda (bind expr) (env-set env bind expr)) - binds - exprs))) + (let loop ((binds (car rest)) + (exprs (cadr rest))) + (when (pair? binds) + (let ((bind (car binds))) + (if (eq? bind '&) + (env-set env (cadr binds) (mal-list exprs)) + (begin + (env-set env bind (car exprs)) + (loop (cdr binds) (cdr exprs)))))))) env)) (define (env-set env key value) diff --git a/scm/lib/printer.sld b/scm/lib/printer.sld index 8391c24ab6..247350eb2f 100644 --- a/scm/lib/printer.sld +++ b/scm/lib/printer.sld @@ -23,7 +23,17 @@ ((string) (call-with-output-string (lambda (port) (if print-readably - (write value port) + (begin + (display #\" port) + (string-for-each + (lambda (char) + (case char + ((#\\) (display "\\\\" port)) + ((#\") (display "\\\"" port)) + ((#\newline) (display "\\n" port)) + (else (display char port)))) + value) + (display #\" port)) (display value port))))) ((keyword) (string-append ":" (symbol->string value))) ((symbol) (symbol->string value)) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index ea671f1079..8fc0cf54c2 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -3,7 +3,7 @@ (export call-with-input-string call-with-output-string str prn debug string-intersperse - list->alist alist->list alist-ref alist-map + list->alist alist->list alist-ref alist-map ->list ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -94,6 +94,11 @@ (define (alist-map proc items) (map (lambda (item) (proc (car item) (cdr item))) items)) +(define (->list items) + (if (vector? items) + (vector->list items) + items)) + ) ) diff --git a/scm/notes.rst b/scm/notes.rst index 31ca602e5b..af9aaab3bf 100644 --- a/scm/notes.rst +++ b/scm/notes.rst @@ -39,6 +39,10 @@ Matrix Error objects y y y y ? y n y ? ? ? ------------------------ --- --- --- --- --- --- --- --- --- --- --- Step #1 y y y y ? y n n ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + (srfi 1) y y y y y y y n ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Step #4 y y y y ? y n n ? ? ? ======================== === === === === === === === === === === === Notes @@ -129,6 +133,29 @@ show-stopping bug where the last symbol token had one garbage byte too many, I've fixed this and another bug about the write representation locally for now. +(srfi 1) +-------- + +The infamous list processing SRFI. It contains many goodies you'd +taken for granted in other programming languages, such as a procedure +for retrieving the last element of a list. All implementation except +Foment have it, so I just write my own list helpers as needed. No big +deal. + +Step #4 +------- + +Step #2 and #3 worked without any hitch, step #4 however exposes some +shortcuts I've taken. R7RS states for certain procedures that +evaluation order is unspecified to allow for optimizations for pure +functions, Cyclone makes use of this for ``map``. ``begin`` is +guaranteed to go from left to right, an explicit loop also works. My +clever trick of repurposing ``read`` and ``write`` for parsing and +serializing machine-readable strings backfired as R7RS only specifies +that backslashes and double-quotes need to be quoted, newlines may be +quoted but don't have to. For this reason I rolled my own serializer +that takes care of all of those characters. + Bug reports =========== diff --git a/scm/step4_if_fn_do.scm b/scm/step4_if_fn_do.scm new file mode 100644 index 0000000000..40b7a932eb --- /dev/null +++ b/scm/step4_if_fn_do.scm @@ -0,0 +1,119 @@ +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (case (mal-value (car items)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) + (EVAL (list-ref items 2) env)))) + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2))) + (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (apply op ops))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) From a9385e9777468eed8e72a0556f621fb60c37f55c Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 6 Sep 2017 17:40:38 +0200 Subject: [PATCH 0114/1998] Implement step 5 --- scm/Makefile | 6 ++- scm/lib/printer.sld | 66 ++++++++++++----------- scm/lib/types.sld | 12 ++++- scm/lib/util.sld | 2 +- scm/step5_tco.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 177 insertions(+), 34 deletions(-) create mode 100644 scm/step5_tco.scm diff --git a/scm/Makefile b/scm/Makefile index 1b3bce49c3..d96e3a0e58 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -1,7 +1,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld -SOURCES_LISP = lib/env.sld lib/func.sld lib/core.sld stepA_mal.scm +SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do +BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco SYMLINK = ln -sfr RM = rm -f @@ -40,6 +40,7 @@ chicken: $(CSC) step2_eval.scm $(CSC) step3_env.scm $(CSC) step4_if_fn_do.scm + $(CSC) step5_tco.scm cyclone: $(CYCLONE) lib/util.sld @@ -53,6 +54,7 @@ cyclone: $(CYCLONE) step2_eval.scm $(CYCLONE) step3_env.scm $(CYCLONE) step4_if_fn_do.scm + $(CYCLONE) step5_tco.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/printer.sld b/scm/lib/printer.sld index 247350eb2f..f921fefc05 100644 --- a/scm/lib/printer.sld +++ b/scm/lib/printer.sld @@ -11,36 +11,42 @@ (begin (define (pr-str ast print-readably) - (if (procedure? ast) - "#" - (let* ((type (and (mal-object? ast) (mal-type ast))) - (value (and type (mal-value ast)))) - (case type - ((true) "true") - ((false) "false") - ((nil) "nil") - ((number) (number->string value)) - ((string) (call-with-output-string - (lambda (port) - (if print-readably - (begin - (display #\" port) - (string-for-each - (lambda (char) - (case char - ((#\\) (display "\\\\" port)) - ((#\") (display "\\\"" port)) - ((#\newline) (display "\\n" port)) - (else (display char port)))) - value) - (display #\" port)) - (display value port))))) - ((keyword) (string-append ":" (symbol->string value))) - ((symbol) (symbol->string value)) - ((list) (pr-list value "(" ")" print-readably)) - ((vector) (pr-list (vector->list value) "[" "]" print-readably)) - ((map) (pr-list (alist->list value) "{" "}" print-readably)) - (else (error "unknown type")))))) + (cond + ((procedure? ast) + "#") + ((func? ast) + "#") + (else + (if (procedure? ast) + "#" + (let* ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((true) "true") + ((false) "false") + ((nil) "nil") + ((number) (number->string value)) + ((string) (call-with-output-string + (lambda (port) + (if print-readably + (begin + (display #\" port) + (string-for-each + (lambda (char) + (case char + ((#\\) (display "\\\\" port)) + ((#\") (display "\\\"" port)) + ((#\newline) (display "\\n" port)) + (else (display char port)))) + value) + (display #\" port)) + (display value port))))) + ((keyword) (string-append ":" (symbol->string value))) + ((symbol) (symbol->string value)) + ((list) (pr-list value "(" ")" print-readably)) + ((vector) (pr-list (vector->list value) "[" "]" print-readably)) + ((map) (pr-list (alist->list value) "{" "}" print-readably)) + (else (error "unknown type")))))))) (define (pr-list items starter ender print-readably) (call-with-output-string diff --git a/scm/lib/types.sld b/scm/lib/types.sld index e4702ce510..ca54566475 100644 --- a/scm/lib/types.sld +++ b/scm/lib/types.sld @@ -3,7 +3,9 @@ (export mal-object? mal-type mal-value mal-value-set! mal-true mal-false mal-nil mal-number mal-string mal-symbol mal-keyword - mal-list mal-vector mal-map mal-atom) + mal-list mal-vector mal-map mal-atom + + make-func func? func-ast func-params func-env func-fn) (import (scheme base)) @@ -44,6 +46,14 @@ (define (mal-atom item) (make-mal-object 'atom item #f)) +(define-record-type func + (make-func ast params env fn) + func? + (ast func-ast) + (params func-params) + (env func-env) + (fn func-fn)) + ) ) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index 8fc0cf54c2..4a6744bce5 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -41,7 +41,7 @@ (for-each (lambda (item) (display item port)) items)))) (define (prn . items) - (for-each write items) + (for-each (lambda (item) (write item) (display " ")) items) (newline)) (define (debug . items) diff --git a/scm/step5_tco.scm b/scm/step5_tco.scm new file mode 100644 index 0000000000..62ab631fb5 --- /dev/null +++ b/scm/step5_tco.scm @@ -0,0 +1,125 @@ +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (case (mal-value (car items)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) From 663059ad9beb9d6b1221318409b7cf4c18ee429e Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Thu, 7 Sep 2017 19:56:21 +0200 Subject: [PATCH 0115/1998] Implement step 6 --- scm/Makefile | 3 + scm/lib/core.sld | 31 +++++++++- scm/lib/printer.sld | 1 + scm/lib/util.sld | 8 ++- scm/notes.rst | 13 +++++ scm/step6_file.scm | 135 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 189 insertions(+), 2 deletions(-) create mode 100644 scm/step6_file.scm diff --git a/scm/Makefile b/scm/Makefile index d96e3a0e58..52df73b33b 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -2,6 +2,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco +BINS += step6_file SYMLINK = ln -sfr RM = rm -f @@ -41,6 +42,7 @@ chicken: $(CSC) step3_env.scm $(CSC) step4_if_fn_do.scm $(CSC) step5_tco.scm + $(CSC) step6_file.scm cyclone: $(CYCLONE) lib/util.sld @@ -55,6 +57,7 @@ cyclone: $(CYCLONE) step3_env.scm $(CYCLONE) step4_if_fn_do.scm $(CYCLONE) step5_tco.scm + $(CYCLONE) step6_file.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/core.sld b/scm/lib/core.sld index 876bd0726d..e76a58dfaa 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -4,16 +4,21 @@ (import (scheme base)) (import (scheme write)) +(import (scheme file)) (import (lib types)) (import (lib util)) (import (lib printer)) +(import (lib reader)) (begin (define (coerce x) (if x mal-true mal-false)) +(define (mal-instance-of? x type) + (and (mal-object? x) (eq? (mal-type x) type))) + (define (->printed-string args print-readably sep) (let ((items (map (lambda (arg) (pr-str arg print-readably)) args))) (string-intersperse items sep))) @@ -46,6 +51,17 @@ (loop (cdr as) (cdr bs)) #f))))) +(define (slurp path) + (call-with-output-string + (lambda (out) + (call-with-input-file path + (lambda (in) + (let loop () + (let ((chunk (read-string 1024 in))) + (when (not (eof-object? chunk)) + (display chunk out) + (loop))))))))) + (define ns `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) @@ -53,7 +69,7 @@ (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) (list . ,(lambda args (mal-list args))) - (list? . ,(lambda (x) (coerce (and (mal-object? x) (eq? (mal-type x) 'list))))) + (list? . ,(lambda (x) (coerce (mal-instance-of? x 'list)))) (empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis)))))) (count . ,(lambda (lis) (mal-number (if (eq? lis mal-nil) @@ -77,6 +93,19 @@ (newline) mal-nil)) + (read-string . ,(lambda (string) (read-str (mal-value string)))) + (slurp . ,(lambda (path) (mal-string (slurp (mal-value path))))) + + (atom . ,(lambda (x) (mal-atom x))) + (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom)))) + (deref . ,(lambda (atom) (mal-value atom))) + (reset! . ,(lambda (atom x) (mal-value-set! atom x) x)) + (swap! . ,(lambda (atom fn . args) + (let* ((fn (if (func? fn) (func-fn fn) fn)) + (value (apply fn (cons (mal-value atom) args)))) + (mal-value-set! atom value) + value))) + )) ) diff --git a/scm/lib/printer.sld b/scm/lib/printer.sld index f921fefc05..18fbfae74e 100644 --- a/scm/lib/printer.sld +++ b/scm/lib/printer.sld @@ -46,6 +46,7 @@ ((list) (pr-list value "(" ")" print-readably)) ((vector) (pr-list (vector->list value) "[" "]" print-readably)) ((map) (pr-list (alist->list value) "{" "}" print-readably)) + ((atom) (string-append "(atom " (pr-str value print-readably) ")")) (else (error "unknown type")))))))) (define (pr-list items starter ender print-readably) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index 4a6744bce5..f9a1ba08cf 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -3,7 +3,8 @@ (export call-with-input-string call-with-output-string str prn debug string-intersperse - list->alist alist->list alist-ref alist-map ->list + list->alist alist->list alist-ref alist-map + ->list cdr-safe ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -99,6 +100,11 @@ (vector->list items) items)) +(define (cdr-safe x) + (if (pair? x) + (cdr x) + '())) + ) ) diff --git a/scm/notes.rst b/scm/notes.rst index af9aaab3bf..ec5c3401d4 100644 --- a/scm/notes.rst +++ b/scm/notes.rst @@ -43,6 +43,8 @@ Matrix (srfi 1) y y y y y y y n ? ? ? ------------------------ --- --- --- --- --- --- --- --- --- --- --- Step #4 y y y y ? y n n ? ? ? +------------------------ --- --- --- --- --- --- --- --- --- --- --- + Step #6 y y y y ? y n y ? ? ? ======================== === === === === === === === === === === === Notes @@ -156,6 +158,16 @@ that backslashes and double-quotes need to be quoted, newlines may be quoted but don't have to. For this reason I rolled my own serializer that takes care of all of those characters. +Step #6 +------- + +Step #5 wasn't a problem either, however this step introduced basic +file I/O. To read a complete file into a string I read a fixed size +string from the file port until EOF is returned and stuff each chunk +into the string port. This strategy yields an infinite loop with +Cyclone as it doesn't ever return EOF. I've handed in a PR to fix +this. + Bug reports =========== @@ -164,6 +176,7 @@ Bug reports - https://github.com/justinethier/cyclone/issues/219 - https://github.com/justinethier/cyclone/issues/220 - https://github.com/justinethier/cyclone/issues/221 +- https://github.com/justinethier/cyclone/pull/222 - https://github.com/leftmike/foment/issues/14 - https://github.com/leftmike/foment/issues/15 - https://github.com/leftmike/foment/issues/16 diff --git a/scm/step6_file.scm b/scm/step6_file.scm new file mode 100644 index 0000000000..c90eaebb81 --- /dev/null +++ b/scm/step6_file.scm @@ -0,0 +1,135 @@ +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define argv (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? argv) + (main) + (rep (string-append "(load-file \"" (car argv) "\")"))) From 7f0ce0f00952f14a072b8f8750e39329925b3b5a Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Thu, 7 Sep 2017 19:57:04 +0200 Subject: [PATCH 0116/1998] Implement step 7 --- scm/Makefile | 4 +- scm/lib/core.sld | 3 + scm/step7_quote.scm | 163 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 169 insertions(+), 1 deletion(-) create mode 100644 scm/step7_quote.scm diff --git a/scm/Makefile b/scm/Makefile index 52df73b33b..01bf7a5e2c 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -2,7 +2,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco -BINS += step6_file +BINS += step6_file step7_quote SYMLINK = ln -sfr RM = rm -f @@ -43,6 +43,7 @@ chicken: $(CSC) step4_if_fn_do.scm $(CSC) step5_tco.scm $(CSC) step6_file.scm + $(CSC) step7_quote.scm cyclone: $(CYCLONE) lib/util.sld @@ -58,6 +59,7 @@ cyclone: $(CYCLONE) step4_if_fn_do.scm $(CYCLONE) step5_tco.scm $(CYCLONE) step6_file.scm + $(CYCLONE) step7_quote.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/core.sld b/scm/lib/core.sld index e76a58dfaa..bd8a0cef38 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -106,6 +106,9 @@ (mal-value-set! atom value) value))) + (cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs)))))) + (concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args))))) + )) ) diff --git a/scm/step7_quote.scm b/scm/step7_quote.scm new file mode 100644 index 0000000000..ea081bccba --- /dev/null +++ b/scm/step7_quote.scm @@ -0,0 +1,163 @@ +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (is-pair? ast) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (memq type '(list vector)) + (pair? (->list (mal-value ast))) + #f))) + +(define (QUASIQUOTE ast) + (if (not (is-pair? ast)) + (mal-list (list (mal-symbol 'quote) ast)) + (let* ((items (->list (mal-value ast))) + (a0 (car items))) + (if (and (mal-object? a0) + (eq? (mal-type a0) 'symbol) + (eq? (mal-value a0) 'unquote)) + (cadr items) + (if (and (is-pair? a0) + (mal-object? (car (mal-value a0))) + (eq? (mal-type (car (mal-value a0))) 'symbol) + (eq? (mal-value (car (mal-value a0))) 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) + (cadr (mal-value a0)) + (QUASIQUOTE (mal-list (cdr items))))) + (mal-list (list (mal-symbol 'cons) + (QUASIQUOTE a0) + (QUASIQUOTE (mal-list (cdr items)))))))))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) (cadr items)) + ((quasiquote) (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define argv (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? argv) + (main) + (rep (string-append "(load-file \"" (car argv) "\")"))) From 0d6f869650d48f999c5b7c70d6e9f3b7ad7ca657 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Thu, 7 Sep 2017 22:41:37 +0200 Subject: [PATCH 0117/1998] Implement step 8 --- scm/Makefile | 4 +- scm/lib/core.sld | 20 ++++- scm/lib/types.sld | 16 +++- scm/lib/util.sld | 7 +- scm/step8_macros.scm | 206 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 245 insertions(+), 8 deletions(-) create mode 100644 scm/step8_macros.scm diff --git a/scm/Makefile b/scm/Makefile index 01bf7a5e2c..b3f4542ae2 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -2,7 +2,7 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco -BINS += step6_file step7_quote +BINS += step6_file step7_quote step8_macros SYMLINK = ln -sfr RM = rm -f @@ -44,6 +44,7 @@ chicken: $(CSC) step5_tco.scm $(CSC) step6_file.scm $(CSC) step7_quote.scm + $(CSC) step8_macros.scm cyclone: $(CYCLONE) lib/util.sld @@ -60,6 +61,7 @@ cyclone: $(CYCLONE) step5_tco.scm $(CYCLONE) step6_file.scm $(CYCLONE) step7_quote.scm + $(CYCLONE) step8_macros.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/core.sld b/scm/lib/core.sld index bd8a0cef38..d969578b84 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -16,9 +16,6 @@ (define (coerce x) (if x mal-true mal-false)) -(define (mal-instance-of? x type) - (and (mal-object? x) (eq? (mal-type x) type))) - (define (->printed-string args print-readably sep) (let ((items (map (lambda (arg) (pr-str arg print-readably)) args))) (string-intersperse items sep))) @@ -108,6 +105,23 @@ (cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs)))))) (concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args))))) + (nth . ,(lambda (x n) (let ((items (->list (mal-value x))) + (index (mal-value n))) + (if (< index (length items)) + (list-ref items index) + (error (str "Out of range: " index)))))) + (first . ,(lambda (x) (if (eq? x mal-nil) + mal-nil + (let ((items (->list (mal-value x)))) + (if (null? items) + mal-nil + (car items)))))) + (rest . ,(lambda (x) (if (eq? x mal-nil) + (mal-list '()) + (let ((items (->list (mal-value x)))) + (if (null? items) + (mal-list '()) + (mal-list (cdr items))))))) )) diff --git a/scm/lib/types.sld b/scm/lib/types.sld index ca54566475..b5a8581d83 100644 --- a/scm/lib/types.sld +++ b/scm/lib/types.sld @@ -5,7 +5,10 @@ mal-number mal-string mal-symbol mal-keyword mal-list mal-vector mal-map mal-atom - make-func func? func-ast func-params func-env func-fn) + make-func func? func-ast func-params func-env + func-fn func-macro? func-macro?-set! + + mal-instance-of?) (import (scheme base)) @@ -47,12 +50,19 @@ (make-mal-object 'atom item #f)) (define-record-type func - (make-func ast params env fn) + (%make-func ast params env fn macro?) func? (ast func-ast) (params func-params) (env func-env) - (fn func-fn)) + (fn func-fn) + (macro? func-macro? func-macro?-set!)) + +(define (make-func ast params env fn) + (%make-func ast params env fn #f)) + +(define (mal-instance-of? x type) + (and (mal-object? x) (eq? (mal-type x) type))) ) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index f9a1ba08cf..44615ccb4f 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -4,7 +4,7 @@ str prn debug string-intersperse list->alist alist->list alist-ref alist-map - ->list cdr-safe + ->list car-safe cdr-safe ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -100,6 +100,11 @@ (vector->list items) items)) +(define (car-safe x) + (if (pair? x) + (car x) + '())) + (define (cdr-safe x) (if (pair? x) (cdr x) diff --git a/scm/step8_macros.scm b/scm/step8_macros.scm new file mode 100644 index 0000000000..006ed82b69 --- /dev/null +++ b/scm/step8_macros.scm @@ -0,0 +1,206 @@ +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (is-pair? ast) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (memq type '(list vector)) + (pair? (->list (mal-value ast))) + #f))) + +(define (QUASIQUOTE ast) + (if (not (is-pair? ast)) + (mal-list (list (mal-symbol 'quote) ast)) + (let* ((items (->list (mal-value ast))) + (a0 (car items))) + (if (and (mal-object? a0) + (eq? (mal-type a0) 'symbol) + (eq? (mal-value a0) 'unquote)) + (cadr items) + (if (and (is-pair? a0) + (mal-object? (car (mal-value a0))) + (eq? (mal-type (car (mal-value a0))) 'symbol) + (eq? (mal-value (car (mal-value a0))) 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) + (cadr (mal-value a0)) + (QUASIQUOTE (mal-list (cdr items))))) + (mal-list (list (mal-symbol 'cons) + (QUASIQUOTE a0) + (QUASIQUOTE (mal-list (cdr items)))))))))) + +(define (is-macro-call? ast env) + (if (mal-instance-of? ast 'list) + (let ((op (car-safe (mal-value ast)))) + (if (mal-instance-of? op 'symbol) + (let* ((symbol (mal-value op)) + (env (env-find env symbol))) + (if env + (let ((x (env-get env symbol))) + (if (and (func? x) (func-macro? x)) + #t + #f)) + #f)) + #f)) + #f)) + +(define (macroexpand ast env) + (let loop ((ast ast)) + (if (is-macro-call? ast env) + (let* ((items (mal-value ast)) + (op (car items)) + (ops (cdr items)) + (fn (func-fn (env-get env (mal-value op))))) + (loop (apply fn ops))) + ast))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (if (null? (mal-value ast)) + ast + (let* ((ast (macroexpand ast env)) + (items (mal-value ast))) + (if (not (mal-instance-of? ast 'list)) + (eval-ast ast env) + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((defmacro!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (when (func? value) + (func-macro?-set! value #t)) + (env-set env symbol value) + value)) + ((macroexpand) + (macroexpand (cadr items) env)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) + (cadr items)) + ((quasiquote) + (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define argv (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") +(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") + + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? argv) + (main) + (rep (string-append "(load-file \"" (car argv) "\")"))) From 1d117aafee2042d286294ec4018701e96c84fd38 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 8 Sep 2017 16:34:44 +0200 Subject: [PATCH 0118/1998] Implement step 9 --- scm/.gitignore | 1 + scm/Makefile | 31 ++++++- scm/lib/core.sld | 66 +++++++++++++- scm/lib/util.sld | 49 +++++++--- scm/notes.rst | 2 + scm/run | 4 +- scm/step9_try.scm | 222 ++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 358 insertions(+), 17 deletions(-) create mode 100644 scm/step9_try.scm diff --git a/scm/.gitignore b/scm/.gitignore index 844f88703e..02a300ce14 100644 --- a/scm/.gitignore +++ b/scm/.gitignore @@ -7,3 +7,4 @@ lib.*.scm *.so *.c *.o +out/ diff --git a/scm/Makefile b/scm/Makefile index b3f4542ae2..018444dc14 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -2,18 +2,20 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco -BINS += step6_file step7_quote step8_macros +BINS += step6_file step7_quote step8_macros step9_try SYMLINK = ln -sfr RM = rm -f +RMR = rm -rf -CSC = csc -O2 -R r7rs -CSCSO = csc -O2 -R r7rs -sJ +KAWA = kawa --r7rs --no-warn-unused -d out -C +CSC = csc -O3 -R r7rs +CSCSO = $(CSC) -sJ CYCLONE = cyclone -O2 all: symlinks -.PHONY: symlinks chicken cyclone clean stats stats-lisp +.PHONY: symlinks kawa chicken cyclone clean stats stats-lisp symlinks: $(SYMLINK) lib/util.sld lib/util.scm @@ -29,6 +31,24 @@ symlinks: $(SYMLINK) lib/core.sld lib/core.scm $(SYMLINK) lib/core.sld lib.core.scm +kawa: + $(KAWA) lib/util.scm + $(KAWA) lib/types.scm + $(KAWA) lib/reader.scm + $(KAWA) lib/printer.scm + $(KAWA) lib/env.scm + $(KAWA) lib/core.scm + $(KAWA) step0_repl.scm + $(KAWA) step1_read_print.scm + $(KAWA) step2_eval.scm + $(KAWA) step3_env.scm + $(KAWA) step4_if_fn_do.scm + $(KAWA) step5_tco.scm + $(KAWA) step6_file.scm + $(KAWA) step7_quote.scm + $(KAWA) step8_macros.scm + $(KAWA) step9_try.scm + chicken: $(CSCSO) lib.util.scm $(CSCSO) lib.types.scm @@ -45,6 +65,7 @@ chicken: $(CSC) step6_file.scm $(CSC) step7_quote.scm $(CSC) step8_macros.scm + $(CSC) step9_try.scm cyclone: $(CYCLONE) lib/util.sld @@ -62,10 +83,12 @@ cyclone: $(CYCLONE) step6_file.scm $(CYCLONE) step7_quote.scm $(CYCLONE) step8_macros.scm + $(CYCLONE) step9_try.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta $(RM) lib.*.scm *.so *.c *.o $(BINS) + $(RMR) out stats: $(SOURCES) @wc $^ diff --git a/scm/lib/core.sld b/scm/lib/core.sld index d969578b84..7b757daeed 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -32,7 +32,7 @@ (memq b-type '(list vector))) (mal-list-equal? (->list a-value) (->list b-value))) ((and (eq? a-type 'map) (eq? b-type 'map)) - (error "TODO")) + (mal-map-equal? a-value b-value)) (else (and (eq? a-type b-type) (equal? a-value b-value)))))) @@ -48,6 +48,39 @@ (loop (cdr as) (cdr bs)) #f))))) +(define (mal-map-ref key m . default) + (if (pair? default) + (alist-ref key m mal-equal? (car default)) + (alist-ref key m mal-equal?))) + +(define (mal-map-equal? as bs) + (if (not (= (length as) (length bs))) + #f + (let loop ((as as)) + (if (pair? as) + (let* ((item (car as)) + (key (car item)) + (value (cdr item))) + (if (mal-equal? (mal-map-ref key bs) value) + (loop (cdr as)) + #f)) + #t)))) + +(define (mal-map-dissoc m keys) + (let loop ((items m) + (acc '())) + (if (pair? items) + (let* ((item (car items)) + (key (car item))) + (if (contains? keys (lambda (x) (mal-equal? key x))) + (loop (cdr items) acc) + (loop (cdr items) (cons item acc)))) + (reverse acc)))) + +(define (mal-map-assoc m kvs) + (let ((kvs (list->alist kvs))) + (append kvs (mal-map-dissoc m (map car kvs))))) + (define (slurp path) (call-with-output-string (lambda (out) @@ -92,6 +125,7 @@ (read-string . ,(lambda (string) (read-str (mal-value string)))) (slurp . ,(lambda (path) (mal-string (slurp (mal-value path))))) + (throw . ,(lambda (x) (raise (cons 'user-error x)))) (atom . ,(lambda (x) (mal-atom x))) (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom)))) @@ -123,6 +157,36 @@ (mal-list '()) (mal-list (cdr items))))))) + (apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f) + (if (pair? (cdr args)) + (append (butlast args) + (->list (mal-value (last args)))) + (->list (mal-value (car args))))))) + (map . ,(lambda (f items) (mal-list (map (if (func? f) (func-fn f) f) + (->list (mal-value items)))))) + + (nil? . ,(lambda (x) (coerce (eq? x mal-nil)))) + (true? . ,(lambda (x) (coerce (eq? x mal-true)))) + (false? . ,(lambda (x) (coerce (eq? x mal-false)))) + (symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol)))) + (symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x))))) + (keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword)))) + (keyword . ,(lambda (x) (mal-keyword (string->symbol (mal-value x))))) + (vector? . ,(lambda (x) (coerce (mal-instance-of? x 'vector)))) + (vector . ,(lambda args (mal-vector (list->vector args)))) + (map? . ,(lambda (x) (coerce (mal-instance-of? x 'map)))) + (hash-map . ,(lambda args (mal-map (list->alist args)))) + (sequential? . ,(lambda (x) (coerce (and (mal-object? x) + (memq (mal-type x) + '(list vector)))))) + + (assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs)))) + (dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys)))) + (get . ,(lambda (m key) (mal-map-ref key (mal-value m) mal-nil))) + (contains? . ,(lambda (m key) (coerce (mal-map-ref key (mal-value m))))) + (keys . ,(lambda (m) (mal-list (map car (mal-value m))))) + (vals . ,(lambda (m) (mal-list (map cdr (mal-value m))))) + )) ) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index 44615ccb4f..0b3e8cb21d 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -4,7 +4,7 @@ str prn debug string-intersperse list->alist alist->list alist-ref alist-map - ->list car-safe cdr-safe + ->list car-safe cdr-safe contains? last butlast ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -17,7 +17,7 @@ ;; HACK: cyclone currently implements error the SICP way (cond-expand (cyclone - (define error-object? pair?) + (define (error-object? x) (and (pair? x) (string? (car x)))) (define error-object-message car) (define error-object-irritants cdr)) (else)) @@ -83,14 +83,16 @@ (loop (cdr items) (cons (cdr kv) (cons (car kv) acc))))))) -(define (alist-ref key alist) - (let loop ((items alist)) - (if (pair? items) - (let ((item (car items))) - (if (eqv? (car item) key) - (cdr item) - (loop (cdr items)))) - #f))) +(define (alist-ref key alist . args) + (let ((test (if (pair? args) (car args) eqv?)) + (default (if (> (length args) 1) (cadr args) #f))) + (let loop ((items alist)) + (if (pair? items) + (let ((item (car items))) + (if (test (car item) key) + (cdr item) + (loop (cdr items)))) + default)))) (define (alist-map proc items) (map (lambda (item) (proc (car item) (cdr item))) items)) @@ -110,6 +112,33 @@ (cdr x) '())) +(define (contains? items test) + (let loop ((items items)) + (if (pair? items) + (if (test (car items)) + #t + (loop (cdr items))) + #f))) + +(define (last items) + (when (null? items) + (error "empty argument")) + (let loop ((items items)) + (let ((tail (cdr items))) + (if (pair? tail) + (loop tail) + (car items))))) + +(define (butlast items) + (when (null? items) + (error "empty argument")) + (let loop ((items items) + (acc '())) + (let ((tail (cdr items))) + (if (pair? tail) + (loop tail (cons (car items) acc)) + (reverse acc))))) + ) ) diff --git a/scm/notes.rst b/scm/notes.rst index ec5c3401d4..4a45cc5762 100644 --- a/scm/notes.rst +++ b/scm/notes.rst @@ -177,6 +177,8 @@ Bug reports - https://github.com/justinethier/cyclone/issues/220 - https://github.com/justinethier/cyclone/issues/221 - https://github.com/justinethier/cyclone/pull/222 +- https://github.com/justinethier/cyclone/issues/224 +- https://github.com/justinethier/cyclone/issues/225 - https://github.com/leftmike/foment/issues/14 - https://github.com/leftmike/foment/issues/15 - https://github.com/leftmike/foment/issues/16 diff --git a/scm/run b/scm/run index 4537671a1f..b517126cb1 100755 --- a/scm/run +++ b/scm/run @@ -1,9 +1,9 @@ #!/bin/bash case ${SCM_MODE:-chibi} in chibi) exec chibi-scheme $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - kawa) exec kawa --r7rs $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - chicken) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; + kawa) cd $(dirname $0)/out && exec kawa -f ${STEP:-stepA_mal} "${@}" ;; gauche) exec gosh -I. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + chicken) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; sagittarius) exec sagittarius -n -L. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; cyclone) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; foment) exec foment $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; diff --git a/scm/step9_try.scm b/scm/step9_try.scm new file mode 100644 index 0000000000..ad4647337c --- /dev/null +++ b/scm/step9_try.scm @@ -0,0 +1,222 @@ +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (is-pair? ast) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (memq type '(list vector)) + (pair? (->list (mal-value ast))) + #f))) + +(define (QUASIQUOTE ast) + (if (not (is-pair? ast)) + (mal-list (list (mal-symbol 'quote) ast)) + (let* ((items (->list (mal-value ast))) + (a0 (car items))) + (if (and (mal-object? a0) + (eq? (mal-type a0) 'symbol) + (eq? (mal-value a0) 'unquote)) + (cadr items) + (if (and (is-pair? a0) + (mal-object? (car (mal-value a0))) + (eq? (mal-type (car (mal-value a0))) 'symbol) + (eq? (mal-value (car (mal-value a0))) 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) + (cadr (mal-value a0)) + (QUASIQUOTE (mal-list (cdr items))))) + (mal-list (list (mal-symbol 'cons) + (QUASIQUOTE a0) + (QUASIQUOTE (mal-list (cdr items)))))))))) + +(define (is-macro-call? ast env) + (if (mal-instance-of? ast 'list) + (let ((op (car-safe (mal-value ast)))) + (if (mal-instance-of? op 'symbol) + (let* ((symbol (mal-value op)) + (env (env-find env symbol))) + (if env + (let ((x (env-get env symbol))) + (if (and (func? x) (func-macro? x)) + #t + #f)) + #f)) + #f)) + #f)) + +(define (macroexpand ast env) + (let loop ((ast ast)) + (if (is-macro-call? ast env) + (let* ((items (mal-value ast)) + (op (car items)) + (ops (cdr items)) + (fn (func-fn (env-get env (mal-value op))))) + (loop (apply fn ops))) + ast))) + +(define (EVAL ast env) + (define (handle-catch value handler) + (let* ((symbol (mal-value (cadr handler))) + (form (list-ref handler 2)) + (env* (make-env env (list symbol) (list value)))) + (EVAL form env*))) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (if (null? (mal-value ast)) + ast + (let* ((ast (macroexpand ast env)) + (items (mal-value ast))) + (if (not (mal-instance-of? ast 'list)) + (eval-ast ast env) + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((defmacro!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (when (func? value) + (func-macro?-set! value #t)) + (env-set env symbol value) + value)) + ((macroexpand) + (macroexpand (cadr items) env)) + ((try*) + (let* ((form (cadr items)) + (handler (mal-value (list-ref items 2)))) + (guard + (ex ((error-object? ex) + (handle-catch + (mal-string (error-object-message ex)) + handler)) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (handle-catch (cdr ex) handler))) + (EVAL form env)))) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) + (cadr items)) + ((quasiquote) + (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define argv (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") +(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") + + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? argv) + (main) + (rep (string-append "(load-file \"" (car argv) "\")"))) From e0704a2b8bfdb9f09687d27988ea69b82f4d4115 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 8 Sep 2017 16:35:07 +0200 Subject: [PATCH 0119/1998] Fix warning for argv with CHICKEN --- scm/step6_file.scm | 8 ++++---- scm/step7_quote.scm | 8 ++++---- scm/step8_macros.scm | 8 ++++---- scm/step9_try.scm | 8 ++++---- 4 files changed, 16 insertions(+), 16 deletions(-) diff --git a/scm/step6_file.scm b/scm/step6_file.scm index c90eaebb81..4e39963f31 100644 --- a/scm/step6_file.scm +++ b/scm/step6_file.scm @@ -99,10 +99,10 @@ (define (rep input) (PRINT (EVAL (READ input) repl-env))) -(define argv (cdr (command-line))) +(define args (cdr (command-line))) (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -130,6 +130,6 @@ (loop)))) (newline)) -(if (null? argv) +(if (null? args) (main) - (rep (string-append "(load-file \"" (car argv) "\")"))) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/scm/step7_quote.scm b/scm/step7_quote.scm index ea081bccba..1fbc5c596c 100644 --- a/scm/step7_quote.scm +++ b/scm/step7_quote.scm @@ -127,10 +127,10 @@ (define (rep input) (PRINT (EVAL (READ input) repl-env))) -(define argv (cdr (command-line))) +(define args (cdr (command-line))) (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -158,6 +158,6 @@ (loop)))) (newline)) -(if (null? argv) +(if (null? args) (main) - (rep (string-append "(load-file \"" (car argv) "\")"))) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/scm/step8_macros.scm b/scm/step8_macros.scm index 006ed82b69..c4c22919b5 100644 --- a/scm/step8_macros.scm +++ b/scm/step8_macros.scm @@ -166,10 +166,10 @@ (define (rep input) (PRINT (EVAL (READ input) repl-env))) -(define argv (cdr (command-line))) +(define args (cdr (command-line))) (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -201,6 +201,6 @@ (loop)))) (newline)) -(if (null? argv) +(if (null? args) (main) - (rep (string-append "(load-file \"" (car argv) "\")"))) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/scm/step9_try.scm b/scm/step9_try.scm index ad4647337c..76c41c6e5d 100644 --- a/scm/step9_try.scm +++ b/scm/step9_try.scm @@ -182,10 +182,10 @@ (define (rep input) (PRINT (EVAL (READ input) repl-env))) -(define argv (cdr (command-line))) +(define args (cdr (command-line))) (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") @@ -217,6 +217,6 @@ (loop)))) (newline)) -(if (null? argv) +(if (null? args) (main) - (rep (string-append "(load-file \"" (car argv) "\")"))) + (rep (string-append "(load-file \"" (car args) "\")"))) From b2c53ccdb7dfbcae588fe73b08f9ee1b3cd4e798 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 8 Sep 2017 16:50:34 +0200 Subject: [PATCH 0120/1998] Move readline to util library --- scm/lib/util.sld | 9 +++++++++ scm/step1_read_print.scm | 8 -------- scm/step2_eval.scm | 8 -------- scm/step3_env.scm | 8 -------- scm/step4_if_fn_do.scm | 8 -------- scm/step5_tco.scm | 8 -------- scm/step6_file.scm | 8 -------- scm/step7_quote.scm | 8 -------- scm/step8_macros.scm | 8 -------- scm/step9_try.scm | 8 -------- 10 files changed, 9 insertions(+), 72 deletions(-) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index 0b3e8cb21d..c63c9ef9d1 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -5,6 +5,7 @@ string-intersperse list->alist alist->list alist-ref alist-map ->list car-safe cdr-safe contains? last butlast + readline ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -139,6 +140,14 @@ (loop tail (cons (car items) acc)) (reverse acc))))) +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + ) ) diff --git a/scm/step1_read_print.scm b/scm/step1_read_print.scm index 8c2026f06a..6cb64d0d64 100644 --- a/scm/step1_read_print.scm +++ b/scm/step1_read_print.scm @@ -18,14 +18,6 @@ (define (rep input) (PRINT (EVAL (READ input)))) -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step2_eval.scm b/scm/step2_eval.scm index 26f9038779..87db7ee741 100644 --- a/scm/step2_eval.scm +++ b/scm/step2_eval.scm @@ -44,14 +44,6 @@ (define (rep input) (PRINT (EVAL (READ input) repl-env))) -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step3_env.scm b/scm/step3_env.scm index 9046380d64..ab21a126e9 100644 --- a/scm/step3_env.scm +++ b/scm/step3_env.scm @@ -65,14 +65,6 @@ (define (rep input) (PRINT (EVAL (READ input) repl-env))) -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step4_if_fn_do.scm b/scm/step4_if_fn_do.scm index 40b7a932eb..3a112d028e 100644 --- a/scm/step4_if_fn_do.scm +++ b/scm/step4_if_fn_do.scm @@ -93,14 +93,6 @@ (rep "(def! not (fn* (a) (if a false true)))") -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step5_tco.scm b/scm/step5_tco.scm index 62ab631fb5..51506e72bd 100644 --- a/scm/step5_tco.scm +++ b/scm/step5_tco.scm @@ -99,14 +99,6 @@ (rep "(def! not (fn* (a) (if a false true)))") -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step6_file.scm b/scm/step6_file.scm index 4e39963f31..79c34e51e7 100644 --- a/scm/step6_file.scm +++ b/scm/step6_file.scm @@ -107,14 +107,6 @@ (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step7_quote.scm b/scm/step7_quote.scm index 1fbc5c596c..487a61037e 100644 --- a/scm/step7_quote.scm +++ b/scm/step7_quote.scm @@ -135,14 +135,6 @@ (rep "(def! not (fn* (a) (if a false true)))") (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step8_macros.scm b/scm/step8_macros.scm index c4c22919b5..dc974f0fcf 100644 --- a/scm/step8_macros.scm +++ b/scm/step8_macros.scm @@ -178,14 +178,6 @@ (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) diff --git a/scm/step9_try.scm b/scm/step9_try.scm index 76c41c6e5d..f828ccd175 100644 --- a/scm/step9_try.scm +++ b/scm/step9_try.scm @@ -194,14 +194,6 @@ (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - (define (main) (let loop () (let ((input (readline "user> "))) From 8e53f705b1737a24513ff8417aa5a186a67bc7e4 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 8 Sep 2017 21:06:17 +0200 Subject: [PATCH 0121/1998] Implement step A --- scm/Makefile | 26 +++--- scm/lib/core.sld | 55 ++++++++++++ scm/lib/reader.sld | 2 +- scm/lib/types.sld | 11 +-- scm/lib/util.sld | 9 +- scm/run | 2 +- scm/stepA_mal.scm | 219 +++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 305 insertions(+), 19 deletions(-) create mode 100644 scm/stepA_mal.scm diff --git a/scm/Makefile b/scm/Makefile index 018444dc14..a431e812cf 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -2,13 +2,14 @@ SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco -BINS += step6_file step7_quote step8_macros step9_try +BINS += step6_file step7_quote step8_macros step9_try stepA_mal SYMLINK = ln -sfr RM = rm -f RMR = rm -rf KAWA = kawa --r7rs --no-warn-unused -d out -C +KAWAM = kawa --r7rs --no-warn-unused -d out --main -C CSC = csc -O3 -R r7rs CSCSO = $(CSC) -sJ CYCLONE = cyclone -O2 @@ -38,16 +39,17 @@ kawa: $(KAWA) lib/printer.scm $(KAWA) lib/env.scm $(KAWA) lib/core.scm - $(KAWA) step0_repl.scm - $(KAWA) step1_read_print.scm - $(KAWA) step2_eval.scm - $(KAWA) step3_env.scm - $(KAWA) step4_if_fn_do.scm - $(KAWA) step5_tco.scm - $(KAWA) step6_file.scm - $(KAWA) step7_quote.scm - $(KAWA) step8_macros.scm - $(KAWA) step9_try.scm + $(KAWAM) step0_repl.scm + $(KAWAM) step1_read_print.scm + $(KAWAM) step2_eval.scm + $(KAWAM) step3_env.scm + $(KAWAM) step4_if_fn_do.scm + $(KAWAM) step5_tco.scm + $(KAWAM) step6_file.scm + $(KAWAM) step7_quote.scm + $(KAWAM) step8_macros.scm + $(KAWAM) step9_try.scm + $(KAWAM) stepA_mal.scm chicken: $(CSCSO) lib.util.scm @@ -66,6 +68,7 @@ chicken: $(CSC) step7_quote.scm $(CSC) step8_macros.scm $(CSC) step9_try.scm + $(CSC) stepA_mal.scm cyclone: $(CYCLONE) lib/util.sld @@ -84,6 +87,7 @@ cyclone: $(CYCLONE) step7_quote.scm $(CYCLONE) step8_macros.scm $(CYCLONE) step9_try.scm + $(CYCLONE) stepA_mal.scm clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta diff --git a/scm/lib/core.sld b/scm/lib/core.sld index 7b757daeed..37cb3820de 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -5,6 +5,7 @@ (import (scheme base)) (import (scheme write)) (import (scheme file)) +(import (scheme time)) (import (lib types)) (import (lib util)) @@ -92,6 +93,9 @@ (display chunk out) (loop))))))))) +(define (time-ms) + (* (/ (current-jiffy) (jiffies-per-second)) 1000.0)) + (define ns `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) @@ -126,6 +130,9 @@ (read-string . ,(lambda (string) (read-str (mal-value string)))) (slurp . ,(lambda (path) (mal-string (slurp (mal-value path))))) (throw . ,(lambda (x) (raise (cons 'user-error x)))) + (readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt)))) + (if output (mal-string output) mal-nil)))) + (time-ms . ,(lambda () (mal-number (time-ms)))) (atom . ,(lambda (x) (mal-atom x))) (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom)))) @@ -156,6 +163,33 @@ (if (null? items) (mal-list '()) (mal-list (cdr items))))))) + (conj . ,(lambda (coll . args) + (let ((items (mal-value coll))) + (cond + ((vector? items) + (mal-vector (vector-append items (list->vector args)))) + ((list? items) + (mal-list (append (reverse args) items))) + (else + (error "invalid collection type")))))) + (seq . ,(lambda (x) (if (eq? x mal-nil) + mal-nil + (let ((value (mal-value x))) + (case (mal-type x) + ((list) + (if (null? value) + mal-nil + x)) + ((vector) + (if (zero? (vector-length value)) + mal-nil + (mal-list (vector->list value)))) + ((string) + (if (zero? (string-length value)) + mal-nil + (mal-list (map mal-string (explode value))))) + (else + (error "invalid collection type"))))))) (apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f) (if (pair? (cdr args)) @@ -168,6 +202,7 @@ (nil? . ,(lambda (x) (coerce (eq? x mal-nil)))) (true? . ,(lambda (x) (coerce (eq? x mal-true)))) (false? . ,(lambda (x) (coerce (eq? x mal-false)))) + (string? . ,(lambda (x) (coerce (mal-instance-of? x 'string)))) (symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol)))) (symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x))))) (keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword)))) @@ -187,6 +222,26 @@ (keys . ,(lambda (m) (mal-list (map car (mal-value m))))) (vals . ,(lambda (m) (mal-list (map cdr (mal-value m))))) + (with-meta . ,(lambda (x meta) + (cond + ((mal-object? x) + (make-mal-object (mal-type x) (mal-value x) meta)) + ((func? x) + (let ((func (make-func (func-ast x) (func-params x) + (func-env x) (func-fn x)))) + (func-macro?-set! func (func-macro? x)) + (func-meta-set! func meta) + func)) + (else + (error "unsupported type"))))) + (meta . ,(lambda (x) (cond + ((mal-object? x) + (or (mal-meta x) mal-nil)) + ((func? x) + (or (func-meta x) mal-nil)) + (else + mal-nil)))) + )) ) diff --git a/scm/lib/reader.sld b/scm/lib/reader.sld index c697f1da41..6e63e9f20d 100644 --- a/scm/lib/reader.sld +++ b/scm/lib/reader.sld @@ -69,7 +69,7 @@ (skip-comment port) (loop tokens)) ((special-char? char) - (loop (cons (list->string (list char)) tokens))) + (loop (cons (char->string char) tokens))) (else (loop (cons (tokenize-word port char) tokens)))))))))) diff --git a/scm/lib/types.sld b/scm/lib/types.sld index b5a8581d83..8eebb6f854 100644 --- a/scm/lib/types.sld +++ b/scm/lib/types.sld @@ -1,12 +1,12 @@ (define-library (lib types) -(export mal-object? mal-type mal-value mal-value-set! +(export make-mal-object mal-object? mal-type mal-value mal-value-set! mal-meta mal-true mal-false mal-nil mal-number mal-string mal-symbol mal-keyword mal-list mal-vector mal-map mal-atom make-func func? func-ast func-params func-env - func-fn func-macro? func-macro?-set! + func-fn func-macro? func-macro?-set! func-meta func-meta-set! mal-instance-of?) @@ -50,16 +50,17 @@ (make-mal-object 'atom item #f)) (define-record-type func - (%make-func ast params env fn macro?) + (%make-func ast params env fn macro? meta) func? (ast func-ast) (params func-params) (env func-env) (fn func-fn) - (macro? func-macro? func-macro?-set!)) + (macro? func-macro? func-macro?-set!) + (meta func-meta func-meta-set!)) (define (make-func ast params env fn) - (%make-func ast params env fn #f)) + (%make-func ast params env fn #f #f)) (define (mal-instance-of? x type) (and (mal-object? x) (eq? (mal-type x) type))) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index c63c9ef9d1..36ee354bd5 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -2,7 +2,8 @@ (export call-with-input-string call-with-output-string str prn debug - string-intersperse + string-intersperse explode + char->string list->alist alist->list alist-ref alist-map ->list car-safe cdr-safe contains? last butlast readline @@ -63,6 +64,12 @@ (define (string-intersperse items sep) (apply string-append (intersperse items sep))) +(define (char->string char) + (list->string (list char))) + +(define (explode string) + (map char->string (string->list string))) + (define (list->alist items) (let loop ((items items) (acc '())) diff --git a/scm/run b/scm/run index b517126cb1..5dd755c7c1 100755 --- a/scm/run +++ b/scm/run @@ -1,7 +1,7 @@ #!/bin/bash case ${SCM_MODE:-chibi} in chibi) exec chibi-scheme $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - kawa) cd $(dirname $0)/out && exec kawa -f ${STEP:-stepA_mal} "${@}" ;; + kawa) java -cp /usr/share/kawa/lib/kawa.jar:out ${STEP:-stepA_mal} "${@}" ;; gauche) exec gosh -I. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; chicken) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; sagittarius) exec sagittarius -n -L. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; diff --git a/scm/stepA_mal.scm b/scm/stepA_mal.scm new file mode 100644 index 0000000000..fbfc6792db --- /dev/null +++ b/scm/stepA_mal.scm @@ -0,0 +1,219 @@ +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (is-pair? ast) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (memq type '(list vector)) + (pair? (->list (mal-value ast))) + #f))) + +(define (QUASIQUOTE ast) + (if (not (is-pair? ast)) + (mal-list (list (mal-symbol 'quote) ast)) + (let* ((items (->list (mal-value ast))) + (a0 (car items))) + (if (and (mal-object? a0) + (eq? (mal-type a0) 'symbol) + (eq? (mal-value a0) 'unquote)) + (cadr items) + (if (and (is-pair? a0) + (mal-object? (car (mal-value a0))) + (eq? (mal-type (car (mal-value a0))) 'symbol) + (eq? (mal-value (car (mal-value a0))) 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) + (cadr (mal-value a0)) + (QUASIQUOTE (mal-list (cdr items))))) + (mal-list (list (mal-symbol 'cons) + (QUASIQUOTE a0) + (QUASIQUOTE (mal-list (cdr items)))))))))) + +(define (is-macro-call? ast env) + (if (mal-instance-of? ast 'list) + (let ((op (car-safe (mal-value ast)))) + (if (mal-instance-of? op 'symbol) + (let* ((symbol (mal-value op)) + (env (env-find env symbol))) + (if env + (let ((x (env-get env symbol))) + (if (and (func? x) (func-macro? x)) + #t + #f)) + #f)) + #f)) + #f)) + +(define (macroexpand ast env) + (let loop ((ast ast)) + (if (is-macro-call? ast env) + (let* ((items (mal-value ast)) + (op (car items)) + (ops (cdr items)) + (fn (func-fn (env-get env (mal-value op))))) + (loop (apply fn ops))) + ast))) + +(define (EVAL ast env) + (define (handle-catch value handler) + (let* ((symbol (mal-value (cadr handler))) + (form (list-ref handler 2)) + (env* (make-env env (list symbol) (list value)))) + (EVAL form env*))) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (if (null? (mal-value ast)) + ast + (let* ((ast (macroexpand ast env)) + (items (mal-value ast))) + (if (not (mal-instance-of? ast 'list)) + (eval-ast ast env) + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((defmacro!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (when (func? value) + (func-macro?-set! value #t)) + (env-set env symbol value) + value)) + ((macroexpand) + (macroexpand (cadr items) env)) + ((try*) + (let* ((form (cadr items)) + (handler (mal-value (list-ref items 2)))) + (guard + (ex ((error-object? ex) + (handle-catch + (mal-string (error-object-message ex)) + handler)) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (handle-catch (cdr ex) handler))) + (EVAL form env)))) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) + (cadr items)) + ((quasiquote) + (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define args (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) +(let ((scheme (or (get-environment-variable "SCM_MODE") "chibi"))) + (env-set repl-env '*host-language* (mal-string (str "scheme (" scheme ")")))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(rep "(def! *gensym-counter* (atom 0))") +(rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))") + +(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))") +(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") + +(define (main) + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? args) + (main) + (rep (string-append "(load-file \"" (car args) "\")"))) From dda1fe77c437be7687894e53a9ac000f4e3e77a4 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 9 Sep 2017 12:29:35 +0200 Subject: [PATCH 0122/1998] Make perf tests run --- scm/.gitignore | 1 + scm/Makefile | 31 ++++++++++++++++++------------- scm/run | 18 +++++++++++------- 3 files changed, 30 insertions(+), 20 deletions(-) diff --git a/scm/.gitignore b/scm/.gitignore index 02a300ce14..2cc78f64d7 100644 --- a/scm/.gitignore +++ b/scm/.gitignore @@ -8,3 +8,4 @@ lib.*.scm *.c *.o out/ +eggs/ diff --git a/scm/Makefile b/scm/Makefile index a431e812cf..09e507fe69 100644 --- a/scm/Makefile +++ b/scm/Makefile @@ -4,13 +4,14 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco BINS += step6_file step7_quote step8_macros step9_try stepA_mal +MKDIR = mkdir -p SYMLINK = ln -sfr RM = rm -f RMR = rm -rf KAWA = kawa --r7rs --no-warn-unused -d out -C KAWAM = kawa --r7rs --no-warn-unused -d out --main -C -CSC = csc -O3 -R r7rs +CSC = CHICKEN_REPOSITORY=$(CURDIR)/eggs csc -O3 -R r7rs CSCSO = $(CSC) -sJ CYCLONE = cyclone -O2 @@ -19,18 +20,19 @@ all: symlinks .PHONY: symlinks kawa chicken cyclone clean stats stats-lisp symlinks: + $(MKDIR) eggs $(SYMLINK) lib/util.sld lib/util.scm - $(SYMLINK) lib/util.sld lib.util.scm + $(SYMLINK) lib/util.sld eggs/lib.util.scm $(SYMLINK) lib/types.sld lib/types.scm - $(SYMLINK) lib/types.sld lib.types.scm + $(SYMLINK) lib/types.sld eggs/lib.types.scm $(SYMLINK) lib/reader.sld lib/reader.scm - $(SYMLINK) lib/reader.sld lib.reader.scm + $(SYMLINK) lib/reader.sld eggs/lib.reader.scm $(SYMLINK) lib/printer.sld lib/printer.scm - $(SYMLINK) lib/printer.sld lib.printer.scm + $(SYMLINK) lib/printer.sld eggs/lib.printer.scm $(SYMLINK) lib/env.sld lib/env.scm - $(SYMLINK) lib/env.sld lib.env.scm + $(SYMLINK) lib/env.sld eggs/lib.env.scm $(SYMLINK) lib/core.sld lib/core.scm - $(SYMLINK) lib/core.sld lib.core.scm + $(SYMLINK) lib/core.sld eggs/lib.core.scm kawa: $(KAWA) lib/util.scm @@ -52,12 +54,14 @@ kawa: $(KAWAM) stepA_mal.scm chicken: - $(CSCSO) lib.util.scm - $(CSCSO) lib.types.scm - $(CSCSO) lib.reader.scm - $(CSCSO) lib.printer.scm - $(CSCSO) lib.env.scm - $(CSCSO) lib.core.scm + chicken-install -init eggs + CHICKEN_REPOSITORY=$(CURDIR)/eggs chicken-install r7rs + $(CSCSO) eggs/lib.util.scm + $(CSCSO) eggs/lib.types.scm + $(CSCSO) eggs/lib.reader.scm + $(CSCSO) eggs/lib.printer.scm + $(CSCSO) eggs/lib.env.scm + $(CSCSO) eggs/lib.core.scm $(CSC) step0_repl.scm $(CSC) step1_read_print.scm $(CSC) step2_eval.scm @@ -93,6 +97,7 @@ clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta $(RM) lib.*.scm *.so *.c *.o $(BINS) $(RMR) out + $(RMR) eggs stats: $(SOURCES) @wc $^ diff --git a/scm/run b/scm/run index 5dd755c7c1..3130ec0c81 100755 --- a/scm/run +++ b/scm/run @@ -1,11 +1,15 @@ #!/bin/bash +basedir=$(dirname $0) +kawa=${KAWA_JAR:-/usr/share/kawa/lib/kawa.jar} +step=${STEP:-stepA_mal} + case ${SCM_MODE:-chibi} in - chibi) exec chibi-scheme $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - kawa) java -cp /usr/share/kawa/lib/kawa.jar:out ${STEP:-stepA_mal} "${@}" ;; - gauche) exec gosh -I. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - chicken) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; - sagittarius) exec sagittarius -n -L. $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; - cyclone) exec $(dirname $0)/${STEP:-stepA_mal} "${@}" ;; - foment) exec foment $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" ;; + chibi) exec chibi-scheme -I$basedir $basedir/$step.scm "${@}" ;; + kawa) exec java -cp $kawa:$basedir/out $step "${@}" ;; + gauche) exec gosh -I$basedir $basedir/$step.scm "${@}" ;; + chicken) CHICKEN_REPOSITORY=$basedir/eggs exec $basedir/$step "${@}" ;; + sagittarius) exec sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;; + cyclone) exec $basedir/$step "${@}" ;; + foment) exec foment $basedir/$step.scm "${@}" ;; *) echo "Invalid SCM_MODE: ${SCM_MODE}"; exit 2 ;; esac From 0541442183ddb9a83ff149e6cf8e2b4c823b0a93 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 9 Sep 2017 12:34:18 +0200 Subject: [PATCH 0123/1998] Self-hosting fix --- scm/lib/core.sld | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/scm/lib/core.sld b/scm/lib/core.sld index 37cb3820de..8299a992a9 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -82,6 +82,13 @@ (let ((kvs (list->alist kvs))) (append kvs (mal-map-dissoc m (map car kvs))))) +(define (map-in-order proc items) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (loop (cdr items) (cons (proc (car items)) acc))))) + (define (slurp path) (call-with-output-string (lambda (out) @@ -196,8 +203,9 @@ (append (butlast args) (->list (mal-value (last args)))) (->list (mal-value (car args))))))) - (map . ,(lambda (f items) (mal-list (map (if (func? f) (func-fn f) f) - (->list (mal-value items)))))) + (map . ,(lambda (f items) (mal-list (map-in-order + (if (func? f) (func-fn f) f) + (->list (mal-value items)))))) (nil? . ,(lambda (x) (coerce (eq? x mal-nil)))) (true? . ,(lambda (x) (coerce (eq? x mal-true)))) From a43528b9dc405c38a9e1df0da726e666385c9ca2 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 9 Sep 2017 16:09:47 +0200 Subject: [PATCH 0124/1998] Implement scm-eval --- scm/lib/core.sld | 24 ++++++++++++++++++++++++ scm/tests/stepA_mal.mal | 17 +++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 scm/tests/stepA_mal.mal diff --git a/scm/lib/core.sld b/scm/lib/core.sld index 8299a992a9..b3d815376c 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -6,6 +6,9 @@ (import (scheme write)) (import (scheme file)) (import (scheme time)) +(import (scheme read)) +(import (scheme eval)) +(import (scheme repl)) (import (lib types)) (import (lib util)) @@ -103,6 +106,26 @@ (define (time-ms) (* (/ (current-jiffy) (jiffies-per-second)) 1000.0)) +(define (->mal-object x) + (cond + ((boolean? x) (if x mal-true mal-false)) + ((char? x) (mal-string (char->string x))) + ((procedure? x) x) + ((symbol? x) (mal-symbol x)) + ((number? x) (mal-number x)) + ((string? x) (mal-string x)) + ((or (null? x) (pair? x)) + (mal-list (map ->mal-object x))) + ((vector? x) + (mal-vector (vector-map ->mal-object x))) + (else + (error "unknown type")))) + +(define (scm-eval input) + (call-with-input-string input + (lambda (port) + (->mal-object (eval (read port) (interaction-environment)))))) + (define ns `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) @@ -140,6 +163,7 @@ (readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt)))) (if output (mal-string output) mal-nil)))) (time-ms . ,(lambda () (mal-number (time-ms)))) + (scm-eval . ,(lambda (input) (scm-eval (mal-value input)))) (atom . ,(lambda (x) (mal-atom x))) (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom)))) diff --git a/scm/tests/stepA_mal.mal b/scm/tests/stepA_mal.mal new file mode 100644 index 0000000000..da3f7fe3bc --- /dev/null +++ b/scm/tests/stepA_mal.mal @@ -0,0 +1,17 @@ +;; Testing basic Scheme interop + +(scm-eval "(+ 1 1)") +;=>2 + +(scm-eval "(begin (display \"Hello World!\") (newline))") +; "Hello World!" + +(scm-eval "(string->list \"MAL\")") +;=>("M" "A" "L") + +(scm-eval "(map + '(1 2 3) '(4 5 6))") +;=>(5 7 9) + +(scm-eval "(define (rot13 c) (integer->char (+ 65 (modulo (+ (- (char->integer c) 65) 13) 26))))") +(scm-eval "(string-map rot13 \"ZNY\")") +;=>"MAL" From ff3a8bf8c1aa6678a71afa7a4a69a1a9bd280ae7 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 10 Sep 2017 12:24:55 +0200 Subject: [PATCH 0125/1998] Mention Scheme in README, add instructions --- README.md | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 4cc1e729e6..913ecdec2c 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 68 languages: +Mal is implemented in 69 languages: * Ada * GNU awk @@ -68,6 +68,7 @@ Mal is implemented in 68 languages: * Ruby * Rust * Scala +* Scheme (R7RS) * Skew * Swift * Swift 3 @@ -863,6 +864,39 @@ sbt compile scala -classpath target/scala*/classes stepX_YYY ``` +### Scheme ### + +*The Scheme implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* + +The Scheme implementation of mal has been tested with Chibi-Scheme +0.7.3, Kawa 2.4, Gauche 0.9.5, CHICKEN 4.11.0, Sagittarius 0.8.3, +Cyclone 0.6.3 (Git version) and Foment 0.4 (Git version). You should +be able to get it running on other conforming R7RS implementations +after figuring out how libraries are loaded and adjusting the +`Makefile` and `run` script accordingly. + +``` +cd scm +make symlinks +# chibi +SCM_MODE=chibi ./run +# kawa +make kawa +SCM_MODE=kawa ./run +# gauche +SCM_MODE=gauche ./run +# chicken +make chicken +SCM_MODE=chicken ./run +# sagittarius +SCM_MODE=sagittarius ./run +# cyclone +make cyclone +SCM_MODE=cyclone ./run +# foment +SCM_MODE=foment ./run +``` + ### Skew ### *The Skew implementation was created by [Dov Murik](https://github.com/dubek)* From 84dee477f382c55e5df190baab5be736e11afaa7 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 10 Sep 2017 13:21:45 +0200 Subject: [PATCH 0126/1998] Improve env lookup performance considerably --- scm/lib/env.sld | 8 ++++---- scm/lib/util.sld | 4 +++- scm/step8_macros.scm | 12 +++++------- scm/step9_try.scm | 12 +++++------- scm/stepA_mal.scm | 12 +++++------- 5 files changed, 22 insertions(+), 26 deletions(-) diff --git a/scm/lib/env.sld b/scm/lib/env.sld index 1804d78128..00e4f2a2c1 100644 --- a/scm/lib/env.sld +++ b/scm/lib/env.sld @@ -34,14 +34,14 @@ (define (env-find env key) (cond - ((alist-ref key (env-data env)) env) + ((alist-ref key (env-data env)) => identity) ((env-outer env) => (lambda (outer) (env-find outer key))) (else #f))) (define (env-get env key) - (let ((env (env-find env key))) - (if env - (alist-ref key (env-data env)) + (let ((value (env-find env key))) + (if value + value (error (str "'" key "' not found"))))) ) diff --git a/scm/lib/util.sld b/scm/lib/util.sld index 36ee354bd5..05c0bdb4d6 100644 --- a/scm/lib/util.sld +++ b/scm/lib/util.sld @@ -6,7 +6,7 @@ char->string list->alist alist->list alist-ref alist-map ->list car-safe cdr-safe contains? last butlast - readline + identity readline ;; HACK: cyclone doesn't have those error-object? error-object-message error-object-irritants) @@ -147,6 +147,8 @@ (loop tail (cons (car items) acc)) (reverse acc))))) +(define (identity x) x) + (define (readline prompt) (display prompt) (flush-output-port) diff --git a/scm/step8_macros.scm b/scm/step8_macros.scm index dc974f0fcf..8df319a3d2 100644 --- a/scm/step8_macros.scm +++ b/scm/step8_macros.scm @@ -52,13 +52,11 @@ (if (mal-instance-of? ast 'list) (let ((op (car-safe (mal-value ast)))) (if (mal-instance-of? op 'symbol) - (let* ((symbol (mal-value op)) - (env (env-find env symbol))) - (if env - (let ((x (env-get env symbol))) - (if (and (func? x) (func-macro? x)) - #t - #f)) + (let ((x (env-find env (mal-value op)))) + (if x + (if (and (func? x) (func-macro? x)) + #t + #f) #f)) #f)) #f)) diff --git a/scm/step9_try.scm b/scm/step9_try.scm index f828ccd175..e9c0d3975d 100644 --- a/scm/step9_try.scm +++ b/scm/step9_try.scm @@ -52,13 +52,11 @@ (if (mal-instance-of? ast 'list) (let ((op (car-safe (mal-value ast)))) (if (mal-instance-of? op 'symbol) - (let* ((symbol (mal-value op)) - (env (env-find env symbol))) - (if env - (let ((x (env-get env symbol))) - (if (and (func? x) (func-macro? x)) - #t - #f)) + (let ((x (env-find env (mal-value op)))) + (if x + (if (and (func? x) (func-macro? x)) + #t + #f) #f)) #f)) #f)) diff --git a/scm/stepA_mal.scm b/scm/stepA_mal.scm index fbfc6792db..d5cd0da879 100644 --- a/scm/stepA_mal.scm +++ b/scm/stepA_mal.scm @@ -52,13 +52,11 @@ (if (mal-instance-of? ast 'list) (let ((op (car-safe (mal-value ast)))) (if (mal-instance-of? op 'symbol) - (let* ((symbol (mal-value op)) - (env (env-find env symbol))) - (if env - (let ((x (env-get env symbol))) - (if (and (func? x) (func-macro? x)) - #t - #f)) + (let ((x (env-find env (mal-value op)))) + (if x + (if (and (func? x) (func-macro? x)) + #t + #f) #f)) #f)) #f)) From 49352c897b326a8c2b0864b388711d47c68cd658 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 10 Sep 2017 13:28:27 +0200 Subject: [PATCH 0127/1998] Fix build with cyclone --- scm/lib/core.sld | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/scm/lib/core.sld b/scm/lib/core.sld index b3d815376c..7e62cfc1ff 100644 --- a/scm/lib/core.sld +++ b/scm/lib/core.sld @@ -8,7 +8,12 @@ (import (scheme time)) (import (scheme read)) (import (scheme eval)) -(import (scheme repl)) +;; HACK: cyclone doesn't implement environments yet, but its eval +;; behaves as if you were using the repl environment +(cond-expand + (cyclone) + (else + (import (scheme repl)))) (import (lib types)) (import (lib util)) @@ -124,7 +129,11 @@ (define (scm-eval input) (call-with-input-string input (lambda (port) - (->mal-object (eval (read port) (interaction-environment)))))) + (cond-expand + (cyclone + (->mal-object (eval (read port)))) + (else + (->mal-object (eval (read port) (interaction-environment)))))))) (define ns `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) From 4bb2ab37be6031fccd3a170e65004fad54a7e510 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 11 Sep 2017 16:45:53 -0500 Subject: [PATCH 0128/1998] Matlab: update to Octave 4.2.1 Make Octave the primary in the README description and add instructions for direct Octave execution. --- README.md | 13 +++++++------ matlab/Dockerfile | 7 ++++--- matlab/run | 2 +- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 4cc1e729e6..4ea9ab1b82 100644 --- a/README.md +++ b/README.md @@ -46,7 +46,7 @@ Mal is implemented in 68 languages: * Lua * GNU Make * mal itself -* MATLAB +* Matlab (GNU Octave and MATLAB) * [miniMAL](https://github.com/kanaka/miniMAL) * Nim * Object Pascal @@ -652,18 +652,19 @@ make ./stepX_YYY ``` -### MATLAB +### MatLab (GNU Octave and MATLAB) -The MATLAB implementation of mal has been tested with MATLAB version -R2014a on Linux. Note that MATLAB is a commercial product. It should -be fairly simple to support GNU Octave once it support classdef object -syntax. +The MatLab implementation has been tested with GNU Octave 4.2.1. +It has also been tested with MATLAB version R2014a on Linux. Note that +MATLAB is a commercial product. ``` cd matlab ./stepX_YYY +octave -q --no-gui --no-history --eval "stepX_YYY();quit;" matlab -nodisplay -nosplash -nodesktop -nojvm -r "stepX_YYY();quit;" # OR with command line arguments +octave -q --no-gui --no-history --eval "stepX_YYY('arg1','arg2');quit;" matlab -nodisplay -nosplash -nodesktop -nojvm -r "stepX_YYY('arg1','arg2');quit;" ``` diff --git a/matlab/Dockerfile b/matlab/Dockerfile index ea9afaa046..4ac3468975 100644 --- a/matlab/Dockerfile +++ b/matlab/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:xenial MAINTAINER Joel Martin ########################################################## @@ -22,8 +22,8 @@ WORKDIR /mal ########################################################## # Java and maven deps -RUN apt-get -y install openjdk-7-jdk -RUN apt-get -y install maven2 +RUN apt-get -y install openjdk-8-jdk +RUN apt-get -y install maven ENV MAVEN_OPTS -Duser.home=/mal # GNU Octave @@ -32,3 +32,4 @@ RUN apt-get -y install software-properties-common && \ apt-get -y update && \ apt-get -y install octave +ENV HOME /mal diff --git a/matlab/run b/matlab/run index 1cb6ecbbea..3d4f957efb 100755 --- a/matlab/run +++ b/matlab/run @@ -9,5 +9,5 @@ fi if [ -n "$USE_MATLAB" ] ; then exec matlab -nodisplay -nosplash -nodesktop -nojvm -r "${STEP:-stepA_mal}($args);quit;" else - exec octave --no-gui --no-history -q --traditional --eval "${STEP:-stepA_mal}($args);quit;" + exec octave -q --no-gui --no-history --eval "${STEP:-stepA_mal}($args);quit;" fi From a7b8df67156b4743bcad8d7a95b80164b56ae530 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 11 Sep 2017 23:54:50 +0200 Subject: [PATCH 0129/1998] Rename to scheme --- Makefile | 4 +- README.md | 2 +- {scm => scheme}/.gitignore | 0 {scm => scheme}/Makefile | 0 {scm => scheme}/lib/core.sld | 0 {scm => scheme}/lib/env.sld | 0 {scm => scheme}/lib/printer.sld | 0 {scm => scheme}/lib/reader.sld | 0 {scm => scheme}/lib/types.sld | 0 {scm => scheme}/lib/util.sld | 0 {scm => scheme}/run | 0 {scm => scheme}/step0_repl.scm | 0 {scm => scheme}/step1_read_print.scm | 0 {scm => scheme}/step2_eval.scm | 0 {scm => scheme}/step3_env.scm | 0 {scm => scheme}/step4_if_fn_do.scm | 0 {scm => scheme}/step5_tco.scm | 0 {scm => scheme}/step6_file.scm | 0 {scm => scheme}/step7_quote.scm | 0 {scm => scheme}/step8_macros.scm | 0 {scm => scheme}/step9_try.scm | 0 {scm => scheme}/stepA_mal.scm | 0 {scm => scheme}/tests/stepA_mal.mal | 0 scm/notes.rst | 186 --------------------------- 24 files changed, 3 insertions(+), 189 deletions(-) rename {scm => scheme}/.gitignore (100%) rename {scm => scheme}/Makefile (100%) rename {scm => scheme}/lib/core.sld (100%) rename {scm => scheme}/lib/env.sld (100%) rename {scm => scheme}/lib/printer.sld (100%) rename {scm => scheme}/lib/reader.sld (100%) rename {scm => scheme}/lib/types.sld (100%) rename {scm => scheme}/lib/util.sld (100%) rename {scm => scheme}/run (100%) rename {scm => scheme}/step0_repl.scm (100%) rename {scm => scheme}/step1_read_print.scm (100%) rename {scm => scheme}/step2_eval.scm (100%) rename {scm => scheme}/step3_env.scm (100%) rename {scm => scheme}/step4_if_fn_do.scm (100%) rename {scm => scheme}/step5_tco.scm (100%) rename {scm => scheme}/step6_file.scm (100%) rename {scm => scheme}/step7_quote.scm (100%) rename {scm => scheme}/step8_macros.scm (100%) rename {scm => scheme}/step9_try.scm (100%) rename {scm => scheme}/stepA_mal.scm (100%) rename {scm => scheme}/tests/stepA_mal.mal (100%) delete mode 100644 scm/notes.rst diff --git a/Makefile b/Makefile index ee6d07ab72..4b3ddc94b4 100644 --- a/Makefile +++ b/Makefile @@ -81,7 +81,7 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ - python r racket rexx rpython ruby rust scala scm skew swift swift3 tcl \ + python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ ts vb vhdl vimscript livescript elm EXTENSION = .mal @@ -208,7 +208,7 @@ rpython_STEP_TO_PROG = rpython/$($(1)) ruby_STEP_TO_PROG = ruby/$($(1)).rb rust_STEP_TO_PROG = rust/target/release/$($(1)) scala_STEP_TO_PROG = scala/target/scala-2.11/classes/$($(1)).class -scm_STEP_TO_PROG = scm/$($(1)).scm +scheme_STEP_TO_PROG = scheme/$($(1)).scm skew_STEP_TO_PROG = skew/$($(1)).js swift_STEP_TO_PROG = swift/$($(1)) swift3_STEP_TO_PROG = swift3/$($(1)) diff --git a/README.md b/README.md index 913ecdec2c..ac9aa7d291 100644 --- a/README.md +++ b/README.md @@ -876,7 +876,7 @@ after figuring out how libraries are loaded and adjusting the `Makefile` and `run` script accordingly. ``` -cd scm +cd scheme make symlinks # chibi SCM_MODE=chibi ./run diff --git a/scm/.gitignore b/scheme/.gitignore similarity index 100% rename from scm/.gitignore rename to scheme/.gitignore diff --git a/scm/Makefile b/scheme/Makefile similarity index 100% rename from scm/Makefile rename to scheme/Makefile diff --git a/scm/lib/core.sld b/scheme/lib/core.sld similarity index 100% rename from scm/lib/core.sld rename to scheme/lib/core.sld diff --git a/scm/lib/env.sld b/scheme/lib/env.sld similarity index 100% rename from scm/lib/env.sld rename to scheme/lib/env.sld diff --git a/scm/lib/printer.sld b/scheme/lib/printer.sld similarity index 100% rename from scm/lib/printer.sld rename to scheme/lib/printer.sld diff --git a/scm/lib/reader.sld b/scheme/lib/reader.sld similarity index 100% rename from scm/lib/reader.sld rename to scheme/lib/reader.sld diff --git a/scm/lib/types.sld b/scheme/lib/types.sld similarity index 100% rename from scm/lib/types.sld rename to scheme/lib/types.sld diff --git a/scm/lib/util.sld b/scheme/lib/util.sld similarity index 100% rename from scm/lib/util.sld rename to scheme/lib/util.sld diff --git a/scm/run b/scheme/run similarity index 100% rename from scm/run rename to scheme/run diff --git a/scm/step0_repl.scm b/scheme/step0_repl.scm similarity index 100% rename from scm/step0_repl.scm rename to scheme/step0_repl.scm diff --git a/scm/step1_read_print.scm b/scheme/step1_read_print.scm similarity index 100% rename from scm/step1_read_print.scm rename to scheme/step1_read_print.scm diff --git a/scm/step2_eval.scm b/scheme/step2_eval.scm similarity index 100% rename from scm/step2_eval.scm rename to scheme/step2_eval.scm diff --git a/scm/step3_env.scm b/scheme/step3_env.scm similarity index 100% rename from scm/step3_env.scm rename to scheme/step3_env.scm diff --git a/scm/step4_if_fn_do.scm b/scheme/step4_if_fn_do.scm similarity index 100% rename from scm/step4_if_fn_do.scm rename to scheme/step4_if_fn_do.scm diff --git a/scm/step5_tco.scm b/scheme/step5_tco.scm similarity index 100% rename from scm/step5_tco.scm rename to scheme/step5_tco.scm diff --git a/scm/step6_file.scm b/scheme/step6_file.scm similarity index 100% rename from scm/step6_file.scm rename to scheme/step6_file.scm diff --git a/scm/step7_quote.scm b/scheme/step7_quote.scm similarity index 100% rename from scm/step7_quote.scm rename to scheme/step7_quote.scm diff --git a/scm/step8_macros.scm b/scheme/step8_macros.scm similarity index 100% rename from scm/step8_macros.scm rename to scheme/step8_macros.scm diff --git a/scm/step9_try.scm b/scheme/step9_try.scm similarity index 100% rename from scm/step9_try.scm rename to scheme/step9_try.scm diff --git a/scm/stepA_mal.scm b/scheme/stepA_mal.scm similarity index 100% rename from scm/stepA_mal.scm rename to scheme/stepA_mal.scm diff --git a/scm/tests/stepA_mal.mal b/scheme/tests/stepA_mal.mal similarity index 100% rename from scm/tests/stepA_mal.mal rename to scheme/tests/stepA_mal.mal diff --git a/scm/notes.rst b/scm/notes.rst deleted file mode 100644 index 4a45cc5762..0000000000 --- a/scm/notes.rst +++ /dev/null @@ -1,186 +0,0 @@ -Key -=== - -- Chibi: c -- Kawa: k -- CHICKEN: C -- Gauche: g -- Picrin: p -- Sagitarrius: s -- Cyclone: § -- Foment: f -- Guile: G -- Racket: r -- Larceny: l - -- Works: y -- Doesn't: n -- Sort of: x -- Unknown: ? - -Matrix -====== - -======================== === === === === === === === === === === === - Scheme implementations c k C g p s § f G r l -======================== === === === === === === === === === === === - R7RS support y y y y y y y y n ? x ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Console I/O y y y y y y x n ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Step #0 y y y y y y y n ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Modules y y y y n y y y ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Automatic library load y y x y n y x y ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - (scheme char) y y y y n y y y ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Error objects y y y y ? y n y ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Step #1 y y y y ? y n n ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - (srfi 1) y y y y y y y n ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Step #4 y y y y ? y n n ? ? ? ------------------------- --- --- --- --- --- --- --- --- --- --- --- - Step #6 y y y y ? y n y ? ? ? -======================== === === === === === === === === === === === - -Notes -===== - -R7RS Support ------------- - -This is about whether I can write a script in R7RS Scheme and -successfully execute it with the implementation. Guile didn't pass -this test and the manual merely mentions it implements a few -R7RS-features (which is far from sufficient), Racket supposedly has -inofficial support for it, Larceny refuses loading up anything else -than a R7RS library. - -Console I/O ------------ - -In step 0 a REPL is implemented that echoes back user input and quits -on EOF (signalled by ``C-d``). Cyclone is weird here because its -``read-line`` procedure includes the trailing newline (fixed -upstream), Foment doesn't recognize EOF from console, but does so fine -with input redirection (as in ``(with-input-from-file "..." -read-line)``), a bug report for that is still pending. - -Step #0 -------- - -This is about whether the tests for step #0 have been passed -successfully. Foment fails this as it detects it's wired up to a tty -and probes for its cursor position before initializing its readline -implementation. This makes the test rig fail detecting a prompt. A -bug has been submitted upstream to rectify this. - -Modules -------- - -MAL requires a certain amount of modularization by splitting the -interpreter up into multiple files, for this R7RS libraries are a -natural fit. This is purely about whether the implementation allows -using code from a library file inside a script file. The only one not -passing this requirement is Picrin as it neither allows loading up -multiple files nor automatically loads up extra files. This leaves me -with just ``load`` as primitive, but this is not sufficient because I -need a relative load facility and the details on how its argument is -treated are implementation-specific. - -Automatic library load ----------------------- - -R7RS libraries are specified as a list of identifiers, commonly -translated to a nested path (for example ``(foo bar)`` translates to -``foo/bar.sld``) that is looked up in the include locations and loaded -automatically. CHICKEN translates them to ``foo.bar.scm`` and doesn't -load up source files automatically, instead you'll have to compile -libraries to importable shared libraries. Similarly, Cyclone only -loads up libraries after they've been compiled. Picrin doesn't do -anything in this regard, so only something like concatenating source -files (hello JS!) might work out. - -(scheme char) -------------- - -R7RS is split up into many base libraries, including one for char -procedures. This is necessary for tokenization of user input, -unfortunately Picrin doesn't implement this namespace at all and -throws parts of it into ``(scheme base)`` instead, without the -mandatory unicode support. This and the preceding failures are reason -enough for me to exclude it from this comparison. - -Error objects -------------- - -While there is an exception system, there is no need to use ``raise`` -when the more convenient ``error`` is available. Cyclone doesn't yet -support its helper procedures though, so I've written my own -replacements for them for its current internal representation (a list -of the message and the arguments). This will most certainly break -once it actually starts supporting them... - -Step #1 -------- - -This is about whether the tests for step #1 have been passed -successfully. Foment fails here as it sends ANSI escapes to the test -rig, but works again after a recent bugfix. Cyclone had a -show-stopping bug where the last symbol token had one garbage byte too -many, I've fixed this and another bug about the write representation -locally for now. - -(srfi 1) --------- - -The infamous list processing SRFI. It contains many goodies you'd -taken for granted in other programming languages, such as a procedure -for retrieving the last element of a list. All implementation except -Foment have it, so I just write my own list helpers as needed. No big -deal. - -Step #4 -------- - -Step #2 and #3 worked without any hitch, step #4 however exposes some -shortcuts I've taken. R7RS states for certain procedures that -evaluation order is unspecified to allow for optimizations for pure -functions, Cyclone makes use of this for ``map``. ``begin`` is -guaranteed to go from left to right, an explicit loop also works. My -clever trick of repurposing ``read`` and ``write`` for parsing and -serializing machine-readable strings backfired as R7RS only specifies -that backslashes and double-quotes need to be quoted, newlines may be -quoted but don't have to. For this reason I rolled my own serializer -that takes care of all of those characters. - -Step #6 -------- - -Step #5 wasn't a problem either, however this step introduced basic -file I/O. To read a complete file into a string I read a fixed size -string from the file port until EOF is returned and stuff each chunk -into the string port. This strategy yields an infinite loop with -Cyclone as it doesn't ever return EOF. I've handed in a PR to fix -this. - -Bug reports -=========== - -- https://github.com/justinethier/cyclone/issues/216 -- https://github.com/justinethier/cyclone/issues/217 -- https://github.com/justinethier/cyclone/issues/219 -- https://github.com/justinethier/cyclone/issues/220 -- https://github.com/justinethier/cyclone/issues/221 -- https://github.com/justinethier/cyclone/pull/222 -- https://github.com/justinethier/cyclone/issues/224 -- https://github.com/justinethier/cyclone/issues/225 -- https://github.com/leftmike/foment/issues/14 -- https://github.com/leftmike/foment/issues/15 -- https://github.com/leftmike/foment/issues/16 -- https://github.com/leftmike/foment/issues/17 -- https://github.com/leftmike/foment/issues/18 From 2d76e8776c189aaaf73120d71d24d4072c1c372f Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 11 Sep 2017 17:49:26 -0500 Subject: [PATCH 0130/1998] Generic _MODE setting. Add travis modes. For implementations that support different compile/run modes, the convention is not _MODE=. This is passed through to make/docker commands. Fix Makefiles and run scripts to listen to the respective *_MODE variables. Enable travis builds/tests for 4 Haxe modes and 2 python modes. --- .travis.yml | 11 ++++++++--- .travis_build.sh | 7 +++++-- .travis_test.sh | 5 ++++- Makefile | 25 +++++++++++++------------ README.md | 10 +++++----- clojure/Makefile | 6 +++--- clojure/run | 2 +- haxe/Makefile | 14 +++++++------- haxe/run | 4 ++-- matlab/run | 2 +- python/run | 2 +- 11 files changed, 50 insertions(+), 38 deletions(-) diff --git a/.travis.yml b/.travis.yml index fc6c6a7ffe..7d1b821db5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,8 +14,8 @@ matrix: - {env: IMPL=coffee, services: [docker]} - {env: IMPL=cs, services: [docker]} - {env: IMPL=chuck, services: [docker]} - - {env: IMPL=clojure CLJ_MODE=clj, services: [docker]} - - {env: IMPL=clojure CLJ_MODE=cljs, services: [docker]} + - {env: IMPL=clojure clojure_MODE=clj, services: [docker]} + - {env: IMPL=clojure clojure_MODE=cljs, services: [docker]} - {env: IMPL=common-lisp, services: [docker]} - {env: IMPL=crystal, services: [docker]} - {env: IMPL=d, services: [docker]} @@ -33,6 +33,10 @@ matrix: - {env: IMPL=gst, services: [docker]} - {env: IMPL=guile, services: [docker]} - {env: IMPL=haskell, services: [docker]} + - {env: IMPL=haxe haxe_MODE=neko, services: [docker]} + - {env: IMPL=haxe haxe_MODE=python, services: [docker]} + - {env: IMPL=haxe haxe_MODE=cpp, services: [docker]} + - {env: IMPL=haxe haxe_MODE=js, services: [docker]} - {env: IMPL=haxe, services: [docker]} - {env: IMPL=io, services: [docker]} - {env: IMPL=java, services: [docker]} @@ -59,7 +63,8 @@ matrix: # - {env: IMPL=plsql, services: [docker]} - {env: IMPL=ps, services: [docker]} - {env: IMPL=powershell, services: [docker]} - - {env: IMPL=python, services: [docker]} + - {env: IMPL=python python_MODE=python2, services: [docker]} + - {env: IMPL=python python_MODE=python3, services: [docker]} - {env: IMPL=r, services: [docker]} - {env: IMPL=racket, services: [docker]} - {env: IMPL=rexx, services: [docker]} diff --git a/.travis_build.sh b/.travis_build.sh index 5adf810cee..60537127f6 100755 --- a/.travis_build.sh +++ b/.travis_build.sh @@ -4,6 +4,9 @@ set -ex BUILD_IMPL=${BUILD_IMPL:-${IMPL}} +mode_var=${MAL_IMPL}_MODE +mode_val=${!mode_var} + # If NO_DOCKER is blank then launch use a docker image, otherwise # use the Travis image/tools directly. if [ -z "${NO_DOCKER}" ]; then @@ -21,9 +24,9 @@ if [ -z "${NO_DOCKER}" ]; then make -C ${BUILD_IMPL} step9_try || true fi docker run -it -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl} \ - make CLJ_MODE=${CLJ_MODE} \ + make ${mode_val:+${mode_var}=${mode_val}} \ -C ${BUILD_IMPL} else - make CLJ_MODE=${CLJ_MODE} \ + make ${mode_val:+${mode_var}=${mode_val}} \ -C ${BUILD_IMPL} fi diff --git a/.travis_test.sh b/.travis_test.sh index 0a3d95062d..c452324502 100755 --- a/.travis_test.sh +++ b/.travis_test.sh @@ -6,6 +6,9 @@ ACTION=${1} IMPL=${2} MAL_IMPL=${3:-js} +mode_var=${MAL_IMPL}_MODE +mode_val=${!mode_var} + echo "ACTION: ${ACTION}" echo "IMPL: ${IMPL}" echo "MAL_IMPL: ${MAL_IMPL}" @@ -23,7 +26,7 @@ fi ${MAKE} TEST_OPTS="--debug-file ../${ACTION}.err" \ MAL_IMPL=${MAL_IMPL} \ - CLJ_MODE=${CLJ_MODE} \ + ${mode_val:+${mode_var}=${mode_val}} \ ${ACTION}^${IMPL} # no failure so remove error log diff --git a/Makefile b/Makefile index 20a663629d..6f0ff1a894 100644 --- a/Makefile +++ b/Makefile @@ -44,12 +44,14 @@ all help: MAL_IMPL = js -PYTHON = python -USE_MATLAB = -# python, js, cpp, or neko are currently supported -HAXE_MODE = neko -# clj or cljs are currently supported (Clojure vs ClojureScript/lumo) -CLJ_MODE = clj +# clj or cljs (Clojure vs ClojureScript/lumo) +clojure_MODE = clj +# python, js, cpp, or neko +haxe_MODE = neko +# octave or matlab +matlab_MODE = octave +# python, python2 or python3 +python_MODE = python # Extra options to pass to runtest.py TEST_OPTS = @@ -159,7 +161,7 @@ basic_STEP_TO_PROG = basic/$($(1)).bas c_STEP_TO_PROG = c/$($(1)) d_STEP_TO_PROG = d/$($(1)) chuck_STEP_TO_PROG = chuck/$($(1)).ck -clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(CLJ_MODE)) +clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(clojure_MODE)) coffee_STEP_TO_PROG = coffee/$($(1)).coffee common-lisp_STEP_TO_PROG = common-lisp/$($(1)) cpp_STEP_TO_PROG = cpp/$($(1)) @@ -178,7 +180,7 @@ groovy_STEP_TO_PROG = groovy/$($(1)).groovy gst_STEP_TO_PROG = gst/$($(1)).st java_STEP_TO_PROG = java/target/classes/mal/$($(1)).class haskell_STEP_TO_PROG = haskell/$($(1)) -haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(HAXE_MODE)) +haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(haxe_MODE)) io_STEP_TO_PROG = io/$($(1)).io julia_STEP_TO_PROG = julia/$($(1)).jl js_STEP_TO_PROG = js/$($(1)).js @@ -242,7 +244,7 @@ get_build_prefix = $(strip $(if $(strip $(DOCKERIZE)),\ -it --rm -u $(shell id -u) \ -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ -w /mal/$(1) \ - $(if $(filter clojure,$(1)),-e CLJ_MODE=$(CLJ_MODE),) \ + $(if $(strip $($(1)_MODE)),-e $(1)_MODE=$($(1)_MODE),) \ $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ $(call impl_to_image,$(1)) \ ,)) @@ -255,14 +257,13 @@ get_run_prefix = $(strip $(if $(strip $(DOCKERIZE)),\ -it --rm -u $(shell id -u) \ -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ -w /mal/$(call actual_impl,$(1)) \ - $(if $(filter clojure,$(1)),-e CLJ_MODE=$(CLJ_MODE),) \ - $(if $(filter haxe,$(1)),-e HAXE_MODE=$(HAXE_MODE),) \ + $(if $(strip $($(1)_MODE)),-e $(1)_MODE=$($(1)_MODE),) \ $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ $(foreach env,$(3),-e $(env)) \ $(call impl_to_image,$(call actual_impl,$(1))) \ ,\ env STEP=$($2) MAL_IMPL=$(MAL_IMPL) \ - $(if $(filter haxe,$(1)),HAXE_MODE=$(HAXE_MODE),) \ + $(if $(strip $($(1)_MODE)),$(1)_MODE=$($(1)_MODE),) \ $(if $(filter factor,$(1)),FACTOR_ROOTS=$(FACTOR_ROOTS),) \ $(3))) diff --git a/README.md b/README.md index 4ea9ab1b82..1b10efd04b 100644 --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ Mal is implemented in 68 languages: * C# * ChucK * Common Lisp -* Clojure +* Clojure (Clojure and ClojureScript) * CoffeeScript * Crystal * D @@ -35,7 +35,7 @@ Mal is implemented in 68 languages: * GNU Guile * GNU Smalltalk * Haskell -* Haxe +* Haxe (Neko, Python, C++ and JavaScript) * Io * Java * JavaScript ([Online Demo](http://kanaka.github.io/mal)) @@ -60,7 +60,7 @@ Mal is implemented in 68 languages: * PL/SQL (Oracle) * Postscript * PowerShell -* Python +* Python (2.X and 3.X) * RPython * R * Racket @@ -478,7 +478,7 @@ make ./stepX_YYY ``` -### Haxe +### Haxe (Neko, Python, C++ and JavaScript) The Haxe implementation of mal requires Haxe version 3.2 to compile. Four different Haxe targets are supported: Neko, Python, C++, and @@ -785,7 +785,7 @@ cd powershell powershell ./stepX_YYY.ps1 ``` -### Python (2.X or 3.X) +### Python (2.X and 3.X) ``` cd python diff --git a/clojure/Makefile b/clojure/Makefile index 4c468efd29..c77d1c2f27 100644 --- a/clojure/Makefile +++ b/clojure/Makefile @@ -1,11 +1,11 @@ -CLJ_MODE ?= clj -SOURCES_UTIL = src/mal/readline.$(CLJ_MODE) +clojure_MODE ?= clj +SOURCES_UTIL = src/mal/readline.$(clojure_MODE) SOURCES_BASE = $(SOURCES_UTIL) src/mal/printer.cljc SOURCES_LISP = src/mal/env.cljc src/mal/core.cljc src/mal/stepA_mal.cljc SRCS = $(SOURCES_BASE) src/mal/env.cljc src/mal/core.cljc SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -DEPS = $(if $(filter cljs,$(CLJ_MODE)),node_modules,deps) +DEPS = $(if $(filter cljs,$(clojure_MODE)),node_modules,deps) dist: mal.jar mal diff --git a/clojure/run b/clojure/run index 54c14f8014..f74eba6f25 100755 --- a/clojure/run +++ b/clojure/run @@ -1,7 +1,7 @@ #!/bin/bash export PATH=$PATH:$(dirname $0)/node_modules/.bin STEP=${STEP:-stepA_mal} -if [ "${CLJ_MODE}" = "cljs" ]; then +if [ "${clojure_MODE}" = "cljs" ]; then exec lumo -c $(dirname $0)/src -m mal.${STEP//_/-} "${@}" else exec java -jar $(dirname $0)/target/${STEP}.jar "${@}" diff --git a/haxe/Makefile b/haxe/Makefile index 30ad30088e..6af11e251f 100644 --- a/haxe/Makefile +++ b/haxe/Makefile @@ -8,7 +8,7 @@ STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ step8_macros step9_try stepA_mal -HAXE_DIST_MODE = neko +haxe_MODE = neko dist_neko = mal.n dist_python = mal.py dist_cpp = cpp/mal @@ -38,18 +38,18 @@ mal.js: stepA_mal.js cp $< $@ -mal: $(dist_$(HAXE_DIST_MODE)) - $(if $(filter cpp,$(HAXE_DIST_MODE)),\ +mal: $(dist_$(haxe_MODE)) + $(if $(filter cpp,$(haxe_MODE)),\ cp $< $@;,\ - $(if $(filter neko,$(HAXE_DIST_MODE)),\ + $(if $(filter neko,$(haxe_MODE)),\ nekotools boot $<;,\ - $(if $(filter js,$(HAXE_DIST_MODE)),\ + $(if $(filter js,$(haxe_MODE)),\ echo "#!/usr/bin/env node" > $@;\ cat $< >> $@;,\ - $(if $(filter python,$(HAXE_DIST_MODE)),\ + $(if $(filter python,$(haxe_MODE)),\ echo "#!/usr/bin/env python3" > $@;\ cat $< >> $@;,\ - $(error Invalid HAXE_DIST_MODE: $(HAXE_DIST_MODE)))))) + $(error Invalid haxe_MODE: $(haxe_MODE)))))) chmod +x $@ diff --git a/haxe/run b/haxe/run index 4adaf760e9..6011b6c1e1 100755 --- a/haxe/run +++ b/haxe/run @@ -1,8 +1,8 @@ #!/bin/bash -case ${HAXE_MODE:-neko} in +case ${haxe_MODE:-neko} in neko) exec neko $(dirname $0)/${STEP:-stepA_mal}.n "${@}" ;; python) exec python3 $(dirname $0)/${STEP:-stepA_mal}.py "${@}" ;; js) exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" ;; cpp) exec $(dirname $0)/cpp/${STEP:-stepA_mal} "${@}" ;; - *) echo "Invalid HAXE_MODE: ${HAXE_MODE}"; exit 2 ;; + *) echo "Invalid haxe_MODE: ${haxe_MODE}"; exit 2 ;; esac diff --git a/matlab/run b/matlab/run index 3d4f957efb..e3f209dea1 100755 --- a/matlab/run +++ b/matlab/run @@ -6,7 +6,7 @@ if [ "$#" -gt 0 ]; then args="$args,'$a'" done fi -if [ -n "$USE_MATLAB" ] ; then +if [ "$matlab_MODE" = "matlab" ] ; then exec matlab -nodisplay -nosplash -nodesktop -nojvm -r "${STEP:-stepA_mal}($args);quit;" else exec octave -q --no-gui --no-history --eval "${STEP:-stepA_mal}($args);quit;" diff --git a/python/run b/python/run index 09220ec06a..7549617761 100755 --- a/python/run +++ b/python/run @@ -1,2 +1,2 @@ #!/bin/bash -exec python $(dirname $0)/${STEP:-stepA_mal}.py "${@}" +exec ${python_MODE:-python} $(dirname $0)/${STEP:-stepA_mal}.py "${@}" From 49aa3e96ea63bec7688746f857291c02fd6c9e61 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 11 Sep 2017 18:10:24 -0500 Subject: [PATCH 0131/1998] Remove redundant Haxe travis test. --- .travis.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 7d1b821db5..a107abdfae 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,7 +37,6 @@ matrix: - {env: IMPL=haxe haxe_MODE=python, services: [docker]} - {env: IMPL=haxe haxe_MODE=cpp, services: [docker]} - {env: IMPL=haxe haxe_MODE=js, services: [docker]} - - {env: IMPL=haxe, services: [docker]} - {env: IMPL=io, services: [docker]} - {env: IMPL=java, services: [docker]} - {env: IMPL=js, services: [docker]} From 85bb01d0bb0bff8afb5e5686f238dc880aef1ea4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 11 Sep 2017 18:23:32 -0500 Subject: [PATCH 0132/1998] Fix conveyance of *_MODE variables to build rules. --- Makefile | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index 6f0ff1a894..623a8f6795 100644 --- a/Makefile +++ b/Makefile @@ -239,7 +239,7 @@ actual_impl = $(if $(filter mal,$(1)),$(MAL_IMPL),$(1)) # Returns nothing if DOCKERIZE is not set, otherwise returns the # docker prefix necessary to run make within the docker environment # for this impl -get_build_prefix = $(strip $(if $(strip $(DOCKERIZE)),\ +get_build_command = $(strip $(if $(strip $(DOCKERIZE)),\ docker run \ -it --rm -u $(shell id -u) \ -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ @@ -247,7 +247,9 @@ get_build_prefix = $(strip $(if $(strip $(DOCKERIZE)),\ $(if $(strip $($(1)_MODE)),-e $(1)_MODE=$($(1)_MODE),) \ $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ $(call impl_to_image,$(1)) \ - ,)) + $(MAKE) $(if $(strip $($(1)_MODE)),$(1)_MODE=$($(1)_MODE),) \ + ,\ + $(MAKE) $(if $(strip $($(1)_MODE)),$(1)_MODE=$($(1)_MODE),))) # Takes impl and step arguments # Returns a command prefix (docker command and environment variables) @@ -313,8 +315,8 @@ ALL_REPL = $(strip $(sort \ $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))): $(foreach impl,$(word 1,$(subst /, ,$(@))),\ $(if $(DOCKERIZE), \ - $(call get_build_prefix,$(impl)) $(MAKE) $(patsubst $(impl)/%,%,$(@)), \ - $(MAKE) -C $(impl) $(subst $(impl)/,,$(@)))) + $(call get_build_command,$(impl)) $(patsubst $(impl)/%,%,$(@)), \ + $(call get_build_command,$(impl)) -C $(impl) $(subst $(impl)/,,$(@)))) # Allow IMPL, and IMPL^STEP .SECONDEXPANSION: @@ -441,10 +443,10 @@ $(2): @echo "----------------------------------------------"; \ $$(foreach impl,$$(word 2,$$(subst ^, ,$$(@))),\ $$(if $$(DOCKERIZE), \ - echo "Running: $$(call get_build_prefix,$$(impl))$$(MAKE) --no-print-directory $(1)"; \ - $$(call get_build_prefix,$$(impl))$$(MAKE) --no-print-directory $(1), \ - echo "Running: $$(MAKE) --no-print-directory -C $$(impl) $(1)"; \ - $$(MAKE) --no-print-directory -C $$(impl) $(1))) + echo "Running: $$(call get_build_command,$$(impl)) --no-print-directory $(1)"; \ + $$(call get_build_command,$$(impl)) --no-print-directory $(1), \ + echo "Running: $$(call get_build_command,$$(impl)) --no-print-directory -C $$(impl) $(1)"; \ + $$(call get_build_command,$$(impl)) --no-print-directory -C $$(impl) $(1))) endef recur_impls_ = $(filter-out $(foreach impl,$($(1)_EXCLUDES),$(1)^$(impl)),$(foreach impl,$(IMPLS),$(1)^$(impl))) From 6e8730c4eb88ada19ba28473a59519d0052647e6 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 11 Sep 2017 18:30:29 -0500 Subject: [PATCH 0133/1998] Fix IMPL variables in travis scripts. --- .travis_build.sh | 2 +- .travis_test.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis_build.sh b/.travis_build.sh index 60537127f6..d47a2939f5 100755 --- a/.travis_build.sh +++ b/.travis_build.sh @@ -4,7 +4,7 @@ set -ex BUILD_IMPL=${BUILD_IMPL:-${IMPL}} -mode_var=${MAL_IMPL}_MODE +mode_var=${IMPL}_MODE mode_val=${!mode_var} # If NO_DOCKER is blank then launch use a docker image, otherwise diff --git a/.travis_test.sh b/.travis_test.sh index c452324502..cafb005faa 100755 --- a/.travis_test.sh +++ b/.travis_test.sh @@ -6,7 +6,7 @@ ACTION=${1} IMPL=${2} MAL_IMPL=${3:-js} -mode_var=${MAL_IMPL}_MODE +mode_var=${IMPL}_MODE mode_val=${!mode_var} echo "ACTION: ${ACTION}" From 458852b23a5e7fd08ea1bd0e588a93cd21e3ba98 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 11 Sep 2017 23:28:00 -0500 Subject: [PATCH 0134/1998] Clojure, Haxe: all target based on MODE. --- clojure/Makefile | 2 +- haxe/Makefile | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/clojure/Makefile b/clojure/Makefile index c77d1c2f27..f994b5ea0a 100644 --- a/clojure/Makefile +++ b/clojure/Makefile @@ -7,7 +7,7 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) DEPS = $(if $(filter cljs,$(clojure_MODE)),node_modules,deps) -dist: mal.jar mal +dist: $(if $(filter cljs,$(clojure_MODE)),,mal.jar mal) deps: lein deps diff --git a/haxe/Makefile b/haxe/Makefile index 6af11e251f..0602c9edf7 100644 --- a/haxe/Makefile +++ b/haxe/Makefile @@ -8,12 +8,12 @@ STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ step8_macros step9_try stepA_mal -haxe_MODE = neko +haxe_MODE ?= neko dist_neko = mal.n dist_python = mal.py dist_cpp = cpp/mal -all: all-neko all-python all-cpp all-js +all: all-$(haxe_MODE) all-neko: $(foreach x,$(STEPS),$(x).n) From df2cc0c51cfe09e5c17b29111cbdf3aec4000850 Mon Sep 17 00:00:00 2001 From: Poeticode Date: Tue, 12 Sep 2017 00:36:27 -0400 Subject: [PATCH 0135/1998] Rename mal's Error class to _Error --- php/core.php | 2 +- php/step9_try.php | 2 +- php/stepA_mal.php | 2 +- php/types.php | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/php/core.php b/php/core.php index 78f107e3a0..49c63246fa 100644 --- a/php/core.php +++ b/php/core.php @@ -6,7 +6,7 @@ require_once 'printer.php'; // Error/Exception functions -function mal_throw($obj) { throw new Error($obj); } +function mal_throw($obj) { throw new _Error($obj); } // String functions diff --git a/php/step9_try.php b/php/step9_try.php index 1f6e8b0612..7b03d4ecfe 100644 --- a/php/step9_try.php +++ b/php/step9_try.php @@ -119,7 +119,7 @@ function MAL_EVAL($ast, $env) { if ($a2[0]->value === "catch*") { try { return MAL_EVAL($a1, $env); - } catch (Error $e) { + } catch (_Error $e) { $catch_env = new Env($env, array($a2[1]), array($e->obj)); return MAL_EVAL($a2[2], $catch_env); diff --git a/php/stepA_mal.php b/php/stepA_mal.php index 2ac4c301a3..65652ef3e0 100644 --- a/php/stepA_mal.php +++ b/php/stepA_mal.php @@ -124,7 +124,7 @@ function MAL_EVAL($ast, $env) { if ($a2[0]->value === "catch*") { try { return MAL_EVAL($a1, $env); - } catch (Error $e) { + } catch (_Error $e) { $catch_env = new Env($env, array($a2[1]), array($e->obj)); return MAL_EVAL($a2[2], $catch_env); diff --git a/php/types.php b/php/types.php index d7dbdacf82..1279f88f8e 100644 --- a/php/types.php +++ b/php/types.php @@ -2,7 +2,7 @@ // Errors/Exceptions -class Error extends Exception { +class _Error extends Exception { public $obj = null; public function __construct($obj) { parent::__construct("Mal Error", 0, null); From 6c0968a6a4517b2db733eaa73968821d48372371 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 12 Sep 2017 09:44:51 +0200 Subject: [PATCH 0136/1998] Make use of scheme_MODE --- README.md | 16 ++++++++-------- scheme/Makefile | 11 +++++++++-- scheme/run | 4 ++-- scheme/stepA_mal.scm | 2 +- 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index ac9aa7d291..a192c23329 100644 --- a/README.md +++ b/README.md @@ -864,7 +864,7 @@ sbt compile scala -classpath target/scala*/classes stepX_YYY ``` -### Scheme ### +### Scheme (R7RS) ### *The Scheme implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* @@ -879,22 +879,22 @@ after figuring out how libraries are loaded and adjusting the cd scheme make symlinks # chibi -SCM_MODE=chibi ./run +scheme_MODE=chibi ./run # kawa make kawa -SCM_MODE=kawa ./run +scheme_MODE=kawa ./run # gauche -SCM_MODE=gauche ./run +scheme_MODE=gauche ./run # chicken make chicken -SCM_MODE=chicken ./run +scheme_MODE=chicken ./run # sagittarius -SCM_MODE=sagittarius ./run +scheme_MODE=sagittarius ./run # cyclone make cyclone -SCM_MODE=cyclone ./run +scheme_MODE=cyclone ./run # foment -SCM_MODE=foment ./run +scheme_MODE=foment ./run ``` ### Skew ### diff --git a/scheme/Makefile b/scheme/Makefile index 09e507fe69..260c713d53 100644 --- a/scheme/Makefile +++ b/scheme/Makefile @@ -3,6 +3,7 @@ SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco BINS += step6_file step7_quote step8_macros step9_try stepA_mal +scheme_MODE ?= chibi MKDIR = mkdir -p SYMLINK = ln -sfr @@ -15,9 +16,15 @@ CSC = CHICKEN_REPOSITORY=$(CURDIR)/eggs csc -O3 -R r7rs CSCSO = $(CSC) -sJ CYCLONE = cyclone -O2 -all: symlinks +DEPS = $(if $(filter kawa,$(scheme_MODE)),kawa,\ + $(if $(filter chicken,$(scheme_MODE)),chicken,\ + $(if $(filter cyclone,$(scheme_MODE)),cyclone))) -.PHONY: symlinks kawa chicken cyclone clean stats stats-lisp +all: symlinks build + +.PHONY: symlinks build kawa chicken cyclone clean stats stats-lisp + +build: $(DEPS) symlinks: $(MKDIR) eggs diff --git a/scheme/run b/scheme/run index 3130ec0c81..80498c456e 100755 --- a/scheme/run +++ b/scheme/run @@ -3,7 +3,7 @@ basedir=$(dirname $0) kawa=${KAWA_JAR:-/usr/share/kawa/lib/kawa.jar} step=${STEP:-stepA_mal} -case ${SCM_MODE:-chibi} in +case ${scheme_MODE:-chibi} in chibi) exec chibi-scheme -I$basedir $basedir/$step.scm "${@}" ;; kawa) exec java -cp $kawa:$basedir/out $step "${@}" ;; gauche) exec gosh -I$basedir $basedir/$step.scm "${@}" ;; @@ -11,5 +11,5 @@ case ${SCM_MODE:-chibi} in sagittarius) exec sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;; cyclone) exec $basedir/$step "${@}" ;; foment) exec foment $basedir/$step.scm "${@}" ;; - *) echo "Invalid SCM_MODE: ${SCM_MODE}"; exit 2 ;; + *) echo "Invalid scheme_MODE: ${scheme_MODE}"; exit 2 ;; esac diff --git a/scheme/stepA_mal.scm b/scheme/stepA_mal.scm index d5cd0da879..f2da4e98f8 100644 --- a/scheme/stepA_mal.scm +++ b/scheme/stepA_mal.scm @@ -184,7 +184,7 @@ (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) -(let ((scheme (or (get-environment-variable "SCM_MODE") "chibi"))) +(let ((scheme (or (get-environment-variable "scheme_MODE") "chibi"))) (env-set repl-env '*host-language* (mal-string (str "scheme (" scheme ")")))) (rep "(def! not (fn* (a) (if a false true)))") From edd7e9c2599d70f301c17f1daa19eb87760d459c Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 12 Sep 2017 08:57:01 -0500 Subject: [PATCH 0137/1998] Haxe: skip step5 when cpp MODE. --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 623a8f6795..125fc39e5c 100644 --- a/Makefile +++ b/Makefile @@ -124,6 +124,7 @@ test_EXCLUDES += test^matlab^step5 # never completes at 10,000 test_EXCLUDES += test^plpgsql^step5 # too slow for 10,000 test_EXCLUDES += test^plsql^step5 # too slow for 10,000 test_EXCLUDES += test^powershell^step5 # too slow for 10,000 +test_EXCLUDES += $(if $(filter cpp,$(haxe_MODE)),test^haxe^step5,) # cpp finishes 10,000, segfaults at 100,000 perf_EXCLUDES = mal # TODO: fix this From e68e138f27f7310cce8ff525fa013626f720dd51 Mon Sep 17 00:00:00 2001 From: Michael Pope Date: Tue, 12 Sep 2017 11:34:43 -0700 Subject: [PATCH 0138/1998] Update Elixir syntax & version to work with v1.5.x --- elixir/lib/mal/core.ex | 6 +++--- elixir/lib/mix/tasks/step0_repl.ex | 4 ++-- elixir/lib/mix/tasks/step1_read_print.ex | 4 ++-- elixir/lib/mix/tasks/step2_eval.ex | 6 +++--- elixir/lib/mix/tasks/step3_env.ex | 4 ++-- elixir/lib/mix/tasks/step4_if_fn_do.ex | 4 ++-- elixir/lib/mix/tasks/step5_tco.ex | 4 ++-- elixir/lib/mix/tasks/step6_file.ex | 4 ++-- elixir/lib/mix/tasks/step7_quote.ex | 4 ++-- elixir/lib/mix/tasks/step8_macros.ex | 4 ++-- elixir/lib/mix/tasks/step9_try.ex | 4 ++-- elixir/lib/mix/tasks/stepA_mal.ex | 4 ++-- elixir/mix.exs | 6 +++--- 13 files changed, 29 insertions(+), 29 deletions(-) diff --git a/elixir/lib/mal/core.ex b/elixir/lib/mal/core.ex index 1af6581d32..6bb67d202f 100644 --- a/elixir/lib/mal/core.ex +++ b/elixir/lib/mal/core.ex @@ -75,7 +75,7 @@ defmodule Mal.Core do def readline(prompt) do IO.write(:stdio, prompt) IO.read(:stdio, :line) - |> String.strip(?\n) + |> String.trim("\n") end defp convert_vector({type, ast, meta}) when type == :map do @@ -223,9 +223,9 @@ defmodule Mal.Core do end defp seq([nil]), do: nil - defp seq([{:list, [], meta}]), do: nil + defp seq([{:list, [], _meta}]), do: nil defp seq([{:list, ast, meta}]), do: {:list, ast, meta} - defp seq([{:vector, [], meta}]), do: nil + defp seq([{:vector, [], _meta}]), do: nil defp seq([{:vector, ast, meta}]), do: {:list, ast, meta} defp seq([""]), do: nil defp seq([s]), do: {:list, String.split(s, "", trim: true), nil} diff --git a/elixir/lib/mix/tasks/step0_repl.ex b/elixir/lib/mix/tasks/step0_repl.ex index 437e787021..4cd3efec2a 100644 --- a/elixir/lib/mix/tasks/step0_repl.ex +++ b/elixir/lib/mix/tasks/step0_repl.ex @@ -1,12 +1,12 @@ defmodule Mix.Tasks.Step0Repl do - def run(_), do: loop + def run(_), do: loop() defp loop do Mal.Core.readline("user> ") |> read_eval_print |> IO.puts - loop + loop() end defp read(input) do diff --git a/elixir/lib/mix/tasks/step1_read_print.ex b/elixir/lib/mix/tasks/step1_read_print.ex index 25399b08df..9569e68fb6 100644 --- a/elixir/lib/mix/tasks/step1_read_print.ex +++ b/elixir/lib/mix/tasks/step1_read_print.ex @@ -1,12 +1,12 @@ defmodule Mix.Tasks.Step1ReadPrint do - def run(_), do: loop + def run(_), do: loop() defp loop do Mal.Core.readline("user> ") |> read_eval_print |> IO.puts - loop + loop() end defp read(input) do diff --git a/elixir/lib/mix/tasks/step2_eval.ex b/elixir/lib/mix/tasks/step2_eval.ex index 0d130afce9..9d8bf555ad 100644 --- a/elixir/lib/mix/tasks/step2_eval.ex +++ b/elixir/lib/mix/tasks/step2_eval.ex @@ -6,7 +6,7 @@ defmodule Mix.Tasks.Step2Eval do "/" => &div/2 } - def run(_), do: loop + def run(_), do: loop() defp loop do IO.write(:stdio, "user> ") @@ -14,7 +14,7 @@ defmodule Mix.Tasks.Step2Eval do |> read_eval_print |> IO.puts - loop + loop() end defp eval_ast({:list, ast, meta}, env) when is_list(ast) do @@ -46,7 +46,7 @@ defmodule Mix.Tasks.Step2Eval do Mal.Reader.read_str(input) end - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) defp eval(ast, env), do: eval_ast(ast, env) diff --git a/elixir/lib/mix/tasks/step3_env.ex b/elixir/lib/mix/tasks/step3_env.ex index 8c49e50972..34f1903180 100644 --- a/elixir/lib/mix/tasks/step3_env.ex +++ b/elixir/lib/mix/tasks/step3_env.ex @@ -50,7 +50,7 @@ defmodule Mix.Tasks.Step3Env do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -58,7 +58,7 @@ defmodule Mix.Tasks.Step3Env do end defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) defp eval(ast, env), do: eval_ast(ast, env) diff --git a/elixir/lib/mix/tasks/step4_if_fn_do.ex b/elixir/lib/mix/tasks/step4_if_fn_do.ex index 25ef00ef81..77ee53a816 100644 --- a/elixir/lib/mix/tasks/step4_if_fn_do.ex +++ b/elixir/lib/mix/tasks/step4_if_fn_do.ex @@ -59,7 +59,7 @@ defmodule Mix.Tasks.Step4IfFnDo do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -67,7 +67,7 @@ defmodule Mix.Tasks.Step4IfFnDo do end defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) defp eval(ast, env), do: eval_ast(ast, env) diff --git a/elixir/lib/mix/tasks/step5_tco.ex b/elixir/lib/mix/tasks/step5_tco.ex index f5ca80fa14..68d1343ddc 100644 --- a/elixir/lib/mix/tasks/step5_tco.ex +++ b/elixir/lib/mix/tasks/step5_tco.ex @@ -59,7 +59,7 @@ defmodule Mix.Tasks.Step5Tco do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -67,7 +67,7 @@ defmodule Mix.Tasks.Step5Tco do end defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) defp eval(ast, env), do: eval_ast(ast, env) diff --git a/elixir/lib/mix/tasks/step6_file.ex b/elixir/lib/mix/tasks/step6_file.ex index 7ddcefae5f..da486b0f33 100644 --- a/elixir/lib/mix/tasks/step6_file.ex +++ b/elixir/lib/mix/tasks/step6_file.ex @@ -82,7 +82,7 @@ defmodule Mix.Tasks.Step6File do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -90,7 +90,7 @@ defmodule Mix.Tasks.Step6File do end defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) defp eval(ast, env), do: eval_ast(ast, env) diff --git a/elixir/lib/mix/tasks/step7_quote.ex b/elixir/lib/mix/tasks/step7_quote.ex index 566f6c54ba..bd615e8d5d 100644 --- a/elixir/lib/mix/tasks/step7_quote.ex +++ b/elixir/lib/mix/tasks/step7_quote.ex @@ -82,7 +82,7 @@ defmodule Mix.Tasks.Step7Quote do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -114,7 +114,7 @@ defmodule Mix.Tasks.Step7Quote do end defp quasiquote(ast, _env), do: list([{:symbol, "quote"}, ast]) - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) defp eval(ast, env), do: eval_ast(ast, env) diff --git a/elixir/lib/mix/tasks/step8_macros.ex b/elixir/lib/mix/tasks/step8_macros.ex index 11cc5777b8..abb6e6df3b 100644 --- a/elixir/lib/mix/tasks/step8_macros.ex +++ b/elixir/lib/mix/tasks/step8_macros.ex @@ -105,7 +105,7 @@ defmodule Mix.Tasks.Step8Macros do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -159,7 +159,7 @@ defmodule Mix.Tasks.Step8Macros do end end - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, _list, _meta} = ast, env) do case macroexpand(ast, env) do {:list, list, meta} -> eval_list(list, env, meta) diff --git a/elixir/lib/mix/tasks/step9_try.ex b/elixir/lib/mix/tasks/step9_try.ex index aa8f75ef38..036952a647 100644 --- a/elixir/lib/mix/tasks/step9_try.ex +++ b/elixir/lib/mix/tasks/step9_try.ex @@ -105,7 +105,7 @@ defmodule Mix.Tasks.Step9Try do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -159,7 +159,7 @@ defmodule Mix.Tasks.Step9Try do end end - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, _list, _meta} = ast, env) do case macroexpand(ast, env) do {:list, list, meta} -> eval_list(list, env, meta) diff --git a/elixir/lib/mix/tasks/stepA_mal.ex b/elixir/lib/mix/tasks/stepA_mal.ex index 7ac36b8370..af7586eb13 100644 --- a/elixir/lib/mix/tasks/stepA_mal.ex +++ b/elixir/lib/mix/tasks/stepA_mal.ex @@ -124,7 +124,7 @@ defmodule Mix.Tasks.StepAMal do Mal.Reader.read_str(input) end - defp eval_bindings([], _env), do: _env + defp eval_bindings([], env), do: env defp eval_bindings([{:symbol, key}, binding | tail], env) do evaluated = eval(binding, env) Mal.Env.set(env, key, evaluated) @@ -178,7 +178,7 @@ defmodule Mix.Tasks.StepAMal do end end - defp eval({:list, [], _} = empty_ast, env), do: empty_ast + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast defp eval({:list, _list, _meta} = ast, env) do case macroexpand(ast, env) do {:list, list, meta} -> eval_list(list, env, meta) diff --git a/elixir/mix.exs b/elixir/mix.exs index aba14e7b0c..5d768f6e0a 100644 --- a/elixir/mix.exs +++ b/elixir/mix.exs @@ -4,12 +4,12 @@ defmodule Mal.Mixfile do def project do [app: :mal, version: "0.0.1", - elixir: "~> 1.0", + elixir: "~> 1.5", build_embedded: Mix.env == :prod, start_permanent: Mix.env == :prod, - deps: deps, + deps: deps(), default_task: "stepA_mal", - escript: escript] + escript: escript()] end def escript do From 50af689531733546019982ed76c4104dfd66e5b8 Mon Sep 17 00:00:00 2001 From: Campbell Barton Date: Wed, 13 Sep 2017 05:15:21 +1000 Subject: [PATCH 0139/1998] Avoid premature sort --- python/mal_types.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/python/mal_types.py b/python/mal_types.py index 57cbde2c7d..7c5e30c183 100644 --- a/python/mal_types.py +++ b/python/mal_types.py @@ -31,10 +31,10 @@ def _equal_Q(a, b): return True elif _hash_map_Q(a): akeys = a.keys() - akeys.sort() bkeys = b.keys() - bkeys.sort() if len(akeys) != len(bkeys): return False + akeys.sort() + bkeys.sort() for i in range(len(akeys)): if akeys[i] != bkeys[i]: return False if not _equal_Q(a[akeys[i]], b[bkeys[i]]): return False From 953dc52ae8789b838470bdd86712b4c109bd71ee Mon Sep 17 00:00:00 2001 From: Campbell Barton Date: Wed, 13 Sep 2017 12:00:34 +1000 Subject: [PATCH 0140/1998] Remove unnecessary lookup in 'dissoc' --- python/core.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/python/core.py b/python/core.py index d87f1e8da0..b52768dc43 100644 --- a/python/core.py +++ b/python/core.py @@ -36,7 +36,7 @@ def assoc(src_hm, *key_vals): def dissoc(src_hm, *keys): hm = copy.copy(src_hm) for key in keys: - if key in hm: del hm[key] + hm.pop(key, None) return hm def get(hm, key): From a77b8357de7f4ecb4d0902c575ed102355316d1c Mon Sep 17 00:00:00 2001 From: Campbell Barton Date: Wed, 13 Sep 2017 12:03:07 +1000 Subject: [PATCH 0141/1998] Remove unnecessary attr access in 'meta' --- python/core.py | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/python/core.py b/python/core.py index d87f1e8da0..66cafce56a 100644 --- a/python/core.py +++ b/python/core.py @@ -109,8 +109,7 @@ def with_meta(obj, meta): return new_obj def meta(obj): - if hasattr(obj, "__meta__"): return obj.__meta__ - else: return None + return getattr(obj, "__meta__", None) # Atoms functions From ebaca6bbe921701be67df71a901d911f2b7c1b5b Mon Sep 17 00:00:00 2001 From: Campbell Barton Date: Wed, 13 Sep 2017 12:05:04 +1000 Subject: [PATCH 0142/1998] Remove unnecessary lookup in 'get' --- python/core.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/python/core.py b/python/core.py index d87f1e8da0..ec8d180272 100644 --- a/python/core.py +++ b/python/core.py @@ -40,8 +40,8 @@ def dissoc(src_hm, *keys): return hm def get(hm, key): - if hm and key in hm: - return hm[key] + if hm is not None: + return hm.get(key) else: return None From d7d982e8b2f31ccc329ec5d780b91a17eaef895c Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 09:57:43 +0200 Subject: [PATCH 0143/1998] Add Dockerfile and try finding sash --- scheme/Dockerfile | 59 +++++++++++++++++++++++++++++++++++++++++++++++ scheme/run | 8 ++++++- 2 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 scheme/Dockerfile diff --git a/scheme/Dockerfile b/scheme/Dockerfile new file mode 100644 index 0000000000..846f8e303d --- /dev/null +++ b/scheme/Dockerfile @@ -0,0 +1,59 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Prepackaged Scheme implementations +RUN apt-get -y install gauche chicken-bin + +# Chibi +RUN apt-get -y install bison gcc g++ flex +RUN cd /tmp && curl -Lo chibi-0.7.3.tar.gz https://github.com/ashinn/chibi-scheme/archive/0.7.3.tar.gz \ + && tar xvzf chibi-0.7.3.tar.gz && cd chibi-scheme-0.7.3 \ + && make && make install && rm -rf /tmp/chibi-* + +# Kawa +RUN apt-get -y install openjdk-8-jdk-headless groff +RUN cd /tmp && curl -O http://ftp.gnu.org/pub/gnu/kawa/kawa-2.4.tar.gz \ + && tar xvzf kawa-2.4.tar.gz && cd kawa-2.4 \ + && ./configure && make && make install && rm -rf /tmp/kawa-2.4* + +# Sagittarius +RUN apt-get -y install cmake libgc-dev zlib1g-dev libffi-dev +RUN cd /tmp && curl -LO https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.8.3.tar.gz \ + && tar xvzf sagittarius-0.8.3.tar.gz && cd sagittarius-0.8.3 \ + && cmake . && make && make install && rm -rf /tmp/sagittarius-0.8.3* + +# Cyclone +RUN apt-get -y install git libtommath-dev +RUN cd /tmp && curl -O http://concurrencykit.org/releases/ck-0.6.0.tar.gz \ + && tar xvzf ck-0.6.0.tar.gz && cd ck-0.6.0 && ./configure PREFIX=/usr \ + && make all && make install && ldconfig && rm -rf /tmp/ck-0.6.0* +RUN cd /tmp && git clone https://github.com/justinethier/cyclone-bootstrap \ + && cd cyclone-bootstrap && make CFLAGS="-O2 -fPIC -rdynamic -Wall -Iinclude -L." \ + && make install && rm -rf /tmp/cyclone-bootstrap + +# Foment +RUN cd /tmp && git clone https://github.com/leftmike/foment \ + && cd foment/unix && make && cp release/foment /usr/bin/foment \ + && rm -rf /tmp/foment + +ENV HOME /mal diff --git a/scheme/run b/scheme/run index 80498c456e..c4fa69e7a3 100755 --- a/scheme/run +++ b/scheme/run @@ -3,12 +3,18 @@ basedir=$(dirname $0) kawa=${KAWA_JAR:-/usr/share/kawa/lib/kawa.jar} step=${STEP:-stepA_mal} +if [[ $(which sash 2>/dev/null) ]]; then + sagittarius=sash +elif [[ $(which sagittarius 2>/dev/null) ]]; then + sagittarius=sagittarius +fi + case ${scheme_MODE:-chibi} in chibi) exec chibi-scheme -I$basedir $basedir/$step.scm "${@}" ;; kawa) exec java -cp $kawa:$basedir/out $step "${@}" ;; gauche) exec gosh -I$basedir $basedir/$step.scm "${@}" ;; chicken) CHICKEN_REPOSITORY=$basedir/eggs exec $basedir/$step "${@}" ;; - sagittarius) exec sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;; + sagittarius) exec $sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;; cyclone) exec $basedir/$step "${@}" ;; foment) exec foment $basedir/$step.scm "${@}" ;; *) echo "Invalid scheme_MODE: ${scheme_MODE}"; exit 2 ;; From b58ce6c42f97c9b2d8b0cc173f3dc5245a8c05a7 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 09:58:18 +0200 Subject: [PATCH 0144/1998] Add seven Scheme implementations to Dockerfile --- .travis.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.travis.yml b/.travis.yml index a107abdfae..a62674a0a4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -71,6 +71,13 @@ matrix: - {env: IMPL=ruby, services: [docker]} - {env: IMPL=rust, services: [docker]} - {env: IMPL=scala, services: [docker]} + - {env: IMPL=scheme scheme_MODE=chibi, services: [docker]} + - {env: IMPL=scheme scheme_MODE=kawa, services: [docker]} + - {env: IMPL=scheme scheme_MODE=gauche, services: [docker]} + - {env: IMPL=scheme scheme_MODE=chicken, services: [docker]} + - {env: IMPL=scheme scheme_MODE=sagittarius, services: [docker]} + - {env: IMPL=scheme scheme_MODE=cyclone, services: [docker]} + - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} - {env: IMPL=skew, services: [docker]} - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7} - {env: IMPL=swift3, services: [docker]} From fea8cfff34ed8a9da569cfba0a69cd82384b173e Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 16:49:15 +0200 Subject: [PATCH 0145/1998] Fix Makefile --- Makefile | 12 +++- scheme/.gitignore | 2 +- scheme/Makefile | 171 ++++++++++++++++++++++------------------------ scheme/eggs/.keep | 0 4 files changed, 94 insertions(+), 91 deletions(-) create mode 100644 scheme/eggs/.keep diff --git a/Makefile b/Makefile index 236438e3f3..52768a6f6a 100644 --- a/Makefile +++ b/Makefile @@ -52,6 +52,8 @@ haxe_MODE = neko matlab_MODE = octave # python, python2 or python3 python_MODE = python +# scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment) +scheme_MODE = scheme # Extra options to pass to runtest.py TEST_OPTS = @@ -143,6 +145,14 @@ haxe_STEP_TO_PROG_js = haxe/$($(1)).js clojure_STEP_TO_PROG_clj = clojure/target/$($(1)).jar clojure_STEP_TO_PROG_cljs = clojure/src/mal/$($(1)).cljc +scheme_STEP_TO_PROG_chibi = scheme/$($(1)).scm +scheme_STEP_TO_PROG_kawa = scheme/out/$($(1)).class +scheme_STEP_TO_PROG_gauche = scheme/$($(1)).scm +scheme_STEP_TO_PROG_chicken = scheme/$($(1)) +scheme_STEP_TO_PROG_sagittarius = scheme/$($(1)).scm +scheme_STEP_TO_PROG_cyclone = scheme/$($(1)) +scheme_STEP_TO_PROG_foment = scheme/$($(1)).scm + opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable) opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional) @@ -210,7 +220,7 @@ rpython_STEP_TO_PROG = rpython/$($(1)) ruby_STEP_TO_PROG = ruby/$($(1)).rb rust_STEP_TO_PROG = rust/target/release/$($(1)) scala_STEP_TO_PROG = scala/target/scala-2.11/classes/$($(1)).class -scheme_STEP_TO_PROG = scheme/$($(1)).scm +scheme_STEP_TO_PROG = $(scheme_STEP_TO_PROG_$(scheme_MODE)) skew_STEP_TO_PROG = skew/$($(1)).js swift_STEP_TO_PROG = swift/$($(1)) swift3_STEP_TO_PROG = swift3/$($(1)) diff --git a/scheme/.gitignore b/scheme/.gitignore index 2cc78f64d7..31fc0e8966 100644 --- a/scheme/.gitignore +++ b/scheme/.gitignore @@ -8,4 +8,4 @@ lib.*.scm *.c *.o out/ -eggs/ +eggs/* \ No newline at end of file diff --git a/scheme/Makefile b/scheme/Makefile index 260c713d53..5e33a00ae4 100644 --- a/scheme/Makefile +++ b/scheme/Makefile @@ -1,110 +1,103 @@ -SOURCES_BASE = lib/reader.sld lib/printer.sld lib/types.sld +SOURCES_BASE = lib/util.sld lib/reader.sld lib/printer.sld lib/types.sld SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco BINS += step6_file step7_quote step8_macros step9_try stepA_mal scheme_MODE ?= chibi +CLASSSTEPS = out/step0_repl.class out/step1_read_print.class \ + out/step3_env.class out/step4_if_fn_do.class out/step5_tco.class \ + out/step6_file.class out/step7_quote.class out/step8_macros.class \ + out/step9_try.class out/stepA_mal.class +STEPS = $(if $(filter kawa,$(scheme_MODE)),$(CLASSSTEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(BINS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(BINS)))) + +KAWA_STEP1_DEPS = out/lib/util.class out/lib/reader.class \ + out/lib/printer.class out/lib/types.class +KAWA_STEP3_DEPS = $(KAWA_STEP1_DEPS) out/lib/env.class +KAWA_STEP4_DEPS = $(KAWA_STEP3_DEPS) out/lib/core.class +CHICKEN_STEP1_DEPS = eggs/lib.util.so eggs/lib.types.so \ + eggs/lib.reader.so eggs/lib.printer.so +CHICKEN_STEP3_DEPS = $(CHICKEN_STEP1_DEPS) eggs/lib.env.so +CHICKEN_STEP4_DEPS = $(CHICKEN_STEP3_DEPS) eggs/lib.core.so +CYCLONE_STEP1_DEPS = lib/util.so lib/reader.so lib/printer.so lib/types.so +CYCLONE_STEP3_DEPS = $(CYCLONE_STEP1_DEPS) lib/env.so +CYCLONE_STEP4_DEPS = $(CYCLONE_STEP3_DEPS) lib/core.so + +STEP1_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP1_DEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP1_DEPS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP1_DEPS)))) +STEP3_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP3_DEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP3_DEPS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP3_DEPS)))) +STEP4_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP4_DEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP4_DEPS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP4_DEPS)))) + +KAWALIB = kawa --r7rs --no-warn-unused -d out -C +KAWA = kawa --r7rs --no-warn-unused -d out --main -C +CHICKEN = CHICKEN_REPOSITORY=$(CURDIR)/eggs csc -O3 -R r7rs +CHICKENLIB = $(CHICKEN) -sJ +CYCLONELIB = cyclone -O2 +CYCLONE = $(CYCLONELIB) + +SCMLIB = $(if $(filter kawa,$(scheme_MODE)),$(KAWALIB),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKENLIB),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONELIB)))) +SCM = $(if $(filter kawa,$(scheme_MODE)),$(KAWA),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE)))) + MKDIR = mkdir -p SYMLINK = ln -sfr RM = rm -f RMR = rm -rf -KAWA = kawa --r7rs --no-warn-unused -d out -C -KAWAM = kawa --r7rs --no-warn-unused -d out --main -C -CSC = CHICKEN_REPOSITORY=$(CURDIR)/eggs csc -O3 -R r7rs -CSCSO = $(CSC) -sJ -CYCLONE = cyclone -O2 - -DEPS = $(if $(filter kawa,$(scheme_MODE)),kawa,\ - $(if $(filter chicken,$(scheme_MODE)),chicken,\ - $(if $(filter cyclone,$(scheme_MODE)),cyclone))) - -all: symlinks build - -.PHONY: symlinks build kawa chicken cyclone clean stats stats-lisp - -build: $(DEPS) - -symlinks: - $(MKDIR) eggs - $(SYMLINK) lib/util.sld lib/util.scm - $(SYMLINK) lib/util.sld eggs/lib.util.scm - $(SYMLINK) lib/types.sld lib/types.scm - $(SYMLINK) lib/types.sld eggs/lib.types.scm - $(SYMLINK) lib/reader.sld lib/reader.scm - $(SYMLINK) lib/reader.sld eggs/lib.reader.scm - $(SYMLINK) lib/printer.sld lib/printer.scm - $(SYMLINK) lib/printer.sld eggs/lib.printer.scm - $(SYMLINK) lib/env.sld lib/env.scm - $(SYMLINK) lib/env.sld eggs/lib.env.scm - $(SYMLINK) lib/core.sld lib/core.scm - $(SYMLINK) lib/core.sld eggs/lib.core.scm - -kawa: - $(KAWA) lib/util.scm - $(KAWA) lib/types.scm - $(KAWA) lib/reader.scm - $(KAWA) lib/printer.scm - $(KAWA) lib/env.scm - $(KAWA) lib/core.scm - $(KAWAM) step0_repl.scm - $(KAWAM) step1_read_print.scm - $(KAWAM) step2_eval.scm - $(KAWAM) step3_env.scm - $(KAWAM) step4_if_fn_do.scm - $(KAWAM) step5_tco.scm - $(KAWAM) step6_file.scm - $(KAWAM) step7_quote.scm - $(KAWAM) step8_macros.scm - $(KAWAM) step9_try.scm - $(KAWAM) stepA_mal.scm - -chicken: +all: $(STEPS) + +.PHONY: clean stats stats-lisp +.PRECIOUS: lib/%.scm eggs/lib.%.scm + +eggs/r7rs.so: chicken-install -init eggs CHICKEN_REPOSITORY=$(CURDIR)/eggs chicken-install r7rs - $(CSCSO) eggs/lib.util.scm - $(CSCSO) eggs/lib.types.scm - $(CSCSO) eggs/lib.reader.scm - $(CSCSO) eggs/lib.printer.scm - $(CSCSO) eggs/lib.env.scm - $(CSCSO) eggs/lib.core.scm - $(CSC) step0_repl.scm - $(CSC) step1_read_print.scm - $(CSC) step2_eval.scm - $(CSC) step3_env.scm - $(CSC) step4_if_fn_do.scm - $(CSC) step5_tco.scm - $(CSC) step6_file.scm - $(CSC) step7_quote.scm - $(CSC) step8_macros.scm - $(CSC) step9_try.scm - $(CSC) stepA_mal.scm - -cyclone: - $(CYCLONE) lib/util.sld - $(CYCLONE) lib/types.sld - $(CYCLONE) lib/reader.sld - $(CYCLONE) lib/printer.sld - $(CYCLONE) lib/env.sld - $(CYCLONE) lib/core.sld - $(CYCLONE) step0_repl.scm - $(CYCLONE) step1_read_print.scm - $(CYCLONE) step2_eval.scm - $(CYCLONE) step3_env.scm - $(CYCLONE) step4_if_fn_do.scm - $(CYCLONE) step5_tco.scm - $(CYCLONE) step6_file.scm - $(CYCLONE) step7_quote.scm - $(CYCLONE) step8_macros.scm - $(CYCLONE) step9_try.scm - $(CYCLONE) stepA_mal.scm + +lib/%.scm: lib/%.sld + $(SYMLINK) $< $@ + +eggs/lib.%.scm: lib/%.sld + $(SYMLINK) $< $@ + +out/lib/%.class: lib/%.scm + $(SCMLIB) $< + +out/%.class: %.scm + $(SCM) $< + +eggs/lib.%.so: eggs/lib.%.scm + $(SCMLIB) $< + +lib/%.so: lib/%.sld + $(SCMLIB) $< + +%: %.scm + $(SCM) $< + +out/step1_read_print.class out/step2_eval.class: $(STEP1_DEPS) +out/step3_env.class: $(STEP3_DEPS) +out/step4_if_fn_do.class out/step5_tco.class out/step6_file.class out/step7_quote.class out/step8_macros.class out/step9_try.class out/stepA_mal.class: $(STEP4_DEPS) + +step0_repl: $(if $(filter chicken,$(scheme_MODE)),eggs/r7rs.so,) +step1_read_print.scm step2_eval.scm: $(STEP1_DEPS) +step3_env.scm: $(STEP3_DEPS) +step4_if_fn_do.scm step5_tco.scm step6_file.scm step7_quote.scm step8_macros.scm step9_try.scm stepA_mal.scm: $(STEP4_DEPS) clean: $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta $(RM) lib.*.scm *.so *.c *.o $(BINS) + $(RM) eggs/* $(RMR) out - $(RMR) eggs stats: $(SOURCES) @wc $^ diff --git a/scheme/eggs/.keep b/scheme/eggs/.keep new file mode 100644 index 0000000000..e69de29bb2 From 2b9b1104579135d2281dbef51f1d5336f29584e5 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 16:49:26 +0200 Subject: [PATCH 0146/1998] Fix eval test --- scheme/lib/core.sld | 3 ++- scheme/tests/stepA_mal.mal | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/scheme/lib/core.sld b/scheme/lib/core.sld index 7e62cfc1ff..b6cfbe33fc 100644 --- a/scheme/lib/core.sld +++ b/scheme/lib/core.sld @@ -133,7 +133,8 @@ (cyclone (->mal-object (eval (read port)))) (else - (->mal-object (eval (read port) (interaction-environment)))))))) + (->mal-object (eval (read port) (environment '(scheme base) + '(scheme write))))))))) (define ns `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) diff --git a/scheme/tests/stepA_mal.mal b/scheme/tests/stepA_mal.mal index da3f7fe3bc..85eb6f06ad 100644 --- a/scheme/tests/stepA_mal.mal +++ b/scheme/tests/stepA_mal.mal @@ -12,6 +12,5 @@ (scm-eval "(map + '(1 2 3) '(4 5 6))") ;=>(5 7 9) -(scm-eval "(define (rot13 c) (integer->char (+ 65 (modulo (+ (- (char->integer c) 65) 13) 26))))") -(scm-eval "(string-map rot13 \"ZNY\")") +(scm-eval "(string-map (lambda (c) (integer->char (+ 65 (modulo (+ (- (char->integer c) 65) 13) 26)))) \"ZNY\")") ;=>"MAL" From f301fa6ce71cd62042c8a3c29cdb88e8bcb3c82e Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 17:51:45 +0200 Subject: [PATCH 0147/1998] Fix execution of Kawa and Gauche in Docker --- scheme/Makefile | 13 ++++++++++--- scheme/run | 7 ++++++- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/scheme/Makefile b/scheme/Makefile index 5e33a00ae4..2239360349 100644 --- a/scheme/Makefile +++ b/scheme/Makefile @@ -17,6 +17,9 @@ KAWA_STEP1_DEPS = out/lib/util.class out/lib/reader.class \ out/lib/printer.class out/lib/types.class KAWA_STEP3_DEPS = $(KAWA_STEP1_DEPS) out/lib/env.class KAWA_STEP4_DEPS = $(KAWA_STEP3_DEPS) out/lib/core.class +GAUCHE_STEP1_DEPS = lib/util.scm lib/reader.scm lib/printer.scm lib/types.scm +GAUCHE_STEP3_DEPS = $(GAUCHE_STEP1_DEPS) lib/env.scm +GAUCHE_STEP4_DEPS = $(GAUCHE_STEP3_DEPS) lib/core.scm CHICKEN_STEP1_DEPS = eggs/lib.util.so eggs/lib.types.so \ eggs/lib.reader.so eggs/lib.printer.so CHICKEN_STEP3_DEPS = $(CHICKEN_STEP1_DEPS) eggs/lib.env.so @@ -26,14 +29,17 @@ CYCLONE_STEP3_DEPS = $(CYCLONE_STEP1_DEPS) lib/env.so CYCLONE_STEP4_DEPS = $(CYCLONE_STEP3_DEPS) lib/core.so STEP1_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP1_DEPS),\ + $(if $(filter gauche,$(scheme_MODE)),$(GAUCHE_STEP1_DEPS),\ $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP1_DEPS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP1_DEPS)))) + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP1_DEPS))))) STEP3_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP3_DEPS),\ + $(if $(filter gauche,$(scheme_MODE)),$(GAUCHE_STEP3_DEPS),\ $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP3_DEPS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP3_DEPS)))) + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP3_DEPS))))) STEP4_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP4_DEPS),\ + $(if $(filter gauche,$(scheme_MODE)),$(GAUCHE_STEP4_DEPS),\ $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP4_DEPS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP4_DEPS)))) + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP4_DEPS))))) KAWALIB = kawa --r7rs --no-warn-unused -d out -C KAWA = kawa --r7rs --no-warn-unused -d out --main -C @@ -89,6 +95,7 @@ out/step3_env.class: $(STEP3_DEPS) out/step4_if_fn_do.class out/step5_tco.class out/step6_file.class out/step7_quote.class out/step8_macros.class out/step9_try.class out/stepA_mal.class: $(STEP4_DEPS) step0_repl: $(if $(filter chicken,$(scheme_MODE)),eggs/r7rs.so,) + step1_read_print.scm step2_eval.scm: $(STEP1_DEPS) step3_env.scm: $(STEP3_DEPS) step4_if_fn_do.scm step5_tco.scm step6_file.scm step7_quote.scm step8_macros.scm step9_try.scm stepA_mal.scm: $(STEP4_DEPS) diff --git a/scheme/run b/scheme/run index c4fa69e7a3..9614f8baea 100755 --- a/scheme/run +++ b/scheme/run @@ -1,8 +1,13 @@ #!/bin/bash basedir=$(dirname $0) -kawa=${KAWA_JAR:-/usr/share/kawa/lib/kawa.jar} step=${STEP:-stepA_mal} +if [[ -e /usr/share/kawa/lib/kawa.jar ]]; then + kawa=/usr/share/kawa/lib/kawa.jar +elif [[ -e /usr/local/share/kawa/lib/kawa.jar ]]; then + kawa=/usr/local/share/kawa/lib/kawa.jar +fi + if [[ $(which sash 2>/dev/null) ]]; then sagittarius=sash elif [[ $(which sagittarius 2>/dev/null) ]]; then From d09216a03c2e65dce5a3d4df1184d87ec81fd5e9 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 20:14:50 +0200 Subject: [PATCH 0148/1998] Set default Scheme implementation for tests --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 52768a6f6a..70ea11732e 100644 --- a/Makefile +++ b/Makefile @@ -53,7 +53,7 @@ matlab_MODE = octave # python, python2 or python3 python_MODE = python # scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment) -scheme_MODE = scheme +scheme_MODE = chibi # Extra options to pass to runtest.py TEST_OPTS = From bcf3234d906fd9403ebc4f52fe4f850ff3a8fd19 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 13 Sep 2017 21:25:05 +0200 Subject: [PATCH 0149/1998] Disable Foment due to inexplicable hangs --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index a62674a0a4..bceeab73d8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -77,7 +77,7 @@ matrix: - {env: IMPL=scheme scheme_MODE=chicken, services: [docker]} - {env: IMPL=scheme scheme_MODE=sagittarius, services: [docker]} - {env: IMPL=scheme scheme_MODE=cyclone, services: [docker]} - - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} +# - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} - {env: IMPL=skew, services: [docker]} - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7} - {env: IMPL=swift3, services: [docker]} From 007e4bf842640898c7a63ae4e4484a54d511e30f Mon Sep 17 00:00:00 2001 From: Michael Pope Date: Wed, 13 Sep 2017 11:45:12 -0700 Subject: [PATCH 0150/1998] Update Dockerfile for Elixir --- elixir/Dockerfile | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/elixir/Dockerfile b/elixir/Dockerfile index 7f013a5928..758c9036a6 100644 --- a/elixir/Dockerfile +++ b/elixir/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:xenial MAINTAINER Joel Martin ########################################################## @@ -22,8 +22,9 @@ WORKDIR /mal ########################################################## # Elixir -RUN curl -O https://packages.erlang-solutions.com/erlang-solutions_1.0_all.deb \ - && dpkg -i erlang-solutions_1.0_all.deb -RUN apt-get -y update -RUN apt-get -y install elixir - +RUN apt-get install -y wget +RUN wget https://packages.erlang-solutions.com/erlang-solutions_1.0_all.deb +RUN dpkg -i erlang-solutions_1.0_all.deb +RUN apt-get update -y +RUN apt-get install -y esl-erlang +RUN apt-get install -y elixir From 5a5357b17ec00caeeb136edf23f549c990d231af Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 14 Sep 2017 23:36:25 -0500 Subject: [PATCH 0151/1998] Makefile: re-ordering. Drop extra SECONDEXPANSIONs --- Makefile | 80 +++++++++++++++++++++++++++----------------------------- 1 file changed, 39 insertions(+), 41 deletions(-) diff --git a/Makefile b/Makefile index 5049bf5f1d..38a189a180 100644 --- a/Makefile +++ b/Makefile @@ -66,19 +66,12 @@ REGRESS = DEFERRABLE=1 OPTIONAL=1 -# Extra implementation specific options to pass to runtest.py -logo_TEST_OPTS = --start-timeout 60 --test-timeout 120 -mal_TEST_OPTS = --start-timeout 60 --test-timeout 120 -miniMAL_TEST_OPTS = --start-timeout 60 --test-timeout 120 -plpgsql_TEST_OPTS = --start-timeout 60 --test-timeout 180 -plsql_TEST_OPTS = --start-timeout 120 --test-timeout 120 -perl6_TEST_OPTS = --test-timeout=60 - # Run target/rule within docker image for the implementation DOCKERIZE = + # -# Settings +# Implementation specific settings # IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs dart \ @@ -134,8 +127,24 @@ dist_EXCLUDES += mal # TODO: still need to implement dist dist_EXCLUDES += guile io julia matlab swift + +# Extra options to pass to runtest.py +logo_TEST_OPTS = --start-timeout 60 --test-timeout 120 +mal_TEST_OPTS = --start-timeout 60 --test-timeout 120 +miniMAL_TEST_OPTS = --start-timeout 60 --test-timeout 120 +plpgsql_TEST_OPTS = --start-timeout 60 --test-timeout 180 +plsql_TEST_OPTS = --start-timeout 120 --test-timeout 120 +perl6_TEST_OPTS = --test-timeout=60 +vimscript_TEST_OPTS = --test-timeout 30 +ifeq ($(MAL_IMPL),vimscript) +mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 +else ifeq ($(MAL_IMPL),powershell) +mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 +endif + + # -# Utility functions +# Implementation specific utility functions # haxe_STEP_TO_PROG_neko = haxe/$($(1)).n @@ -154,16 +163,6 @@ scheme_STEP_TO_PROG_sagittarius = scheme/$($(1)).scm scheme_STEP_TO_PROG_cyclone = scheme/$($(1)) scheme_STEP_TO_PROG_foment = scheme/$($(1)).scm -opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable) -opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional) - -# Return list of test files for a given step. If REGRESS is set then -# test files will include step 2 tests through tests for the step -# being tested. -STEP_TEST_FILES = $(strip $(wildcard \ - $(foreach s,$(if $(strip $(REGRESS)),$(regress_$(2)),$(2)),\ - $(1)/tests/$($(s))$(EXTENSION) tests/$($(s))$(EXTENSION)))) - # Map of step (e.g. "step8") to executable file for that step ada_STEP_TO_PROG = ada/$($(1)) awk_STEP_TO_PROG = awk/$($(1)).awk @@ -235,12 +234,26 @@ livescript_STEP_TO_PROG = livescript/$($(1)).js elm_STEP_TO_PROG = elm/$($(1)).js +# +# General settings and utility functions +# + # Needed some argument munging COMMA = , noop = SPACE = $(noop) $(noop) export FACTOR_ROOTS := . +opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable) +opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional) + +# Return list of test files for a given step. If REGRESS is set then +# test files will include step 2 tests through tests for the step +# being tested. +STEP_TEST_FILES = $(strip $(wildcard \ + $(foreach s,$(if $(strip $(REGRESS)),$(regress_$(2)),$(2)),\ + $(1)/tests/$($(s))$(EXTENSION) tests/$($(s))$(EXTENSION)))) + # DOCKERIZE utility functions lc = $(subst A,a,$(subst B,b,$(subst C,c,$(subst D,d,$(subst E,e,$(subst F,f,$(subst G,g,$(subst H,h,$(subst I,i,$(subst J,j,$(subst K,k,$(subst L,l,$(subst M,m,$(subst N,n,$(subst O,o,$(subst P,p,$(subst Q,q,$(subst R,r,$(subst S,s,$(subst T,t,$(subst U,u,$(subst V,v,$(subst W,w,$(subst X,x,$(subst Y,y,$(subst Z,z,$1)))))))))))))))))))))))))) impl_to_image = kanaka/mal-test-$(call lc,$(1)) @@ -290,13 +303,6 @@ get_runtest_cmd = $(call get_run_prefix,$(1),$(2),$(if $(filter cs fsharp tcl vb # Returns the runtest command prefix (with runtest options) for testing the given step get_argvtest_cmd = $(call get_run_prefix,$(1),$(2)) ../run_argv_test.sh -vimscript_TEST_OPTS = --test-timeout 30 -ifeq ($(MAL_IMPL),vimscript) -mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 -else ifeq ($(MAL_IMPL),powershell) -mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 -endif - # Derived lists STEPS = $(sort $(filter step%,$(.VARIABLES))) DO_IMPLS = $(filter-out $(SKIP_IMPLS),$(IMPLS)) @@ -316,10 +322,14 @@ ALL_REPL = $(strip $(sort \ $(foreach impl,$(DO_IMPLS),\ $(foreach step,$(STEPS),repl^$(impl)^$(step))))) + # # Build rules # +# Enable secondary expansion for all rules +.SECONDEXPANSION: + # Build a program in an implementation directory # Make sure we always try and build first because the dependencies are # encoded in the implementation Makefile not here @@ -331,10 +341,8 @@ $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))): $(call get_build_command,$(impl)) -C $(impl) $(subst $(impl)/,,$(@)))) # Allow IMPL, and IMPL^STEP -.SECONDEXPANSION: $(DO_IMPLS): $$(foreach s,$$(STEPS),$$(call $$(@)_STEP_TO_PROG,$$(s))) -.SECONDEXPANSION: $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(i)^$(s))): $$(call $$(word 1,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 2,$$(subst ^, ,$$(@)))) @@ -342,7 +350,6 @@ $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(i)^$(s))): $$(call $$(word 1,$$(s # Test rules # -.SECONDEXPANSION: $(ALL_TESTS): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ $(foreach step,$(word 3,$(subst ^, ,$(@))),\ @@ -364,10 +371,8 @@ $(ALL_TESTS): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(s test: $(ALL_TESTS) tests: $(ALL_TESTS) -.SECONDEXPANSION: $(IMPL_TESTS): $$(filter $$@^%,$$(ALL_TESTS)) -.SECONDEXPANSION: $(STEP_TESTS): $$(foreach step,$$(subst test^,,$$@),$$(filter %^$$(step),$$(ALL_TESTS))) @@ -377,7 +382,6 @@ $(STEP_TESTS): $$(foreach step,$$(subst test^,,$$@),$$(filter %^$$(step),$$(ALL_ dist: $(IMPL_DIST) -.SECONDEXPANSION: $(IMPL_DIST): @echo "----------------------------------------------"; \ $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ @@ -391,7 +395,6 @@ $(IMPL_DIST): docker-build: $(DOCKER_BUILD) -.SECONDEXPANSION: $(DOCKER_BUILD): echo "----------------------------------------------"; \ $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ @@ -405,7 +408,6 @@ $(DOCKER_BUILD): perf: $(IMPL_PERF) -.SECONDEXPANSION: $(IMPL_PERF): @echo "----------------------------------------------"; \ $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ @@ -423,23 +425,20 @@ $(IMPL_PERF): # REPL invocation rules # -.SECONDEXPANSION: $(ALL_REPL): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ $(foreach step,$(word 3,$(subst ^, ,$(@))),\ cd $(if $(filter mal,$(impl)),$(MAL_IMPL),$(impl)); \ echo 'REPL implementation $(impl), step file: $+'; \ - echo 'Running: $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run'; \ - $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run;)) + echo 'Running: $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run $(RUN_ARGS)'; \ + $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run $(RUN_ARGS);)) # Allow repl^IMPL^STEP and repl^IMPL (which starts REPL of stepA) -.SECONDEXPANSION: $(IMPL_REPL): $$@^stepA # # Utility functions # -.SECONDEXPANSION: print-%: @echo "$($(*))" @@ -450,7 +449,6 @@ print-%: define recur_template .PHONY: $(1) $(1): $(2) -.SECONDEXPANSION: $(2): @echo "----------------------------------------------"; \ $$(foreach impl,$$(word 2,$$(subst ^, ,$$(@))),\ From 48bd82ba6ca545fa42f5b983d965ba2d96f55dac Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 14 Sep 2017 23:37:26 -0500 Subject: [PATCH 0152/1998] Makefile: add docker-shell target(s). --- Makefile | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/Makefile b/Makefile index 38a189a180..c446e19e44 100644 --- a/Makefile +++ b/Makefile @@ -37,6 +37,8 @@ all help: @echo @echo 'make "docker-build^IMPL" # build docker image for IMPL' @echo + @echo 'make "docker-shell^IMPL" # start bash shell in docker image for IMPL' + @echo # # Command line settings @@ -276,10 +278,10 @@ get_build_command = $(strip $(if $(strip $(DOCKERIZE)),\ ,\ $(MAKE) $(if $(strip $($(1)_MODE)),$(1)_MODE=$($(1)_MODE),))) -# Takes impl and step arguments +# Takes impl and step args. Optional env vars and dockerize args # Returns a command prefix (docker command and environment variables) # necessary to launch the given impl and step -get_run_prefix = $(strip $(if $(strip $(DOCKERIZE)),\ +get_run_prefix = $(strip $(if $(strip $(DOCKERIZE) $(4)),\ docker run -e STEP=$($2) -e MAL_IMPL=$(MAL_IMPL) \ -it --rm -u $(shell id -u) \ -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ @@ -315,6 +317,8 @@ ALL_TESTS = $(filter-out $(test_EXCLUDES),\ DOCKER_BUILD = $(foreach impl,$(DO_IMPLS),docker-build^$(impl)) +DOCKER_SHELL = $(foreach impl,$(DO_IMPLS),docker-shell^$(impl)) + IMPL_PERF = $(foreach impl,$(filter-out $(perf_EXCLUDES),$(DO_IMPLS)),perf^$(impl)) IMPL_REPL = $(foreach impl,$(DO_IMPLS),repl^$(impl)) @@ -377,29 +381,26 @@ $(STEP_TESTS): $$(foreach step,$$(subst test^,,$$@),$$(filter %^$$(step),$$(ALL_ # -# Dist rules +# Docker build rules # -dist: $(IMPL_DIST) +docker-build: $(DOCKER_BUILD) -$(IMPL_DIST): +$(DOCKER_BUILD): @echo "----------------------------------------------"; \ $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - echo "Running: make -C $(impl) dist"; \ - $(MAKE) --no-print-directory -C $(impl) dist) - + echo "Running: docker build -t $(call impl_to_image,$(impl)) .:"; \ + cd $(impl) && docker build -t $(call impl_to_image,$(impl)) .) # -# Docker build rules +# Docker shell rules # -docker-build: $(DOCKER_BUILD) - -$(DOCKER_BUILD): - echo "----------------------------------------------"; \ +$(DOCKER_SHELL): + @echo "----------------------------------------------"; \ $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - echo "Running: docker build -t $(call impl_to_image,$(impl)) .:"; \ - cd $(impl) && docker build -t $(call impl_to_image,$(impl)) .) + echo "Running: $(call get_run_prefix,$(impl),stepA,,dockerize) bash"; \ + $(call get_run_prefix,$(impl),stepA,,dockerize) bash) # From 2a368ba6df62190298243b1d39d7bb11eef3f415 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 14 Sep 2017 23:39:00 -0500 Subject: [PATCH 0153/1998] JS, Rexx: fix step build deps. --- Makefile | 2 +- js/Makefile | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index c446e19e44..b2c179d0f4 100644 --- a/Makefile +++ b/Makefile @@ -217,7 +217,7 @@ ps_STEP_TO_PROG = ps/$($(1)).ps python_STEP_TO_PROG = python/$($(1)).py r_STEP_TO_PROG = r/$($(1)).r racket_STEP_TO_PROG = racket/$($(1)).rkt -rexx_STEP_TO_PROG = rexx/$($(1)).rexx +rexx_STEP_TO_PROG = rexx/$($(1)).rexxpp rpython_STEP_TO_PROG = rpython/$($(1)) ruby_STEP_TO_PROG = ruby/$($(1)).rb rust_STEP_TO_PROG = rust/target/release/$($(1)) diff --git a/js/Makefile b/js/Makefile index 72e71348e4..8e4ad35bf1 100644 --- a/js/Makefile +++ b/js/Makefile @@ -6,6 +6,10 @@ SOURCES_LISP = env.js core.js stepA_mal.js SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) WEB_SOURCES = $(SOURCES:node_readline.js=jq_readline.js) +STEPS = step0_repl.js step1_read_print.js step2_eval.js step3_env.js \ + step4_if_fn_do.js step5_tco.js step6_file.js \ + step7_quote.js step8_macros.js step9_try.js stepA_mal.js + all: node_modules dist: mal.js mal web/mal.js @@ -13,6 +17,8 @@ dist: mal.js mal web/mal.js node_modules: npm install +$(STEPS): node_modules + mal.js: $(SOURCES) cat $+ | grep -v "= *require('./" >> $@ @@ -26,6 +32,7 @@ web/mal.js: $(WEB_SOURCES) clean: rm -f mal.js web/mal.js + rm -rf node_modules .PHONY: stats tests $(TESTS) From 115e430d02950571153b77e9774c777150d8806e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 14 Sep 2017 23:50:15 -0500 Subject: [PATCH 0154/1998] Basic: QBasic fixes/enabling. Recursive includes. Enable QBasic console mode usage and fix bugs in newline handling differences with C64 basic (cbm). To enable console mode for QBasic programs, have basicpp.py prefix the output with the QB64 specific console activation variables/functions. One change to basicpp.py to make this change more straightfowards is recursive includes so that includes can appear in more than just the top level step files. This allows us to conditionally include the right readline implementation. For QBasic in the special console mode (instead of the default full-screen UI mode) we need to use the LINE INPUT command in order to read input. --- .travis.yml | 3 +- Makefile | 6 ++++ basic/Dockerfile | 12 ++++++++ basic/Makefile | 26 ++++++++++------ basic/basicpp.py | 56 ++++++++++++++++++++++------------- basic/core.in.bas | 3 +- basic/printer.in.bas | 3 +- basic/reader.in.bas | 3 +- basic/readline.in.bas | 33 ++------------------- basic/readline_char.in.bas | 31 +++++++++++++++++++ basic/readline_line.in.bas | 6 ++++ basic/run | 6 +++- basic/step0_repl.in.bas | 3 +- basic/step1_read_print.in.bas | 3 +- basic/step2_eval.in.bas | 3 +- basic/step3_env.in.bas | 3 +- basic/step4_if_fn_do.in.bas | 3 +- basic/step5_tco.in.bas | 3 +- basic/step6_file.in.bas | 3 +- basic/step7_quote.in.bas | 3 +- basic/step8_macros.in.bas | 3 +- basic/step9_try.in.bas | 3 +- basic/stepA_mal.in.bas | 4 +-- 23 files changed, 146 insertions(+), 76 deletions(-) create mode 100644 basic/readline_char.in.bas create mode 100644 basic/readline_line.in.bas diff --git a/.travis.yml b/.travis.yml index bceeab73d8..45fc93f27a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,7 +8,8 @@ matrix: - {env: IMPL=ada, services: [docker]} - {env: IMPL=awk, services: [docker]} - {env: IMPL=bash, services: [docker]} - - {env: IMPL=basic, services: [docker]} + - {env: IMPL=basic basic_MODE=cbm, services: [docker]} + - {env: IMPL=basic basic_MODE=qbasic, services: [docker]} - {env: IMPL=c, services: [docker]} - {env: IMPL=cpp, services: [docker]} - {env: IMPL=coffee, services: [docker]} diff --git a/Makefile b/Makefile index b2c179d0f4..d89507d95d 100644 --- a/Makefile +++ b/Makefile @@ -46,6 +46,8 @@ all help: MAL_IMPL = js +# cbm or qbasic +basic_MODE = cbm # clj or cljs (Clojure vs ClojureScript/lumo) clojure_MODE = clj # python, js, cpp, or neko @@ -149,6 +151,9 @@ endif # Implementation specific utility functions # +basic_STEP_TO_PROG_cbm = basic/$($(1)).bas +basic_STEP_TO_PROG_qbasic = basic/$($(1)) + haxe_STEP_TO_PROG_neko = haxe/$($(1)).n haxe_STEP_TO_PROG_python = haxe/$($(1)).py haxe_STEP_TO_PROG_cpp = haxe/cpp/$($(1)) @@ -170,6 +175,7 @@ ada_STEP_TO_PROG = ada/$($(1)) awk_STEP_TO_PROG = awk/$($(1)).awk bash_STEP_TO_PROG = bash/$($(1)).sh basic_STEP_TO_PROG = basic/$($(1)).bas +basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) c_STEP_TO_PROG = c/$($(1)) d_STEP_TO_PROG = d/$($(1)) chuck_STEP_TO_PROG = chuck/$($(1)).ck diff --git a/basic/Dockerfile b/basic/Dockerfile index 95200cfb5d..928b1b1c62 100644 --- a/basic/Dockerfile +++ b/basic/Dockerfile @@ -32,3 +32,15 @@ RUN cd /tmp && \ cd .. && \ rm -r cbmbasic* +RUN apt-get install -y g++ mesa-common-dev libglu1-mesa-dev libasound2-dev wget +RUN cd /tmp && \ + curl -L http://www.qb64.net/release/official/2017_02_09__02_14_38-1.1-20170120.51/linux/qb64-1.1-20170120.51-lnx.tar.gz | tar xzf - && \ + cd qb64 && \ + find . -name '*.sh' -exec sed -i "s/\r//g" {} \; && \ + env EUID=1 ./setup_lnx.sh && \ + mkdir -p /usr/share/qb64 && \ + cp -a qb64 internal LICENSE programs source /usr/share/qb64/ && \ + echo '#!/bin/sh\ncd /usr/share/qb64\n./qb64 "${@}"' > /usr/bin/qb64 && \ + chmod +x /usr/bin/qb64 + + diff --git a/basic/Makefile b/basic/Makefile index 3373ea52b1..e2cd4bb3f5 100644 --- a/basic/Makefile +++ b/basic/Makefile @@ -1,5 +1,7 @@ -MODE = cbm -BASICPP_OPTS = --mode $(MODE) +basic_MODE = cbm +BASICPP_OPTS = --mode $(basic_MODE) + +QB64 = qb64 STEPS4_A = step4_if_fn_do.bas step5_tco.bas step6_file.bas \ step7_quote.bas step8_macros.bas step9_try.bas stepA_mal.bas @@ -7,19 +9,23 @@ STEPS3_A = step3_env.bas $(STEPS4_A) STEPS1_A = step1_read_print.bas step2_eval.bas $(STEPS3_A) STEPS0_A = step0_repl.bas $(STEPS1_A) +$(STEPS0_A): readline.in.bas readline_line.in.bas readline_char.in.bas +$(STEPS1_A): debug.in.bas mem.in.bas types.in.bas reader.in.bas printer.in.bas +$(STEPS3_A): env.in.bas +$(STEPS4_A): core.in.bas + + all: $(STEPS0_A) step%.bas: step%.in.bas ./basicpp.py $(BASICPP_OPTS) $< > $@ -$(STEPS0_A): readline.in.bas -$(STEPS1_A): debug.in.bas mem.in.bas types.in.bas reader.in.bas printer.in.bas -$(STEPS3_A): env.in.bas -$(STEPS4_A): core.in.bas - tests/%.bas: tests/%.in.bas ./basicpp.py $(BASICPP_OPTS) $< > $@ +# QBasic specific compilation rule +step%: step%.bas + $(QB64) -x $(abspath $<) -o $(abspath $@) # CBM/C64 image rules @@ -51,11 +57,13 @@ mal.d64: mal.prg .args.mal.prg core.mal.prg .PHONY: clean stats clean: - rm -f $(STEPS0_A) *.d64 *.prg + rm -f $(STEPS0_A) $(subst .bas,,$(STEPS0_A)) *.d64 *.prg qb64 + rm -rf ./internal SOURCES_LISP = env.in.bas core.in.bas stepA_mal.in.bas -SOURCES = readline.in.bas types.in.bas reader.in.bas printer.in.bas $(SOURCES_LISP) +SOURCES = readline.in.bas readline_line.in.bas readline_char.in.bas \ + types.in.bas reader.in.bas printer.in.bas $(SOURCES_LISP) stats: $(SOURCES) @wc $^ diff --git a/basic/basicpp.py b/basic/basicpp.py index fbe1c41f27..cb2f6223f8 100755 --- a/basic/basicpp.py +++ b/basic/basicpp.py @@ -13,6 +13,7 @@ def parse_args(): parser.add_argument('infiles', type=str, nargs='+', help='the Basic files to preprocess') parser.add_argument('--mode', choices=["cbm", "qbasic"], default="cbm") + parser.add_argument('--sub-mode', choices=["noui", "ui"], default="noui") parser.add_argument('--keep-rems', action='store_true', default=False, help='The type of REMs to keep (0 (none) -> 4 (all)') parser.add_argument('--keep-blank-lines', action='store_true', default=False, @@ -25,6 +26,7 @@ def parse_args(): help='Do not combine lines using the ":" separator') args = parser.parse_args() + args.full_mode = "%s-%s" % (args.mode, args.sub_mode) if args.keep_rems and not args.skip_combine_lines: debug("Option --keep-rems implies --skip-combine-lines ") args.skip_combine_lines = True @@ -36,30 +38,37 @@ def parse_args(): return args # pull in include files -def resolve_includes(orig_lines, keep_rems=0): +def resolve_includes(orig_lines, args): included = {} - lines = [] - for line in orig_lines: - m = re.match(r"^ *REM \$INCLUDE: '([^'\n]*)' *$", line) - if m and m.group(1) not in included: - f = m.group(1) - if f not in included: + lines = orig_lines[:] + position = 0 + while position < len(lines): + line = lines[position] + m = re.match(r"^(?:#([^ ]*) )? *REM \$INCLUDE: '([^'\n]*)' *$", line) + if m: + mode = m.group(1) + f = m.group(2) + if mode and mode != args.mode and mode != args.full_mode: + position += 1 + elif f not in included: ilines = [l.rstrip() for l in open(f).readlines()] - if keep_rems: lines.append("REM vvv BEGIN '%s' vvv" % f) - lines.extend(ilines) - if keep_rems: lines.append("REM ^^^ END '%s' ^^^" % f) + if args.keep_rems: lines.append("REM vvv BEGIN '%s' vvv" % f) + lines[position:position+1] = ilines + if args.keep_rems: lines.append("REM ^^^ END '%s' ^^^" % f) else: debug("Ignoring already included file: %s" % f) else: - lines.append(line) + position += 1 return lines -def resolve_mode(orig_lines, mode): +def resolve_mode(orig_lines, args): lines = [] for line in orig_lines: m = re.match(r"^ *#([^ \n]*) *([^\n]*)$", line) if m: - if m.group(1) == mode: + if m.group(1) == args.mode: + lines.append(m.group(2)) + elif m.group(1) == args.full_mode: lines.append(m.group(2)) continue lines.append(line) @@ -121,7 +130,7 @@ def misc_fixups(orig_lines): return text.split("\n") -def finalize(lines, args, mode): +def finalize(lines, args): labels_lines = {} lines_labels = {} call_index = {} @@ -158,7 +167,7 @@ def finalize(lines, args, mode): label = sub+"_"+str(call_index[sub]) # Replace the CALL with stack based GOTO - if mode == "cbm": + if args.mode == "cbm": lines.append("%s %sQ=%s:GOSUBPUSH_Q:GOTO%s" % ( lnum, prefix, call_index[sub], sub)) else: @@ -199,7 +208,7 @@ def finalize(lines, args, mode): index = call_index[cur_sub] ret_labels = [cur_sub+"_"+str(i) for i in range(1, index+1)] - if mode == "cbm": + if args.mode == "cbm": line = "%s GOSUBPOP_Q:ONQGOTO%s" % (lnum, ",".join(ret_labels)) else: line = "%s X=X-1:ON X%%(X+1) GOTO %s" % (lnum, ",".join(ret_labels)) @@ -213,7 +222,7 @@ def update_labels_lines(text, a, b): stext = text text = re.sub(r"(THEN *)%s\b" % a, r"\g<1>%s" % b, stext) #text = re.sub(r"(THEN)%s\b" % a, r"THEN%s" % b, stext) - if mode == "cbm": + if args.mode == "cbm": text = re.sub(r"ON *([^:\n]*) *GOTO *([^:\n]*)\b%s\b" % a, r"ON\g<1>GOTO\g<2>%s" % b, text) text = re.sub(r"ON *([^:\n]*) *GOSUB *([^:\n]*)\b%s\b" % a, r"ON\g<1>GOSUB\g<2>%s" % b, text) else: @@ -286,6 +295,13 @@ def renum(line): text = update_labels_lines(text, a, b) lines = text.split("\n") + # Force non-UI QBasic to use text console. LINE INPUT also needs + # to be used instead in character-by-character READLINE + if args.full_mode == "qbasic-noui": + # Add console program prefix for qb64/qbasic + lines = ["$CONSOLE", + "$SCREENHIDE", + "_DEST _CONSOLE"] + lines return lines @@ -300,10 +316,10 @@ def renum(line): debug("Original lines: %s" % len(lines)) # pull in include files - lines = resolve_includes(lines, keep_rems=args.keep_rems) + lines = resolve_includes(lines, args) debug("Lines after includes: %s" % len(lines)) - lines = resolve_mode(lines, mode=args.mode) + lines = resolve_mode(lines, args) debug("Lines after resolving mode specific lines: %s" % len(lines)) # drop blank lines @@ -325,7 +341,7 @@ def renum(line): lines = misc_fixups(lines) # number lines, drop/keep labels, combine lines - lines = finalize(lines, args, mode=args.mode) + lines = finalize(lines, args) debug("Lines after finalizing: %s" % len(lines)) print("\n".join(lines)) diff --git a/basic/core.in.bas b/basic/core.in.bas index 4cce38a68f..1d22fe2863 100644 --- a/basic/core.in.bas +++ b/basic/core.in.bas @@ -271,7 +271,8 @@ DO_FUNCTION: DO_SLURP_LOOP: C$="" RJ=1:GOSUB READ_FILE_CHAR - IF ASC(C$)=10 THEN R$=R$+CHR$(13) + #cbm IF ASC(C$)=10 THEN R$=R$+CHR$(13) + #qbasic IF ASC(C$)=10 THEN R$=R$+CHR$(10) IF (ASC(C$)<>10) AND (C$<>"") THEN R$=R$+C$ IF EZ>0 THEN GOTO DO_SLURP_DONE GOTO DO_SLURP_LOOP diff --git a/basic/printer.in.bas b/basic/printer.in.bas index 41e75822f1..55c6360b47 100644 --- a/basic/printer.in.bas +++ b/basic/printer.in.bas @@ -37,7 +37,8 @@ PR_STR: PR_STRING_READABLY: S1$="\":S2$="\\":GOSUB REPLACE: REM escape backslash " S1$=CHR$(34):S2$="\"+CHR$(34):GOSUB REPLACE: REM escape quotes " - S1$=CHR$(13):S2$="\n":GOSUB REPLACE: REM escape newlines + #cbm S1$=CHR$(13):S2$="\n":GOSUB REPLACE: REM escape newlines + #qbasic S1$=CHR$(10):S2$="\n":GOSUB REPLACE: REM escape newlines R$=CHR$(34)+R$+CHR$(34) RETURN PR_SYMBOL: diff --git a/basic/reader.in.bas b/basic/reader.in.bas index 955cabc4e2..daafb43ca9 100644 --- a/basic/reader.in.bas +++ b/basic/reader.in.bas @@ -169,7 +169,8 @@ SUB READ_FORM IF C<>34 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"'":GOTO READ_FORM_RETURN R$=MID$(T$,2,LEN(T$)-2) S1$=CHR$(92)+CHR$(34):S2$=CHR$(34):GOSUB REPLACE: REM unescape quotes - S1$=CHR$(92)+"n":S2$=CHR$(13):GOSUB REPLACE: REM unescape newlines + #cbm S1$=CHR$(92)+"n":S2$=CHR$(13):GOSUB REPLACE: REM unescape newlines + #qbasic S1$=CHR$(92)+"n":S2$=CHR$(10):GOSUB REPLACE: REM unescape newlines S1$=CHR$(92)+CHR$(92):S2$=CHR$(92):GOSUB REPLACE: REM unescape backslashes REM intern string value B$=R$:T=4:GOSUB STRING diff --git a/basic/readline.in.bas b/basic/readline.in.bas index 75b7996343..67cbaa76ba 100644 --- a/basic/readline.in.bas +++ b/basic/readline.in.bas @@ -1,31 +1,4 @@ -REM READLINE(A$) -> R$ -READLINE: - EZ=0 - PRINT A$; - C$="":R$="":C=0 - READCH: - #cbm GET C$ - #qbasic C$=INKEY$ - IF C$="" THEN GOTO READCH - C=ASC(C$) - REM PRINT C - #qbasic IF ASC(C$)=8 THEN C=20:C$=CHR$(20) - IF C=4 OR C=0 THEN EZ=1:GOTO RL_DONE: REM EOF - IF C=127 OR C=20 THEN GOSUB RL_BACKSPACE - IF C=127 OR C=20 THEN GOTO READCH - IF (C<32 OR C>127) AND C<>13 THEN GOTO READCH - PRINT C$; - IF LEN(R$)<255 AND C$<>CHR$(13) THEN R$=R$+C$ - IF LEN(R$)<255 AND C$<>CHR$(13) THEN GOTO READCH - RL_DONE: - RETURN - REM Assumes R$ has input buffer - RL_BACKSPACE: - IF LEN(R$)=0 THEN RETURN - R$=LEFT$(R$,LEN(R$)-1) - #cbm PRINT CHR$(157)+" "+CHR$(157); - #qbasic LOCATE ,POS(0)-1 - #qbasic PRINT " "; - #qbasic LOCATE ,POS(0)-1 - RETURN +#cbm REM $INCLUDE: 'readline_char.in.bas' +#qbasic-ui REM $INCLUDE: 'readline_char.in.bas' +#qbasic-noui REM $INCLUDE: 'readline_line.in.bas' diff --git a/basic/readline_char.in.bas b/basic/readline_char.in.bas new file mode 100644 index 0000000000..75b7996343 --- /dev/null +++ b/basic/readline_char.in.bas @@ -0,0 +1,31 @@ +REM READLINE(A$) -> R$ +READLINE: + EZ=0 + PRINT A$; + C$="":R$="":C=0 + READCH: + #cbm GET C$ + #qbasic C$=INKEY$ + IF C$="" THEN GOTO READCH + C=ASC(C$) + REM PRINT C + #qbasic IF ASC(C$)=8 THEN C=20:C$=CHR$(20) + IF C=4 OR C=0 THEN EZ=1:GOTO RL_DONE: REM EOF + IF C=127 OR C=20 THEN GOSUB RL_BACKSPACE + IF C=127 OR C=20 THEN GOTO READCH + IF (C<32 OR C>127) AND C<>13 THEN GOTO READCH + PRINT C$; + IF LEN(R$)<255 AND C$<>CHR$(13) THEN R$=R$+C$ + IF LEN(R$)<255 AND C$<>CHR$(13) THEN GOTO READCH + RL_DONE: + RETURN + + REM Assumes R$ has input buffer + RL_BACKSPACE: + IF LEN(R$)=0 THEN RETURN + R$=LEFT$(R$,LEN(R$)-1) + #cbm PRINT CHR$(157)+" "+CHR$(157); + #qbasic LOCATE ,POS(0)-1 + #qbasic PRINT " "; + #qbasic LOCATE ,POS(0)-1 + RETURN diff --git a/basic/readline_line.in.bas b/basic/readline_line.in.bas new file mode 100644 index 0000000000..3d65f4172f --- /dev/null +++ b/basic/readline_line.in.bas @@ -0,0 +1,6 @@ +REM READLINE(A$) -> R$ +READLINE: + EZ=0 + PRINT A$ ; + LINE INPUT ; R$ + RETURN diff --git a/basic/run b/basic/run index 7fe8318cc2..df853cbc5d 100755 --- a/basic/run +++ b/basic/run @@ -1,4 +1,8 @@ #!/bin/bash cd $(dirname $0) (echo "(list $(for a in "${@}"; do echo -n "\"${a}\""; done))") > .args.mal -exec cbmbasic ${STEP:-stepA_mal}.bas "${@}" +case ${basic_MODE:-cbm} in + cbm) exec cbmbasic ${STEP:-stepA_mal}.bas "${@}" ;; + qbasic) exec ./${STEP:-stepA_mal} "${@}" ;; + *) echo "Invalid basic_MODE: ${basic_MODE}"; exit 2 ;; +esac diff --git a/basic/step0_repl.in.bas b/basic/step0_repl.in.bas index 3d05ae2069..a7c3e74b2b 100755 --- a/basic/step0_repl.in.bas +++ b/basic/step0_repl.in.bas @@ -39,5 +39,6 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM diff --git a/basic/step1_read_print.in.bas b/basic/step1_read_print.in.bas index 2e5d045a64..aa0c45f310 100755 --- a/basic/step1_read_print.in.bas +++ b/basic/step1_read_print.in.bas @@ -57,7 +57,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step2_eval.in.bas b/basic/step2_eval.in.bas index 74ecaae76d..062f83cd3f 100755 --- a/basic/step2_eval.in.bas +++ b/basic/step2_eval.in.bas @@ -242,7 +242,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step3_env.in.bas b/basic/step3_env.in.bas index 615fb2c02c..8340fd2732 100755 --- a/basic/step3_env.in.bas +++ b/basic/step3_env.in.bas @@ -303,7 +303,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step4_if_fn_do.in.bas b/basic/step4_if_fn_do.in.bas index 3b2a8cf061..c3ca6eedcf 100755 --- a/basic/step4_if_fn_do.in.bas +++ b/basic/step4_if_fn_do.in.bas @@ -361,7 +361,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step5_tco.in.bas b/basic/step5_tco.in.bas index f6f4a1dc83..184235c09c 100755 --- a/basic/step5_tco.in.bas +++ b/basic/step5_tco.in.bas @@ -385,7 +385,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step6_file.in.bas b/basic/step6_file.in.bas index 86e664a85d..5d894d3c58 100755 --- a/basic/step6_file.in.bas +++ b/basic/step6_file.in.bas @@ -416,7 +416,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step7_quote.in.bas b/basic/step7_quote.in.bas index 909757db51..75b91cc313 100755 --- a/basic/step7_quote.in.bas +++ b/basic/step7_quote.in.bas @@ -506,7 +506,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step8_macros.in.bas b/basic/step8_macros.in.bas index 6ded89414e..c2c6f8edff 100755 --- a/basic/step8_macros.in.bas +++ b/basic/step8_macros.in.bas @@ -582,7 +582,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: PRINT "Error: "+E$ diff --git a/basic/step9_try.in.bas b/basic/step9_try.in.bas index e9b35adb0e..43ced642e2 100755 --- a/basic/step9_try.in.bas +++ b/basic/step9_try.in.bas @@ -614,7 +614,8 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: REM if the error is an object, then print and free it diff --git a/basic/stepA_mal.in.bas b/basic/stepA_mal.in.bas index 69b6485714..e4facc5a55 100755 --- a/basic/stepA_mal.in.bas +++ b/basic/stepA_mal.in.bas @@ -627,12 +627,12 @@ MAIN: QUIT: REM GOSUB PR_MEMORY_SUMMARY_SMALL - PRINT:GOSUB PR_MEMORY_SUMMARY_SMALL REM GOSUB PR_MEMORY_MAP REM P1=0:P2=ZI:GOSUB PR_MEMORY REM P1=D:GOSUB PR_OBJECT REM P1=ZK:GOSUB PR_OBJECT - END + #cbm END + #qbasic SYSTEM PRINT_ERROR: REM if the error is an object, then print and free it From e17aef048ef18f917d3294064c4b04be237ae648 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 15 Sep 2017 00:00:23 -0500 Subject: [PATCH 0155/1998] Misc fixes and TODO updates. - Truncate ruby and python stacktraces since they can get very long in certain cases causing problems. - Fix Clojure West example with proper escaping. --- .gitignore | 1 + docs/TODO | 39 +++++++++++++++++++----------------- examples/clojurewest2014.mal | 8 ++++---- process/guide.md | 1 + python/step5_tco.py | 2 +- ruby/step5_tco.rb | 2 +- runtest.py | 1 + 7 files changed, 30 insertions(+), 24 deletions(-) diff --git a/.gitignore b/.gitignore index 279cf5c950..887b03c3f6 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ .sbt .npm .node-gyp +.elm */experiments */node_modules *.o diff --git a/docs/TODO b/docs/TODO index ef3b531da1..a273008f76 100644 --- a/docs/TODO +++ b/docs/TODO @@ -7,17 +7,13 @@ General: ./core.mal to ./lib directory - Finish guide.md - - Refactor ./run: - - java: build step, don't use mvn to run - - plpgsql: maybe combine wrap.sh and run - - vhdl: combine run_vhdl.sh and run - - vimscript: combine run_vimscript.sh and run + - mention that identifier names are suggested. some have run + into collisions with READ,EVAL,PRINT in case insensitive + languages All Implementations: - regular expression matching in runtest - add re (use in rep) everywhere and use that (to avoid printing) - - per impl tests for step5_tco, or at least a better way of - enabling/disabling/tweaking per implementation - fix stepA soft failures: lua matlab miniMAL perl racket Other ideas for All: @@ -55,15 +51,11 @@ Bash: C: - come up with better way to do 20 vararg code - - GC: use http://www.hboehm.info/gc/ C#: - accumulates line breaks with mal/clojurewest2014.mal - interop: http://www.ckode.dk/programming/eval-in-c-yes-its-possible/ -Clojure: - - fix "\/" exception in mal/clojurewest2014.mal - CoffeeScript: - make target to compile to JS @@ -77,9 +69,9 @@ Haskell: - immediately exits mal/clojurewest2014.mal ("\/" exception) Java: + - build step, don't use mvn in run script - Use gradle instead of mvn http://blog.paralleluniverse.co/2014/05/01/modern-java/ - - MAL formatting is a bit off with mal/clojurewest2014.mal Javascript: - interop: adopt techniques from miniMAL @@ -87,9 +79,6 @@ Javascript: Make: - allow '_' in make variable names - hash-map with space in key string - - Fix: make -f stepA_mal.mk ../mal/step6_file.mal - (slurp "../tests/incA.mal") - (read-string "(+ 2 3)") - errors should propagate up from within load-file - GC: expore using "undefined" directive in Make 3.82 @@ -97,9 +86,6 @@ Mal: - line numbers in errors - step5_tco -MATLAB: - - Port to support both GNU Octave and MATLAB - miniMAL: - figure out why {} literals are "static"/persistent @@ -107,6 +93,9 @@ ObjPascal: - verify that GC/reference counting works - fix comment by itself error at REPL +plpgsql: + - maybe combine wrap.sh and run + Perl: - fix metadata on native functions - fix extra line breaks at REPL @@ -116,6 +105,14 @@ Postscript: - fix blank line after comments - fix command line arg processing (doesn't run file specified) +Powershell: + - convert function with "abc_def" to "abc-def" + - remove extraneous return statements at end of functions + - remove unnecessary semi-colons + - use ArrayList instead of Array for performance + - new test to test Keys/keys as hash-map key + - test *? predicates with nil + R: - tracebacks in errors - fix running from different directory @@ -129,3 +126,9 @@ Rust: Scala - readline - fix exception when finished running something on command line + +VHDL: + - combine run_vhdl.sh and run + +vimscript: + - combine run_vimscript.sh and run diff --git a/examples/clojurewest2014.mal b/examples/clojurewest2014.mal index 2b5be9c665..98fcf17fef 100755 --- a/examples/clojurewest2014.mal +++ b/examples/clojurewest2014.mal @@ -25,10 +25,10 @@ (list (list (title2 " __ __ _ _") - (title2 "| \/ | / \ | |") - (title2 "| |\/| | / _ \ | | ") - (title2 "| | | |/ ___ \| |___ ") - (title2 "|_| |_/_/ \_\_____|")) + (title2 "| \\/ | / \\ | |") + (title2 "| |\\/| | / _ \\ | | ") + (title2 "| | | |/ ___ \\| |___ ") + (title2 "|_| |_/_/ \\_\\_____|")) (list (title "gherkin") "- a lisp1 written in bash4") diff --git a/process/guide.md b/process/guide.md index cd17969bf0..2da87827e5 100644 --- a/process/guide.md +++ b/process/guide.md @@ -1329,6 +1329,7 @@ implementation. Let us continue! * In the main program, use the `rep` function to define two new control structures macros. Here are the string arguments for `rep` to define these macros: + * TODO: note throw is not present until step9 * `cond`: "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" * `or`: "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" diff --git a/python/step5_tco.py b/python/step5_tco.py index da338d413f..8b714cef10 100644 --- a/python/step5_tco.py +++ b/python/step5_tco.py @@ -97,4 +97,4 @@ def REP(str): print(REP(line)) except reader.Blank: continue except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) + print("".join(traceback.format_exception(*sys.exc_info())[0:100])) diff --git a/ruby/step5_tco.rb b/ruby/step5_tco.rb index a6a82d46da..059bb55a6b 100644 --- a/ruby/step5_tco.rb +++ b/ruby/step5_tco.rb @@ -103,6 +103,6 @@ def PRINT(exp) puts REP[line] rescue Exception => e puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" + puts "\t#{e.backtrace[0..100].join("\n\t")}" end end diff --git a/runtest.py b/runtest.py index c3735adee4..1930b62c1d 100755 --- a/runtest.py +++ b/runtest.py @@ -127,6 +127,7 @@ def read_to_prompt(self, prompts, timeout): new_data = new_data.decode("utf-8") if IS_PY_3 else new_data #print("new_data: '%s'" % new_data) debug(new_data) + # Perform newline cleanup if self.no_pty: self.buf += new_data.replace("\n", "\r\n") else: From 47bcc4c0fac0fe6fea6cbb1dbf196a6881e8af53 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 15 Sep 2017 09:29:38 -0500 Subject: [PATCH 0156/1998] Basic: fix time-ms for QBasic. --- basic/core.in.bas | 3 ++- basic/mem.in.bas | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basic/core.in.bas b/basic/core.in.bas index 1d22fe2863..d8b7a5025a 100644 --- a/basic/core.in.bas +++ b/basic/core.in.bas @@ -308,7 +308,8 @@ DO_FUNCTION: T=2:L=A1/B1:GOSUB ALLOC RETURN DO_TIME_MS: - T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC + #cbm T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC + #qbasic T=2:L=INT((TIMER(0.001)-BT#)*1000):GOSUB ALLOC RETURN DO_LIST: diff --git a/basic/mem.in.bas b/basic/mem.in.bas index a0065ec232..d4a6d54570 100644 --- a/basic/mem.in.bas +++ b/basic/mem.in.bas @@ -383,7 +383,8 @@ INIT_MEMORY: ZK=16 REM start of time clock - BT=TI + #cbm BT=TI + #qbasic BT#=TIMER(0.001) RETURN From 0198b7a230e48a6e06fed419c406833904244941 Mon Sep 17 00:00:00 2001 From: Sebastian Rasmussen Date: Fri, 15 Sep 2017 19:57:10 +0200 Subject: [PATCH 0157/1998] Fix a number of typos in documentation/comments. --- LICENSE | 2 +- basic/variables.txt | 2 +- chuck/notes.md | 4 ++-- cpp/README.md | 2 +- docs/FAQ.md | 2 +- docs/Hints.md | 4 ++-- docs/TODO | 2 +- docs/step_notes.txt | 2 +- examples/clojurewest2014.mal | 2 +- examples/memoize.mal | 4 ++-- examples/presentation.mal | 2 +- process/guide.md | 4 ++-- 12 files changed, 16 insertions(+), 16 deletions(-) diff --git a/LICENSE b/LICENSE index 3bfdf5f61e..88b2867725 100644 --- a/LICENSE +++ b/LICENSE @@ -4,7 +4,7 @@ Mal (make-a-lisp) is licensed under the MPL 2.0 (Mozilla Public License 2.0). The text of the MPL 2.0 license is included below and can be found at https://www.mozilla.org/MPL/2.0/ -Many of the implemenations run or compile using a line editing +Many of the implementations run or compile using a line editing library. In some cases, the implementations provide an option in the code to switch between the GNU GPL licensed GNU readline library and the BSD licensed editline (libedit) library. diff --git a/basic/variables.txt b/basic/variables.txt index dd6cbf8a4f..3e7afc7623 100644 --- a/basic/variables.txt +++ b/basic/variables.txt @@ -36,7 +36,7 @@ Calling arguments/temporaries: A : common call argument (especially EVAL, EVAL_AST) A$ : common call argument (READLINE, reader, string temp, key value) B : common call argument -B$ : STRING arg (HASHMAP_GET temp), PR_STR_SEQ seperator +B$ : STRING arg (HASHMAP_GET temp), PR_STR_SEQ separator : INIT_CORE_SET_FUNCTION, ENV_SET_S, ASSOC1_S C : common call argument, DO_TCO_FUNCTION temp in DO_APPLY E : environment (EVAL, EVAL_AST) diff --git a/chuck/notes.md b/chuck/notes.md index e897610d2a..c467d15bc9 100644 --- a/chuck/notes.md +++ b/chuck/notes.md @@ -1,7 +1,7 @@ # Step 1 - What if I don't have an OOP language? -- types.qx could be more promently mentioned... +- types.qx could be more prominently mentioned... - A table with all types and suggested object names would be hugely useful - Same for a list of all errors and their messages @@ -146,7 +146,7 @@ this even related? - It would be worth to mention that `with-meta` shall clone its argument to avoid one of the more sneaky test failure reasons -- "The value of this entry should be a mal string containing thename +- "The value of this entry should be a mal string containing the name of the current implementation." - "When the REPL starts up (as opposed to when it is called with a script and/or arguments), call the rep function with this string to diff --git a/cpp/README.md b/cpp/README.md index d62db64742..6bae4435ec 100644 --- a/cpp/README.md +++ b/cpp/README.md @@ -30,7 +30,7 @@ can be used to make and run this implementation. ./docker make - * run one of the implemenations: + * run one of the implementations: ./docker run ./stepA_mal diff --git a/docs/FAQ.md b/docs/FAQ.md index f292b1bf2c..d4536c0000 100644 --- a/docs/FAQ.md +++ b/docs/FAQ.md @@ -101,7 +101,7 @@ functionality goes into which step: a scientific fact that many small rewards are more motivating than a single large reward (citation intentionally omitted, get a small reward by googling it yourself). Each step in mal adds new - functionality that can actually be exercised by the implementor and, + functionality that can actually be exercised by the implementer and, just as importantly, easily tested. Also, the step structure of mal/make-a-lisp is not perfect. It never diff --git a/docs/Hints.md b/docs/Hints.md index d9d44c3519..3686cc833d 100644 --- a/docs/Hints.md +++ b/docs/Hints.md @@ -1,4 +1,4 @@ -# Mal/Make-a-Lisp Implmentation Hints +# Mal/Make-a-Lisp Implementation Hints @@ -81,7 +81,7 @@ it is considered legitimate for upstream inclusion. ### How do I read the command-line arguments if my language runtime doesn't support access to them? Most languages give access to the command-line arguments that were passed to -the program, either as an arguement to the `main` function (like `argc` and +the program, either as an argument to the `main` function (like `argc` and `argv` in C) or as a global variable (like `sys.argv` in Python). If your target language doesn't have such mechanisms, consider adding a wrapper script that will read the command-line arguments that were passed to the script and diff --git a/docs/TODO b/docs/TODO index a273008f76..074277f6c9 100644 --- a/docs/TODO +++ b/docs/TODO @@ -80,7 +80,7 @@ Make: - allow '_' in make variable names - hash-map with space in key string - errors should propagate up from within load-file - - GC: expore using "undefined" directive in Make 3.82 + - GC: explore using "undefined" directive in Make 3.82 Mal: - line numbers in errors diff --git a/docs/step_notes.txt b/docs/step_notes.txt index e28761a3c0..df6a74e6ad 100644 --- a/docs/step_notes.txt +++ b/docs/step_notes.txt @@ -379,7 +379,7 @@ Step Notes: - Now self-hosting! -- Extra defintions needed for self-hosting +- Extra definitions needed for self-hosting - core module: - symbol?, sequential? (if not already) - vector, vector? diff --git a/examples/clojurewest2014.mal b/examples/clojurewest2014.mal index 98fcf17fef..2d26336bed 100755 --- a/examples/clojurewest2014.mal +++ b/examples/clojurewest2014.mal @@ -84,7 +84,7 @@ "- performance" "- namespaces" "- keywords" - "- GC (in bash, make, C implmentations)" + "- GC (in bash, make, C implementations)" "- lots of other things") (list (title "why?") diff --git a/examples/memoize.mal b/examples/memoize.mal index 500666c2de..0f9a882744 100644 --- a/examples/memoize.mal +++ b/examples/memoize.mal @@ -1,13 +1,13 @@ ;; ;; memoize.mal ;; -;; Impelement `memoize` using an atom (`mem`) which holds the memoized results +;; Implement `memoize` using an atom (`mem`) which holds the memoized results ;; (hash-map from the arguments to the result). When the function is called, ;; the hash-map is checked to see if the result for the given argument was already ;; calculated and stored. If this is the case, it is returned immediately; ;; otherwise, it is calculated and stored in `mem`. ;; -;; Adapated from http://clojure.org/atoms +;; Adapted from http://clojure.org/atoms ;; ;; Memoize any function diff --git a/examples/presentation.mal b/examples/presentation.mal index 80dadac426..093f9fafce 100755 --- a/examples/presentation.mal +++ b/examples/presentation.mal @@ -83,7 +83,7 @@ (title "things it does not have") "- performance" "- namespaces" - "- GC (in bash, make, C implmentations)" + "- GC (in bash, make, C implementations)" "- protocols :-(" "- lots of other things") (list diff --git a/process/guide.md b/process/guide.md index 2da87827e5..464897a185 100644 --- a/process/guide.md +++ b/process/guide.md @@ -523,7 +523,7 @@ repl_env = {'+': lambda a,b: a+b, `eval_ast` switches on the type of `ast` as follows: * symbol: lookup the symbol in the environment structure and return - the value or raise an error no value is found + the value or raise an error if no value is found * list: return a new list that is the result of calling `EVAL` on each of the members of the list * otherwise just return the original `ast` value @@ -1518,7 +1518,7 @@ diff -urp ../process/step9_try.txt ../process/stepA_mal.txt * Add a new "\*host-language\*" (symbol) entry to your REPL environment. The value of this entry should be a mal string - containing thename of the current implementation. + containing the name of the current implementation. * When the REPL starts up (as opposed to when it is called with a script and/or arguments), call the `rep` function with this string From 012e4179afb22ad6e1e9467bdd3dfaa78ab8c6a9 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Sep 2017 21:45:20 -0500 Subject: [PATCH 0158/1998] FAQ: expand main repo merge expectations section. --- docs/FAQ.md | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/docs/FAQ.md b/docs/FAQ.md index d4536c0000..6fb2c6750f 100644 --- a/docs/FAQ.md +++ b/docs/FAQ.md @@ -124,16 +124,6 @@ programming language. Here are a few guidelines for getting your implementation accepted into the main repository: -* Your implementation needs to be complete enough to self-host. This - means that all the mandatory tests should pass in both direct and - self-hosted modes: - ```bash - make "test^[IMPL_NAME]" - make MAL_IMPL=[IMPL_NAME] "test^mal" - ``` - You do not need to pass the final optional tests for stepA that are - marked as optional and not needed for self-hosting. - * Your implementation should follow the existing mal steps and structure: Lisp-centric code (eval, eval_ast, quasiquote, macroexpand) in the step files, other code in reader, printer, env, @@ -152,7 +142,35 @@ into the main repository: welcome). However, if it is clear to me that your implementation is not idiomatic in a given language then I will probably ask you to improve it first. - + +* Your implementation needs to be complete enough to self-host. This + means that all the mandatory tests should pass in both direct and + self-hosted modes: + ```bash + make "test^[IMPL_NAME]" + make MAL_IMPL=[IMPL_NAME] "test^mal" + ``` + You do not need to pass the final optional tests for stepA that are + marked as optional and not needed for self-hosting (except for the + `time-ms` function which is needed to run the micro-benchmark tests). + +* Create a `Dockerfile` in your directory that installs all the + packages necessary to build and run your implementation. Refer to other + implementations for examples of what the Dockerfile should contain. + Build your docker image and tag it `kanaka/mal-test-[IMPL_NAME]`. + The top-level Makefile has support for building/testing within + docker with the `DOCKERIZE` flag: + ```bash + make DOCKERIZE=1 "test^[IMPL_NAME]" + make DOCKERIZE=1 MAL_IMPL=[IMPL_NAME] "test^mal" + ``` + +* Make sure the Travis build and test scripts pass locally: + ```bash + IMPL=[IMPL_NAME] ./.travis_build.sh + ./.travis_test.sh test [IMPL_NAME] + ``` + * If you are creating a new implementation for an existing implementation (or somebody beats you to the punch while you are working on it), there is still a chance I will merge your From dd4020b944136680c70777a558161b41f9777527 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Sep 2017 21:45:57 -0500 Subject: [PATCH 0159/1998] Guide: fix TODOs. Add next steps section. Also move a few general TODOs to docs/TODO. --- docs/TODO | 5 ++++ process/guide.md | 74 +++++++++++++++++++++++++++++++++++------------- 2 files changed, 59 insertions(+), 20 deletions(-) diff --git a/docs/TODO b/docs/TODO index 074277f6c9..a2ef21b955 100644 --- a/docs/TODO +++ b/docs/TODO @@ -10,6 +10,11 @@ General: - mention that identifier names are suggested. some have run into collisions with READ,EVAL,PRINT in case insensitive languages + - simplify: "X argument (list element Y)" -> ast[Y] + - more clarity about when to peek and poke in read_list and + read_form + - tokenizer: use first group rather than whole match (to + eliminate whitespace/commas) All Implementations: - regular expression matching in runtest diff --git a/process/guide.md b/process/guide.md index 464897a185..aa996c743d 100644 --- a/process/guide.md +++ b/process/guide.md @@ -32,9 +32,9 @@ So jump right in (er ... start the climb)! You might already have a language in mind that you want to use. Technically speaking, mal can be implemented in any sufficiently -complete programming language (i.e. Turing complete), however, there are a few -language features that can make the task MUCH easier. Here are some of -them in rough order of importance: +complete programming language (i.e. Turing complete), however, there +are a few language features that can make the task MUCH easier. Here +are some of them in rough order of importance: * A sequential compound data structure (e.g. arrays, lists, vectors, etc) @@ -1329,8 +1329,11 @@ implementation. Let us continue! * In the main program, use the `rep` function to define two new control structures macros. Here are the string arguments for `rep` to define these macros: - * TODO: note throw is not present until step9 * `cond`: "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" + * Note that `cond` calls the `throw` function when `cond` is + called with an odd number of args. The `throw` function is + implemented in the next step, but it will still serve it's + purpose here by causing an undefined symbol error. * `or`: "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" @@ -1513,8 +1516,17 @@ diff -urp ../process/step9_try.txt ../process/stepA_mal.txt entered by the user is returned as a string. If the user sends an end-of-file (usually Ctrl-D), then nil is returned. -* Add meta-data support to mal functions. TODO. Should be separate - from the function macro flag. +* Add meta-data support to mal functions by adding a new metadata + attribute on mal functions that refers to another mal value/type + (nil by default). Add the following metadata related core functions: + * `meta`: this takes a single mal function argument and returns the + value of the metadata attribute. + * `with-meta`: this function takes two arguments. The first argument + is a mal function and the second argument is another mal + value/type to set as metadata. A copy of the mal function is + returned that has its `meta` attribute set to the second argument. + Note that it is important that the environment and macro attribute + of mal function are retained when it is copied. * Add a new "\*host-language\*" (symbol) entry to your REPL environment. The value of this entry should be a mal string @@ -1606,15 +1618,15 @@ For extra information read [Peter Seibel's thorough discussion about #### Optional additions -* Add metadata support to mal functions, other composite data - types, and native functions. +* Add metadata support to other composite data types (lists, vectors + and hash-maps), and to native functions. * Add the following new core functions: * `time-ms`: takes no arguments and returns the number of milliseconds since epoch (00:00:00 UTC January 1, 1970), or, if not possible, since another point in time (`time-ms` is usually used relatively to measure time durations). After `time-ms` is - implemented, you can run the mal implementation performance - benchmarks by running `make perf^quux`. + implemented, you can run the performance micro-benchmarks by + running `make perf^quux`. * `conj`: takes a collection and one or more elements as arguments and returns a new collection which includes the original collection and the new elements. If the collection is a list, a @@ -1640,13 +1652,35 @@ For extra information read [Peter Seibel's thorough discussion about function should be added in `quux/tests/stepA_mal.mal` (see the [tests for `lua-eval`](../lua/tests/stepA_mal.mal) as an example). - -## TODO: - -* simplify: "X argument (list element Y)" -> ast[Y] -* list of types with metadata: mal functions (required for - self-hosting), list, vector, hash-map, native functions (optional - for self-hosting). -* more clarity about when to peek and poke in read_list and read_form -* tokenizer: use first group rather than whole match (to eliminate - whitespace/commas) +### Next Steps + +* Join the #mal IRC channel. It's fairly quiet but there are bursts of + interesting conversation related to mal, Lisps, esoteric programming + languages, etc. +* If you have created an implementation for a new target language (or + a unique and interesting variant of an existing implementation), + consider sending a pull request to add it into the main mal + repository. The [FAQ](FAQ.md#add_implementation) describes general + requirements for getting an implementation merged into the main + repository. +* Take your interpreter implementation and have it emit source code in + the target language rather than immediately evaluating it. In other + words, create a compiler. +* Pick a new target language and implement mal in it. Pick a language + that is very different from any that you already know. +* Use your mal implementation to implement a real world project. Many + of these will force you to address interop. Some ideas: + * Web server (with mal as CGI language for extra points) + * An IRC/Slack chat bot + * An editor (GUI or curses) with mal as a scripting/extension + language. + * An AI player for a game like Chess or Go. +* Implement a feature in your mal implementation that is not covered + by this guide. Some ideas: + * Namespaces + * Multi-threading support + * Errors with line numbers and/or stack traces. + * Lazy sequences + * Clojure-style protocols + * Full call/cc (call-with-current-continuation) support + * Explicit TCO (i.e. `recur`) with tail-position error checking From 0a9a4685371e02598a7bc4a30123c471b13f1bb8 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Sep 2017 22:05:03 -0500 Subject: [PATCH 0160/1998] python: remove extraneous macroexpand call. --- python/step8_macros.py | 2 +- python/step9_try.py | 2 +- python/stepA_mal.py | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/python/step8_macros.py b/python/step8_macros.py index 016aae8ed3..cdf7969306 100644 --- a/python/step8_macros.py +++ b/python/step8_macros.py @@ -37,7 +37,7 @@ def is_macro_call(ast, env): def macroexpand(ast, env): while is_macro_call(ast, env): mac = env.get(ast[0]) - ast = macroexpand(mac(*ast[1:]), env) + ast = mac(*ast[1:]) return ast def eval_ast(ast, env): diff --git a/python/step9_try.py b/python/step9_try.py index 9cebe9c662..80b7f5d2f5 100644 --- a/python/step9_try.py +++ b/python/step9_try.py @@ -37,7 +37,7 @@ def is_macro_call(ast, env): def macroexpand(ast, env): while is_macro_call(ast, env): mac = env.get(ast[0]) - ast = macroexpand(mac(*ast[1:]), env) + ast = mac(*ast[1:]) return ast def eval_ast(ast, env): diff --git a/python/stepA_mal.py b/python/stepA_mal.py index 6f2f6dabf2..2da3f7190f 100644 --- a/python/stepA_mal.py +++ b/python/stepA_mal.py @@ -37,7 +37,7 @@ def is_macro_call(ast, env): def macroexpand(ast, env): while is_macro_call(ast, env): mac = env.get(ast[0]) - ast = macroexpand(mac(*ast[1:]), env) + ast = mac(*ast[1:]) return ast def eval_ast(ast, env): From cf01dac14531c9df661bba199c81cbd53bea247c Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Sep 2017 22:31:02 -0500 Subject: [PATCH 0161/1998] Add package.lock to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 887b03c3f6..a0cf920095 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ .sbt .npm .node-gyp +package-lock.json .elm */experiments */node_modules From 67365c05460ffc24f2244bab9db243543ff93751 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Sep 2017 22:35:59 -0500 Subject: [PATCH 0162/1998] Hy: step0 --- Makefile | 3 ++- hy/run | 2 ++ hy/step0_repl.hy | 20 ++++++++++++++++++++ 3 files changed, 24 insertions(+), 1 deletion(-) create mode 100755 hy/run create mode 100755 hy/step0_repl.hy diff --git a/Makefile b/Makefile index d89507d95d..100e2f9086 100644 --- a/Makefile +++ b/Makefile @@ -80,7 +80,7 @@ DOCKERIZE = IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs dart \ erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ - haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ + haxe hy io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ ts vb vhdl vimscript livescript elm @@ -199,6 +199,7 @@ gst_STEP_TO_PROG = gst/$($(1)).st java_STEP_TO_PROG = java/target/classes/mal/$($(1)).class haskell_STEP_TO_PROG = haskell/$($(1)) haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(haxe_MODE)) +hy_STEP_TO_PROG = hy/$($(1)).hy io_STEP_TO_PROG = io/$($(1)).io julia_STEP_TO_PROG = julia/$($(1)).jl js_STEP_TO_PROG = js/$($(1)).js diff --git a/hy/run b/hy/run new file mode 100755 index 0000000000..97f856223b --- /dev/null +++ b/hy/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal}.hy "${@}" diff --git a/hy/step0_repl.hy b/hy/step0_repl.hy new file mode 100755 index 0000000000..9596f056f6 --- /dev/null +++ b/hy/step0_repl.hy @@ -0,0 +1,20 @@ +#!/usr/bin/env hy + +(defn READ [str] + str) + +(defn EVAL [ast env] + ast) + +(defn PRINT [exp] + exp) + +(defn REP [str] + (PRINT (EVAL (READ str) {}))) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)))) From 58ff81103f4aacccd12ce0845adfeed5a321e065 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Sep 2017 22:44:41 -0500 Subject: [PATCH 0163/1998] Hy: step1 --- hy/printer.hy | 22 ++++++++++ hy/reader.hy | 92 ++++++++++++++++++++++++++++++++++++++++++ hy/step1_read_print.hy | 27 +++++++++++++ 3 files changed, 141 insertions(+) create mode 100644 hy/printer.hy create mode 100644 hy/reader.hy create mode 100755 hy/step1_read_print.hy diff --git a/hy/printer.hy b/hy/printer.hy new file mode 100644 index 0000000000..14c8c07ca7 --- /dev/null +++ b/hy/printer.hy @@ -0,0 +1,22 @@ +(import [hy.models [HyInteger :as Int HyKeyword :as Keyword + HyString :as Str HySymbol :as Sym HyDict :as Map]]) + + +(defn escape [s] + (-> (str s) (.replace "\\" "\\\\") + (.replace "\"" "\\\"") + (.replace "\n" "\\n"))) + +(defn pr-str [obj &optional [print-readably True]] + (setv _r print-readably + t (type obj)) + (Str + (if + (none? obj) "nil" + (= t bool) (if obj "true" "false") + (= t Keyword) (+ ":" (name obj)) + (= t Str) (if _r (+ "\"" (escape obj) "\"") obj) + (= t tuple) (+ "(" (.join " " (map (fn [x] (pr-str x _r)) obj)) ")") + (= t list) (+ "[" (.join " " (map (fn [x] (pr-str x _r)) obj)) "]") + (= t Map) (+ "{" (.join " " (map (fn [x] (pr-str x _r)) obj)) "}") + True (str obj)))) diff --git a/hy/reader.hy b/hy/reader.hy new file mode 100644 index 0000000000..55010dc5b5 --- /dev/null +++ b/hy/reader.hy @@ -0,0 +1,92 @@ +(import [hy.models [HyInteger :as Int HyKeyword :as Keyword + HyString :as Str HySymbol :as Sym HyDict :as Map]] + [re]) + +(defclass Blank [Exception]) + +(defclass Reader [] + (defn --init-- [self tokens &optional [position 0]] + (setv self.tokens tokens self.position position)) + (defn next [self] + (setv self.position (+ 1 self.position)) + (get self.tokens (- self.position 1))) + (defn peek [self] + (if (> (len self.tokens) self.position) + (get self.tokens self.position) + None))) + +(def tok-re (.compile re "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)")) +(def int-re (.compile re "-?[0-9]+$")) + +(defn tokenize [str] + (list-comp + t + (t (.findall re tok-re str)) + (!= (get t 0) ";"))) + +(defn unescape [s] + (-> s (.replace "\\\"" "\"") + (.replace "\\n" "\n") + (.replace "\\\\" "\\"))) + +(defn read-atom [rdr] + (setv token (.next rdr)) + (if + (.match re int-re token) (int token) + (= "\"" (get token 0)) (Str (unescape (cut token 1 -1))) + (= ":" (get token 0)) (Keyword token) + (= "nil" token) None + (= "true" token) True + (= "false" token) False + True (Sym token))) + +(defn read-seq [rdr &optional [start "("] [end ")"]] + (setv ast (list) + token (.next rdr)) + (if (!= token start) + (raise (Exception (+ "expected '" start "'"))) + (do + (setv token (.peek rdr)) + (while (!= token end) + (if (not token) (raise (Exception (+ "expected '" end + ", got EOF")))) + (.append ast (read-form rdr)) + (setv token (.peek rdr))) + (.next rdr) + ast))) + +(defn read-form [rdr] + (setv token (.peek rdr)) + (if + (= ";" (get token 0)) (.next rdr) + + (= "'" token) (do (.next rdr) + (tuple [(Sym "quote") (read-form rdr)])) + (= "`" token) (do (.next rdr) + (tuple [(Sym "quasiquote") (read-form rdr)])) + (= "~" token) (do (.next rdr) + (tuple [(Sym "unquote") (read-form rdr)])) + (= "~@" token) (do (.next rdr) + (tuple [(Sym "splice-unquote") + (read-form rdr)])) + (= "^" token) (do (.next rdr) + (setv meta (read-form rdr)) + (tuple [(Sym "with-meta") (read-form rdr) meta])) + (= "@" token) (do (.next rdr) + (tuple [(Sym "deref") (read-form rdr)])) + + (= ")" token) (raise (Exception "unexpected ')'")) + (= "(" token) (tuple (read-seq rdr "(" ")")) + + (= "]" token) (raise (Exception "unexpected ')'")) + (= "[" token) (read-seq rdr "[" "]") + + (= "}" token) (raise (Exception "unexpected '}'")) + (= "{" token) (Map (read-seq rdr "{" "}")) + + True (read-atom rdr))) + +(defn read-str [str] + (setv tokens (tokenize str)) + (if (= 0 (len tokens)) (raise (Blank "blank line"))) + (read-form (Reader tokens))) diff --git a/hy/step1_read_print.hy b/hy/step1_read_print.hy new file mode 100755 index 0000000000..dcd384214c --- /dev/null +++ b/hy/step1_read_print.hy @@ -0,0 +1,27 @@ +#!/usr/bin/env hy + +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) + +(defn READ [str] + (read-str str)) + +(defn EVAL [ast env] + ast) + +(defn PRINT [exp] + (pr-str exp True)) + +(defn REP [str] + (PRINT (EVAL (READ str) {}))) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From cadde2db981b3a691c74554c4d63b46b7e909de6 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Sep 2017 20:43:00 -0500 Subject: [PATCH 0164/1998] Hy: step2 --- hy/step2_eval.hy | 56 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100755 hy/step2_eval.hy diff --git a/hy/step2_eval.hy b/hy/step2_eval.hy new file mode 100755 index 0000000000..2b7fd9a431 --- /dev/null +++ b/hy/step2_eval.hy @@ -0,0 +1,56 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + (if + (symbol? ast) (if (.has_key env ast) (get env ast) + (raise (Exception (+ ast " not found")))) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (if + (empty? ast) ast + (do + (setv el (eval-ast ast env) + f (first el) + args (rest el)) + (apply f args))))) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl + +(def repl-env {'+ + + '- - + '* * + '/ (fn [a b] (int (/ a b)))}) + +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From 5d2813209a63aebecd4c71c4cf3818f0fb9c594b Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Sep 2017 21:21:41 -0500 Subject: [PATCH 0165/1998] Hy: step3 --- hy/env.hy | 19 +++++++++++++ hy/step3_env.hy | 74 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 93 insertions(+) create mode 100644 hy/env.hy create mode 100755 hy/step3_env.hy diff --git a/hy/env.hy b/hy/env.hy new file mode 100644 index 0000000000..1893aa440c --- /dev/null +++ b/hy/env.hy @@ -0,0 +1,19 @@ +(defn env-new [&optional [outer None] [binds None] [exprs None]] + {:outer outer}) + +(defn env-find [env k] + (if + (.has_key env k) env + (.has_key env ':outer) (env-find (get env ':outer) k) + True None)) + +(defn env-get [env k] + (setv e (env-find env k)) + (if-not e + (raise (Exception (+ "'" k "' not found")))) + (get e k)) + +(defn env-set [env k v] + (assoc env k v) + v) + diff --git a/hy/step3_env.hy b/hy/step3_env.hy new file mode 100755 index 0000000000..31393cef53 --- /dev/null +++ b/hy/step3_env.hy @@ -0,0 +1,74 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv let-env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set let-env b (EVAL e let-env))) + (EVAL a2 let-env)) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (rest el)) + (apply f args)))))) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl + +(def repl-env {'+ + + '- - + '* * + '/ (fn [a b] (int (/ a b)))}) + +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From 379c7998eac55e36be10a519628b69d0a540ffc2 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Sep 2017 22:24:58 -0500 Subject: [PATCH 0166/1998] Hy: step4 --- hy/core.hy | 31 +++++++++++++++ hy/env.hy | 16 +++++++- hy/step4_if_fn_do.hy | 95 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 140 insertions(+), 2 deletions(-) create mode 100644 hy/core.hy create mode 100755 hy/step4_if_fn_do.hy diff --git a/hy/core.hy b/hy/core.hy new file mode 100644 index 0000000000..7a98352fed --- /dev/null +++ b/hy/core.hy @@ -0,0 +1,31 @@ +(import [hy.models [HyString :as Str]]) +(import [printer [pr-str]]) + +(defn equal [a b] + (if (and (coll? a) (coll? b) (= (len a) (len b))) + (every? (fn [[a b]] (equal a b)) (zip a b)) + (= a b))) + +(def ns + {"=" equal + + "pr-str" (fn [&rest a] (Str (.join " " (map (fn [e] (pr-str e True)) a)))) + "str" (fn [&rest a] (Str (.join "" (map (fn [e] (pr-str e False)) a)))) + "prn" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e True)) a)))) + "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a)))) + + "<" < + "<=" <= + ">" > + ">=" >= + "+" + + "-" - + "*" * + "/" (fn [a b] (int (/ a b))) + + "list" (fn [&rest args] (tuple args)) + "list?" (fn [a] (instance? tuple a)) + + "empty?" empty? + "count" (fn [a] (if (none? a) 0 (len a))) + }) diff --git a/hy/env.hy b/hy/env.hy index 1893aa440c..eb6235146b 100644 --- a/hy/env.hy +++ b/hy/env.hy @@ -1,5 +1,17 @@ -(defn env-new [&optional [outer None] [binds None] [exprs None]] - {:outer outer}) +(import [hy.models [HySymbol :as Sym]]) + +(defn env-new [&optional [outer None] [binds []] [exprs []]] + (setv env {:outer outer}) + (while binds + (if + (= (Sym "&") (first binds)) + (do (assoc env (nth binds 1) (tuple exprs)) (break)) + + True + (do (assoc env (first binds) (first exprs)) + (setv binds (list (rest binds)) + exprs (list (rest exprs)))))) + env) (defn env-find [env k] (if diff --git a/hy/step4_if_fn_do.hy b/hy/step4_if_fn_do.hy new file mode 100755 index 0000000000..2c8db51871 --- /dev/null +++ b/hy/step4_if_fn_do.hy @@ -0,0 +1,95 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv let-env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set let-env b (EVAL e let-env))) + (EVAL a2 let-env)) + + (= (Sym "do") a0) + (last (eval-ast (list (rest ast)) env)) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (EVAL (nth ast 3) env) + None) + (EVAL a2 env))) + + (= (Sym "fn*") a0) + (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + ;;(print "f:" f "args:" args) + (apply f args)))))) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From 45f4d834a87d4b9b5c04f73211b6a6cfa82c4c41 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Sep 2017 22:52:52 -0500 Subject: [PATCH 0167/1998] Hy: step5 --- hy/step5_tco.hy | 109 +++++++++++++++++++++++++++++++++++++++++ hy/tests/step5_tco.mal | 15 ++++++ 2 files changed, 124 insertions(+) create mode 100755 hy/step5_tco.hy create mode 100644 hy/tests/step5_tco.mal diff --git a/hy/step5_tco.hy b/hy/step5_tco.hy new file mode 100755 index 0000000000..ebc58fa6b6 --- /dev/null +++ b/hy/step5_tco.hy @@ -0,0 +1,109 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) diff --git a/hy/tests/step5_tco.mal b/hy/tests/step5_tco.mal new file mode 100644 index 0000000000..d20df25db7 --- /dev/null +++ b/hy/tests/step5_tco.mal @@ -0,0 +1,15 @@ +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil From 5b86f08c037a729918a1e69b52e583ebded1033b Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Sep 2017 23:27:30 -0500 Subject: [PATCH 0168/1998] Hy: step6 --- hy/core.hy | 15 +++++- hy/env.hy | 6 +-- hy/mal_types.hy | 3 ++ hy/printer.hy | 3 +- hy/step6_file.hy | 116 +++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 137 insertions(+), 6 deletions(-) create mode 100644 hy/mal_types.hy create mode 100755 hy/step6_file.hy diff --git a/hy/core.hy b/hy/core.hy index 7a98352fed..5215add203 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -1,4 +1,6 @@ (import [hy.models [HyString :as Str]]) +(import [mal_types [Atom]]) +(import [reader [read-str]]) (import [printer [pr-str]]) (defn equal [a b] @@ -13,6 +15,8 @@ "str" (fn [&rest a] (Str (.join "" (map (fn [e] (pr-str e False)) a)))) "prn" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e True)) a)))) "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a)))) + "read-string" read-str + "slurp" (fn [a] (Str (-> a open .read))) "<" < "<=" <= @@ -23,9 +27,16 @@ "*" * "/" (fn [a b] (int (/ a b))) - "list" (fn [&rest args] (tuple args)) - "list?" (fn [a] (instance? tuple a)) + "list" (fn [&rest args] (tuple args)) + "list?" (fn [a] (instance? tuple a)) "empty?" empty? "count" (fn [a] (if (none? a) 0 (len a))) + + "atom" (fn [a] (Atom a)) + "atom?" (fn [a] (instance? Atom a)) + "deref" (fn [a] a.val) + "reset!" (fn [a b] (do (setv a.val b) b)) + "swap!" (fn [a f &rest args] (do (setv a.val (apply f (+ (, a.val) args))) + a.val)) }) diff --git a/hy/env.hy b/hy/env.hy index eb6235146b..02161704e4 100644 --- a/hy/env.hy +++ b/hy/env.hy @@ -15,9 +15,9 @@ (defn env-find [env k] (if - (.has_key env k) env - (.has_key env ':outer) (env-find (get env ':outer) k) - True None)) + (.has_key env k) env + (get env ':outer) (env-find (get env ':outer) k) + True None)) (defn env-get [env k] (setv e (env-find env k)) diff --git a/hy/mal_types.hy b/hy/mal_types.hy new file mode 100644 index 0000000000..b227e4321e --- /dev/null +++ b/hy/mal_types.hy @@ -0,0 +1,3 @@ +(defclass Atom [] + (defn --init-- [self val] (setv self.val val))) + diff --git a/hy/printer.hy b/hy/printer.hy index 14c8c07ca7..1e63484810 100644 --- a/hy/printer.hy +++ b/hy/printer.hy @@ -1,6 +1,6 @@ (import [hy.models [HyInteger :as Int HyKeyword :as Keyword HyString :as Str HySymbol :as Sym HyDict :as Map]]) - +(import [mal_types [Atom]]) (defn escape [s] (-> (str s) (.replace "\\" "\\\\") @@ -19,4 +19,5 @@ (= t tuple) (+ "(" (.join " " (map (fn [x] (pr-str x _r)) obj)) ")") (= t list) (+ "[" (.join " " (map (fn [x] (pr-str x _r)) obj)) "]") (= t Map) (+ "{" (.join " " (map (fn [x] (pr-str x _r)) obj)) "}") + (instance? Atom obj) (+ "(atom " (pr-str obj.val _r) ")") True (str obj)))) diff --git a/hy/step6_file.hy b/hy/step6_file.hy new file mode 100755 index 0000000000..735842cc5b --- /dev/null +++ b/hy/step6_file.hy @@ -0,0 +1,116 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(when (>= (len sys.argv) 2) + (REP (+ "(load-file \"" (get sys.argv 1) "\")")) + (sys.exit 0)) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From 4abefe454aee3276ef7775832370fd6d9d3bcc5b Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Sep 2017 23:49:32 -0500 Subject: [PATCH 0169/1998] Hy: step7 --- hy/core.hy | 12 +++- hy/step7_quote.hy | 140 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 149 insertions(+), 3 deletions(-) create mode 100755 hy/step7_quote.hy diff --git a/hy/core.hy b/hy/core.hy index 5215add203..599b8e7a50 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -5,8 +5,12 @@ (defn equal [a b] (if (and (coll? a) (coll? b) (= (len a) (len b))) - (every? (fn [[a b]] (equal a b)) (zip a b)) - (= a b))) + (every? (fn [[a b]] (equal a b)) (zip a b)) + + (= (type a) (type b)) + (= a b) + + False)) (def ns {"=" equal @@ -17,7 +21,7 @@ "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a)))) "read-string" read-str "slurp" (fn [a] (Str (-> a open .read))) - + "<" < "<=" <= ">" > @@ -30,6 +34,8 @@ "list" (fn [&rest args] (tuple args)) "list?" (fn [a] (instance? tuple a)) + "cons" (fn [a b] (tuple (chain [a] b))) + "concat" (fn [&rest a] (tuple (apply chain a))) "empty?" empty? "count" (fn [a] (if (none? a) 0 (len a))) diff --git a/hy/step7_quote.hy b/hy/step7_quote.hy new file mode 100755 index 0000000000..74150467f8 --- /dev/null +++ b/hy/step7_quote.hy @@ -0,0 +1,140 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn pair? [x] + (and (coll? x) (> (len x) 0))) + +(defn QUASIQUOTE [ast] + (if + (not (pair? ast)) + (tuple [(Sym "quote") ast]) + + (= (Sym "unquote") (first ast)) + (nth ast 1) + + (and (pair? (first ast)) + (= (Sym "splice-unquote") (first (first ast)))) + (tuple [(Sym "concat") (nth (first ast) 1) (QUASIQUOTE (tuple (rest ast)))]) + + True + (tuple [(Sym "cons") (QUASIQUOTE (first ast)) (QUASIQUOTE (tuple (rest ast)))]))) + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + (setv res a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") + +(when (>= (len sys.argv) 2) + (REP (+ "(load-file \"" (get sys.argv 1) "\")")) + (sys.exit 0)) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From 3cc7b877befb89f23fd3588c69cf989566c6b534 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 21:22:55 -0500 Subject: [PATCH 0170/1998] Hy: step8 --- hy/core.hy | 3 + hy/step8_macros.hy | 172 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 175 insertions(+) create mode 100755 hy/step8_macros.hy diff --git a/hy/core.hy b/hy/core.hy index 599b8e7a50..0406b8e03e 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -36,6 +36,9 @@ "cons" (fn [a b] (tuple (chain [a] b))) "concat" (fn [&rest a] (tuple (apply chain a))) + "nth" (fn [a b] (get a b)) + "first" (fn [a] (if (none? a) None (first a))) + "rest" (fn [a] (if (none? a) (,) (tuple (rest a)))) "empty?" empty? "count" (fn [a] (if (none? a) 0 (len a))) diff --git a/hy/step8_macros.hy b/hy/step8_macros.hy new file mode 100755 index 0000000000..5de0cc6254 --- /dev/null +++ b/hy/step8_macros.hy @@ -0,0 +1,172 @@ +#!/usr/bin/env hy + +(import [hy.models [HyDict :as Map HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set env-find]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn pair? [x] + (and (coll? x) (> (len x) 0))) + +(defn QUASIQUOTE [ast] + (if + (not (pair? ast)) + (tuple [(Sym "quote") ast]) + + (= (Sym "unquote") (first ast)) + (nth ast 1) + + (and (pair? (first ast)) + (= (Sym "splice-unquote") (first (first ast)))) + (tuple [(Sym "concat") (nth (first ast) 1) (QUASIQUOTE (tuple (rest ast)))]) + + True + (tuple [(Sym "cons") (QUASIQUOTE (first ast)) (QUASIQUOTE (tuple (rest ast)))]))) + +(defn macro? [ast env] + (when (and (coll? ast) + (symbol? (first ast)) + (env-find env (first ast))) + (setv mac (env-get env (first ast))) + (and (hasattr mac "macro") + mac.macro))) + +(defn macroexpand [ast env] + (while (macro? ast env) + (setv mac (env-get env (first ast)) + ast (apply mac (tuple (rest ast))))) + ast) + + + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + (setv res a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (setv res (env-set env a1 func))) + + (= (Sym "macroexpand") a0) + (setv res (macroexpand a1 env)) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") +(REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") +(REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") + + +(when (>= (len sys.argv) 2) + (REP (+ "(load-file \"" (get sys.argv 1) "\")")) + (sys.exit 0)) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From 081c322323f64e40335dda7aa9983f4dd8bfdd0d Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 22:35:00 -0500 Subject: [PATCH 0171/1998] Hy: use dict instead of HyDict --- hy/core.hy | 13 ++++++++++--- hy/printer.hy | 6 ++++-- hy/reader.hy | 4 ++-- hy/step2_eval.hy | 5 +++-- hy/step3_env.hy | 6 ++++-- hy/step4_if_fn_do.hy | 6 ++++-- hy/step5_tco.hy | 6 ++++-- hy/step6_file.hy | 6 ++++-- hy/step7_quote.hy | 8 +++++--- hy/step8_macros.hy | 8 +++++--- 10 files changed, 45 insertions(+), 23 deletions(-) diff --git a/hy/core.hy b/hy/core.hy index 0406b8e03e..1b6e5327c9 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -3,10 +3,16 @@ (import [reader [read-str]]) (import [printer [pr-str]]) +(defn sequential? [a] + (or (instance? tuple a) (instance? list a))) + (defn equal [a b] - (if (and (coll? a) (coll? b) (= (len a) (len b))) + (if (and (sequential? a) (sequential? b) (= (len a) (len b))) (every? (fn [[a b]] (equal a b)) (zip a b)) + (and (instance? dict a) (instance? dict b) (= (.keys a) (.keys b))) + (every? (fn [k] (and (equal (get a k) (get b k)))) a) + (= (type a) (type b)) (= a b) @@ -41,11 +47,12 @@ "rest" (fn [a] (if (none? a) (,) (tuple (rest a)))) "empty?" empty? "count" (fn [a] (if (none? a) 0 (len a))) + "apply" (fn [f &rest a] (apply f (+ (list (butlast a)) (list (last a))))) + "map" (fn [f a] (tuple (map f a))) "atom" (fn [a] (Atom a)) "atom?" (fn [a] (instance? Atom a)) "deref" (fn [a] a.val) "reset!" (fn [a b] (do (setv a.val b) b)) - "swap!" (fn [a f &rest args] (do (setv a.val (apply f (+ (, a.val) args))) - a.val)) + "swap!" (fn [a f &rest xs] (do (setv a.val (apply f (+ (, a.val) xs))) a.val)) }) diff --git a/hy/printer.hy b/hy/printer.hy index 1e63484810..55809fc195 100644 --- a/hy/printer.hy +++ b/hy/printer.hy @@ -1,5 +1,5 @@ (import [hy.models [HyInteger :as Int HyKeyword :as Keyword - HyString :as Str HySymbol :as Sym HyDict :as Map]]) + HyString :as Str HySymbol :as Sym]]) (import [mal_types [Atom]]) (defn escape [s] @@ -18,6 +18,8 @@ (= t Str) (if _r (+ "\"" (escape obj) "\"") obj) (= t tuple) (+ "(" (.join " " (map (fn [x] (pr-str x _r)) obj)) ")") (= t list) (+ "[" (.join " " (map (fn [x] (pr-str x _r)) obj)) "]") - (= t Map) (+ "{" (.join " " (map (fn [x] (pr-str x _r)) obj)) "}") + (= t dict) (+ "{" (.join " " (map (fn [k] (+ (pr-str k _r) " " + (pr-str (get obj k) _r))) + obj)) "}") (instance? Atom obj) (+ "(atom " (pr-str obj.val _r) ")") True (str obj)))) diff --git a/hy/reader.hy b/hy/reader.hy index 55010dc5b5..41abec29d3 100644 --- a/hy/reader.hy +++ b/hy/reader.hy @@ -1,5 +1,5 @@ (import [hy.models [HyInteger :as Int HyKeyword :as Keyword - HyString :as Str HySymbol :as Sym HyDict :as Map]] + HyString :as Str HySymbol :as Sym]] [re]) (defclass Blank [Exception]) @@ -82,7 +82,7 @@ (= "[" token) (read-seq rdr "[" "]") (= "}" token) (raise (Exception "unexpected '}'")) - (= "{" token) (Map (read-seq rdr "{" "}")) + (= "{" token) (dict (partition (read-seq rdr "{" "}") 2)) True (read-atom rdr))) diff --git a/hy/step2_eval.hy b/hy/step2_eval.hy index 2b7fd9a431..d6b407b52c 100755 --- a/hy/step2_eval.hy +++ b/hy/step2_eval.hy @@ -1,6 +1,5 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -14,7 +13,9 @@ (if (symbol? ast) (if (.has_key env ast) (get env ast) (raise (Exception (+ ast " not found")))) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) diff --git a/hy/step3_env.hy b/hy/step3_env.hy index 31393cef53..95dc3fbbb2 100755 --- a/hy/step3_env.hy +++ b/hy/step3_env.hy @@ -1,6 +1,6 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map HySymbol :as Sym]]) +(import [hy.models [HySymbol :as Sym]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -15,7 +15,9 @@ ;;(print "eval-ast:" ast (type ast)) (if (symbol? ast) (env-get env ast) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) diff --git a/hy/step4_if_fn_do.hy b/hy/step4_if_fn_do.hy index 2c8db51871..bf9c6ba737 100755 --- a/hy/step4_if_fn_do.hy +++ b/hy/step4_if_fn_do.hy @@ -1,6 +1,6 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map HySymbol :as Sym]]) +(import [hy.models [HySymbol :as Sym]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -16,7 +16,9 @@ ;;(print "eval-ast:" ast (type ast)) (if (symbol? ast) (env-get env ast) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) diff --git a/hy/step5_tco.hy b/hy/step5_tco.hy index ebc58fa6b6..6b4ee8fafa 100755 --- a/hy/step5_tco.hy +++ b/hy/step5_tco.hy @@ -1,6 +1,6 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map HySymbol :as Sym]]) +(import [hy.models [HySymbol :as Sym]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -16,7 +16,9 @@ ;;(print "eval-ast:" ast (type ast)) (if (symbol? ast) (env-get env ast) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) diff --git a/hy/step6_file.hy b/hy/step6_file.hy index 735842cc5b..680a347928 100755 --- a/hy/step6_file.hy +++ b/hy/step6_file.hy @@ -1,6 +1,6 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map HyString :as Str HySymbol :as Sym]]) +(import [hy.models [HyString :as Str HySymbol :as Sym]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -16,7 +16,9 @@ ;;(print "eval-ast:" ast (type ast)) (if (symbol? ast) (env-get env ast) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) diff --git a/hy/step7_quote.hy b/hy/step7_quote.hy index 74150467f8..17e6db7f1d 100755 --- a/hy/step7_quote.hy +++ b/hy/step7_quote.hy @@ -1,6 +1,6 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map HyString :as Str HySymbol :as Sym]]) +(import [hy.models [HyString :as Str HySymbol :as Sym]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -13,7 +13,7 @@ ;; eval (defn pair? [x] - (and (coll? x) (> (len x) 0))) + (and (core.sequential? x) (> (len x) 0))) (defn QUASIQUOTE [ast] (if @@ -34,7 +34,9 @@ ;;(print "eval-ast:" ast (type ast)) (if (symbol? ast) (env-get env ast) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) diff --git a/hy/step8_macros.hy b/hy/step8_macros.hy index 5de0cc6254..740c751b80 100755 --- a/hy/step8_macros.hy +++ b/hy/step8_macros.hy @@ -1,6 +1,6 @@ #!/usr/bin/env hy -(import [hy.models [HyDict :as Map HyString :as Str HySymbol :as Sym]]) +(import [hy.models [HyString :as Str HySymbol :as Sym]]) (import sys traceback) (import [reader [read-str Blank]]) (import [printer [pr-str]]) @@ -13,7 +13,7 @@ ;; eval (defn pair? [x] - (and (coll? x) (> (len x) 0))) + (and (core.sequential? x) (> (len x) 0))) (defn QUASIQUOTE [ast] (if @@ -50,7 +50,9 @@ ;;(print "eval-ast:" ast (type ast)) (if (symbol? ast) (env-get env ast) - (instance? Map ast) (Map (map (fn [x] (EVAL x env)) ast)) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) True ast)) From ef47406a9e47fe0a69f78083bc4d253963e434a0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 22:35:30 -0500 Subject: [PATCH 0172/1998] Hy: step9 --- hy/core.hy | 33 +++++++-- hy/mal_types.hy | 3 + hy/step9_try.hy | 188 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 219 insertions(+), 5 deletions(-) create mode 100755 hy/step9_try.hy diff --git a/hy/core.hy b/hy/core.hy index 1b6e5327c9..960f620240 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -1,5 +1,6 @@ -(import [hy.models [HyString :as Str]]) -(import [mal_types [Atom]]) +(import [hy.models [HyKeyword :as Keyword HyString :as Str HySymbol :as Sym]]) +(import [copy [copy]]) +(import [mal_types [MalException Atom]]) (import [reader [read-str]]) (import [printer [pr-str]]) @@ -19,7 +20,16 @@ False)) (def ns - {"=" equal + {"=" equal + "throw" (fn [a] (raise (MalException a))) + + "nil?" none? + "true?" (fn [a] (and (instance? bool a) (= a True))) + "false?" (fn [a] (and (instance? bool a) (= a False))) + "symbol" (fn [a] (Sym a)) + "symbol?" (fn [a] (instance? Sym a)) + "keyword" (fn [a] (Keyword (if (keyword? a) a (+ ":" a)))) + "keyword?" (fn [a] (keyword? a)) "pr-str" (fn [&rest a] (Str (.join " " (map (fn [e] (pr-str e True)) a)))) "str" (fn [&rest a] (Str (.join "" (map (fn [e] (pr-str e False)) a)))) @@ -37,9 +47,22 @@ "*" * "/" (fn [a b] (int (/ a b))) - "list" (fn [&rest args] (tuple args)) - "list?" (fn [a] (instance? tuple a)) + "list" (fn [&rest args] (tuple args)) + "list?" (fn [a] (instance? tuple a)) + "vector" (fn [&rest a] (list a)) + "vector?" (fn [a] (instance? list a)) + "hash-map" (fn [&rest a] (dict (partition a 2))) + "map?" (fn [a] (instance? dict a)) + "assoc" (fn [m &rest a] (setv m (copy m)) + (for [[k v] (partition a 2)] (assoc m k v)) m) + "dissoc" (fn [m &rest a] (setv m (copy m)) + (for [k a] (if (.has_key m k) (.pop m k))) m) + "get" (fn [m a] (if (and m (.has_key m a)) (get m a))) + "contains?" (fn [m a] (if (none? m) None (.has_key m a))) + "keys" (fn [m] (tuple (.keys m))) + "vals" (fn [m] (tuple (.values m))) + "sequential?" sequential? "cons" (fn [a b] (tuple (chain [a] b))) "concat" (fn [&rest a] (tuple (apply chain a))) "nth" (fn [a b] (get a b)) diff --git a/hy/mal_types.hy b/hy/mal_types.hy index b227e4321e..eb0515cef1 100644 --- a/hy/mal_types.hy +++ b/hy/mal_types.hy @@ -1,3 +1,6 @@ +(defclass MalException [Exception] + (defn --init-- [self val] (setv self.val val))) + (defclass Atom [] (defn --init-- [self val] (setv self.val val))) diff --git a/hy/step9_try.hy b/hy/step9_try.hy new file mode 100755 index 0000000000..2e2f4edd87 --- /dev/null +++ b/hy/step9_try.hy @@ -0,0 +1,188 @@ +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set env-find]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn pair? [x] + (and (core.sequential? x) (> (len x) 0))) + +(defn QUASIQUOTE [ast] + (if + (not (pair? ast)) + (tuple [(Sym "quote") ast]) + + (= (Sym "unquote") (first ast)) + (nth ast 1) + + (and (pair? (first ast)) + (= (Sym "splice-unquote") (first (first ast)))) + (tuple [(Sym "concat") (nth (first ast) 1) (QUASIQUOTE (tuple (rest ast)))]) + + True + (tuple [(Sym "cons") (QUASIQUOTE (first ast)) (QUASIQUOTE (tuple (rest ast)))]))) + +(defn macro? [ast env] + (when (and (coll? ast) + (symbol? (first ast)) + (env-find env (first ast))) + (setv mac (env-get env (first ast))) + (and (hasattr mac "macro") + mac.macro))) + +(defn macroexpand [ast env] + (while (macro? ast env) + (setv mac (env-get env (first ast)) + ast (apply mac (tuple (rest ast))))) + ast) + + + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + (setv res a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (setv res (env-set env a1 func))) + + (= (Sym "macroexpand") a0) + (setv res (macroexpand a1 env)) + + (= (Sym "try*") a0) + (setv res + (if (= (Sym "catch*") (nth a2 0)) + (try + (EVAL a1 env) + (except [e Exception] + (if (instance? MalException e) + (setv exc e.val) + (setv exc (Str (get e.args 0)))) + (EVAL (nth a2 2) (env-new env [(nth a2 1)] + [exc])))) + (EVAL a1 env))) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") +(REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") +(REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") + + +(when (>= (len sys.argv) 2) + (REP (+ "(load-file \"" (get sys.argv 1) "\")")) + (sys.exit 0)) + +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From f382a6122b5089db793638915f7402fc4102f8dc Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 23:15:51 -0500 Subject: [PATCH 0173/1998] Hy: stepA (except meta on collections) --- hy/core.hy | 14 +++- hy/mal_types.hy | 9 +++ hy/stepA_mal.hy | 191 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 213 insertions(+), 1 deletion(-) create mode 100755 hy/stepA_mal.hy diff --git a/hy/core.hy b/hy/core.hy index 960f620240..d4984a7e3d 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -1,6 +1,7 @@ (import [hy.models [HyKeyword :as Keyword HyString :as Str HySymbol :as Sym]]) (import [copy [copy]]) -(import [mal_types [MalException Atom]]) +(import [time [time]]) +(import [mal_types [MalException Atom clone]]) (import [reader [read-str]]) (import [printer [pr-str]]) @@ -26,6 +27,7 @@ "nil?" none? "true?" (fn [a] (and (instance? bool a) (= a True))) "false?" (fn [a] (and (instance? bool a) (= a False))) + "string?" (fn [a] (and (string? a) (not (keyword? a)))) "symbol" (fn [a] (Sym a)) "symbol?" (fn [a] (instance? Sym a)) "keyword" (fn [a] (Keyword (if (keyword? a) a (+ ":" a)))) @@ -36,6 +38,7 @@ "prn" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e True)) a)))) "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a)))) "read-string" read-str + "readline" (fn [a] (Str (raw_input a))) "slurp" (fn [a] (Str (-> a open .read))) "<" < @@ -46,6 +49,7 @@ "-" - "*" * "/" (fn [a b] (int (/ a b))) + "time-ms" (fn [] (int (* 1000 (time)))) "list" (fn [&rest args] (tuple args)) "list?" (fn [a] (instance? tuple a)) @@ -73,6 +77,14 @@ "apply" (fn [f &rest a] (apply f (+ (list (butlast a)) (list (last a))))) "map" (fn [f a] (tuple (map f a))) + "conj" (fn [a &rest xs] (if (instance? list a) (+ a (list xs)) + (tuple (+ (tuple (reversed xs)) a)))) + "seq" (fn [a] (if (or (none? a) (empty? a)) None + (string? a) (tuple (map Str a)) + (tuple a))) + + "meta" (fn [a] (if (hasattr a "meta") a.meta)) + "with-meta" (fn [a b] (setv a (clone a)) (setv a.meta b) a) "atom" (fn [a] (Atom a)) "atom?" (fn [a] (instance? Atom a)) "deref" (fn [a] a.val) diff --git a/hy/mal_types.hy b/hy/mal_types.hy index eb0515cef1..4a30e6fdbd 100644 --- a/hy/mal_types.hy +++ b/hy/mal_types.hy @@ -1,6 +1,15 @@ +(import [types :as pytypes]) + (defclass MalException [Exception] (defn --init-- [self val] (setv self.val val))) (defclass Atom [] (defn --init-- [self val] (setv self.val val))) +(defn clone [obj] + (if (= (type obj) pytypes.FunctionType) + (pytypes.FunctionType obj.__code__ obj.__globals__ + :name obj.__name__ + :argdefs obj.__defaults__ + :closure obj.__closure__) + obj)) diff --git a/hy/stepA_mal.hy b/hy/stepA_mal.hy new file mode 100755 index 0000000000..080e6b4f3d --- /dev/null +++ b/hy/stepA_mal.hy @@ -0,0 +1,191 @@ +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set env-find]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn pair? [x] + (and (core.sequential? x) (> (len x) 0))) + +(defn QUASIQUOTE [ast] + (if + (not (pair? ast)) + (tuple [(Sym "quote") ast]) + + (= (Sym "unquote") (first ast)) + (nth ast 1) + + (and (pair? (first ast)) + (= (Sym "splice-unquote") (first (first ast)))) + (tuple [(Sym "concat") (nth (first ast) 1) (QUASIQUOTE (tuple (rest ast)))]) + + True + (tuple [(Sym "cons") (QUASIQUOTE (first ast)) (QUASIQUOTE (tuple (rest ast)))]))) + +(defn macro? [ast env] + (when (and (coll? ast) + (symbol? (first ast)) + (env-find env (first ast))) + (setv mac (env-get env (first ast))) + (and (hasattr mac "macro") + mac.macro))) + +(defn macroexpand [ast env] + (while (macro? ast env) + (setv mac (env-get env (first ast)) + ast (apply mac (tuple (rest ast))))) + ast) + + + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [(EVAL k env) (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (setv res (eval-ast ast env)) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + (setv res a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (setv res (env-set env a1 func))) + + (= (Sym "macroexpand") a0) + (setv res (macroexpand a1 env)) + + (= (Sym "try*") a0) + (setv res + (if (= (Sym "catch*") (nth a2 0)) + (try + (EVAL a1 env) + (except [e Exception] + (if (instance? MalException e) + (setv exc e.val) + (setv exc (Str (get e.args 0)))) + (EVAL (nth a2 2) (env-new env [(nth a2 1)] + [exc])))) + (EVAL a1 env))) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) + +;; core.mal: defined using the language itself +(REP "(def! *host-language* \"Hy\")") +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") +(REP "(def! *gensym-counter* (atom 0))") +(REP "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))") +(REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))") + + +(when (>= (len sys.argv) 2) + (REP (+ "(load-file \"" (get sys.argv 1) "\")")) + (sys.exit 0)) + +(REP "(println (str \"Mal [\" *host-language* \"]\"))") +(while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) From e8f52c24f49d68a235d0a82f4df31f5562ed1274 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 23:32:15 -0500 Subject: [PATCH 0174/1998] Hy: sync indenting. Define entry with defmain. --- hy/Makefile | 21 ++++++ hy/step0_repl.hy | 14 ++-- hy/step1_read_print.hy | 21 +++--- hy/step2_eval.hy | 43 +++++++------ hy/step3_env.hy | 65 ++++++++++--------- hy/step4_if_fn_do.hy | 107 ++++++++++++++++--------------- hy/step5_tco.hy | 120 +++++++++++++++++----------------- hy/step6_file.hy | 130 +++++++++++++++++++------------------ hy/step7_quote.hy | 142 +++++++++++++++++++++-------------------- hy/step8_macros.hy | 44 +++++++------ hy/step9_try.hy | 46 ++++++------- hy/stepA_mal.hy | 48 +++++++------- 12 files changed, 429 insertions(+), 372 deletions(-) create mode 100644 hy/Makefile diff --git a/hy/Makefile b/hy/Makefile new file mode 100644 index 0000000000..2e6a5d7b64 --- /dev/null +++ b/hy/Makefile @@ -0,0 +1,21 @@ +SOURCES_BASE = mal_types.hy reader.hy printer.hy +SOURCES_LISP = env.hy core.hy stepA_mal.hy +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: mal.hy + +mal.hy: stepA_mal.hy + cp $< $@ + +clean: + rm -f mal.hy *.pyc + +#.PHONY: stats tests $(TESTS) +.PHONY: stats + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/hy/step0_repl.hy b/hy/step0_repl.hy index 9596f056f6..d651bbf0ef 100755 --- a/hy/step0_repl.hy +++ b/hy/step0_repl.hy @@ -12,9 +12,11 @@ (defn REP [str] (PRINT (EVAL (READ str) {}))) -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)))) +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break))))) diff --git a/hy/step1_read_print.hy b/hy/step1_read_print.hy index dcd384214c..179b09f884 100755 --- a/hy/step1_read_print.hy +++ b/hy/step1_read_print.hy @@ -16,12 +16,15 @@ (defn REP [str] (PRINT (EVAL (READ str) {}))) -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/hy/step2_eval.hy b/hy/step2_eval.hy index d6b407b52c..6eb4b0f324 100755 --- a/hy/step2_eval.hy +++ b/hy/step2_eval.hy @@ -22,22 +22,26 @@ (defn EVAL [ast env] (if (not (instance? tuple ast)) - (eval-ast ast env) + (eval-ast ast env) - (if - (empty? ast) ast - (do - (setv el (eval-ast ast env) - f (first el) - args (rest el)) - (apply f args))))) + ;; apply list + ;; indented to match later steps + (if + (empty? ast) + ast + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (rest el)) + (apply f args))))) ;; print (defn PRINT [exp] (pr-str exp True)) ;; repl - (def repl-env {'+ + '- - '* * @@ -46,12 +50,15 @@ (defn REP [str] (PRINT (EVAL (READ str) repl-env))) -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/hy/step3_env.hy b/hy/step3_env.hy index 95dc3fbbb2..2e46c3cfc3 100755 --- a/hy/step3_env.hy +++ b/hy/step3_env.hy @@ -25,38 +25,38 @@ (defn EVAL [ast env] ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) (if (not (instance? tuple ast)) - (eval-ast ast env) + (eval-ast ast env) - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast + ;; apply list + ;; indented to match later steps + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) - (= (Sym "let*") a0) - (do - (setv let-env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set let-env b (EVAL e let-env))) - (EVAL a2 let-env)) + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (EVAL a2 env)) - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (rest el)) - (apply f args)))))) + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (rest el)) + (apply f args)))))) ;; print (defn PRINT [exp] (pr-str exp True)) ;; repl - (def repl-env {'+ + '- - '* * @@ -65,12 +65,15 @@ (defn REP [str] (PRINT (EVAL (READ str) repl-env))) -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/hy/step4_if_fn_do.hy b/hy/step4_if_fn_do.hy index bf9c6ba737..0fd04c442b 100755 --- a/hy/step4_if_fn_do.hy +++ b/hy/step4_if_fn_do.hy @@ -26,49 +26,49 @@ (defn EVAL [ast env] ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv let-env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set let-env b (EVAL e let-env))) - (EVAL a2 let-env)) - - (= (Sym "do") a0) - (last (eval-ast (list (rest ast)) env)) - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (EVAL (nth ast 3) env) - None) - (EVAL a2 env))) - - (= (Sym "fn*") a0) - (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - ;;(print "f:" f "args:" args) - (apply f args)))))) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (EVAL a2 env)) + + (= (Sym "do") a0) + (last (eval-ast (list (rest ast)) env)) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (EVAL (nth ast 3) env) + None) + (EVAL a2 env))) + + (= (Sym "fn*") a0) + (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args)))))) ;; print (defn PRINT [exp] @@ -86,12 +86,15 @@ ;; core.mal: defined using the language itself (REP "(def! not (fn* [a] (if a false true)))") -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/hy/step5_tco.hy b/hy/step5_tco.hy index 6b4ee8fafa..8e6ec056c1 100755 --- a/hy/step5_tco.hy +++ b/hy/step5_tco.hy @@ -29,58 +29,59 @@ (while True (if (not (instance? tuple ast)) (setv res (eval-ast ast env)) - + ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply + ;; indented to match later steps (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) (continue)) ;; TCO - (setv res (apply f args))))))) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))) (break)) res) @@ -100,12 +101,15 @@ ;; core.mal: defined using the language itself (REP "(def! not (fn* [a] (if a false true)))") -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/hy/step6_file.hy b/hy/step6_file.hy index 680a347928..8bd4d696d0 100755 --- a/hy/step6_file.hy +++ b/hy/step6_file.hy @@ -29,58 +29,59 @@ (while True (if (not (instance? tuple ast)) (setv res (eval-ast ast env)) - + ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply + ;; indented to match later steps (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) (continue)) ;; TCO - (setv res (apply f args))))))) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))) (break)) res) @@ -97,22 +98,25 @@ (for [k core.ns] (env-set repl-env (Sym k) (get core.ns k))) (env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) +(env-set repl-env (Sym "*ARGV*") (, )) ;; core.mal: defined using the language itself (REP "(def! not (fn* [a] (if a false true)))") (REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") -(when (>= (len sys.argv) 2) - (REP (+ "(load-file \"" (get sys.argv 1) "\")")) - (sys.exit 0)) - -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))))) diff --git a/hy/step7_quote.hy b/hy/step7_quote.hy index 17e6db7f1d..532e970c53 100755 --- a/hy/step7_quote.hy +++ b/hy/step7_quote.hy @@ -47,64 +47,65 @@ (while True (if (not (instance? tuple ast)) (setv res (eval-ast ast env)) - + ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - (setv res a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) + ;; indented to match later steps (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + (setv res ast) + + (= (Sym "def!") a0) + (setv res (env-set env a1 (EVAL a2 env))) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + (setv res a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) (continue)) ;; TCO - (setv res (apply f args))))))) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + (setv res None)) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1 + res func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (setv res (apply f args))))))) (break)) res) @@ -121,22 +122,25 @@ (for [k core.ns] (env-set repl-env (Sym k) (get core.ns k))) (env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) +(env-set repl-env (Sym "*ARGV*") (, )) ;; core.mal: defined using the language itself (REP "(def! not (fn* [a] (if a false true)))") (REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") -(when (>= (len sys.argv) 2) - (REP (+ "(load-file \"" (get sys.argv 1) "\")")) - (sys.exit 0)) - -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))))) diff --git a/hy/step8_macros.hy b/hy/step8_macros.hy index 740c751b80..d0574ccda9 100755 --- a/hy/step8_macros.hy +++ b/hy/step8_macros.hy @@ -63,7 +63,7 @@ (while True (if (not (instance? tuple ast)) (setv res (eval-ast ast env)) - + ;; apply list (do (setv ast (macroexpand ast env)) @@ -75,10 +75,10 @@ (if (none? a0) (setv res ast) - + (= (Sym "def!") a0) (setv res (env-set env a1 (EVAL a2 env))) - + (= (Sym "let*") a0) (do (setv env (env-new env)) @@ -92,7 +92,7 @@ (= (Sym "quasiquote") a0) (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - + (= (Sym "defmacro!") a0) (do (setv func (EVAL a2 env) func.macro True) @@ -105,7 +105,7 @@ (do (eval-ast (list (butlast (rest ast))) env) (setv ast (last ast)) (continue)) ;; TCO - + (= (Sym "if") a0) (do (setv cond (EVAL a1 env)) @@ -115,7 +115,7 @@ (do (setv ast (nth ast 3)) (continue)) ;; TCO (setv res None)) (do (setv ast a2) (continue)))) ;; TCO - + (= (Sym "fn*") a0) (setv func (fn [&rest args] (EVAL a2 (env-new env a1 (or args [])))) @@ -150,7 +150,7 @@ (for [k core.ns] (env-set repl-env (Sym k) (get core.ns k))) (env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) +(env-set repl-env (Sym "*ARGV*") (, )) ;; core.mal: defined using the language itself (REP "(def! not (fn* [a] (if a false true)))") @@ -158,17 +158,19 @@ (REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") (REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") - -(when (>= (len sys.argv) 2) - (REP (+ "(load-file \"" (get sys.argv 1) "\")")) - (sys.exit 0)) - -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))))) diff --git a/hy/step9_try.hy b/hy/step9_try.hy index 2e2f4edd87..ae5f936f93 100755 --- a/hy/step9_try.hy +++ b/hy/step9_try.hy @@ -64,7 +64,7 @@ (while True (if (not (instance? tuple ast)) (setv res (eval-ast ast env)) - + ;; apply list (do (setv ast (macroexpand ast env)) @@ -76,10 +76,10 @@ (if (none? a0) (setv res ast) - + (= (Sym "def!") a0) (setv res (env-set env a1 (EVAL a2 env))) - + (= (Sym "let*") a0) (do (setv env (env-new env)) @@ -93,7 +93,7 @@ (= (Sym "quasiquote") a0) (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - + (= (Sym "defmacro!") a0) (do (setv func (EVAL a2 env) func.macro True) @@ -114,12 +114,12 @@ (EVAL (nth a2 2) (env-new env [(nth a2 1)] [exc])))) (EVAL a1 env))) - + (= (Sym "do") a0) (do (eval-ast (list (butlast (rest ast))) env) (setv ast (last ast)) (continue)) ;; TCO - + (= (Sym "if") a0) (do (setv cond (EVAL a1 env)) @@ -129,7 +129,7 @@ (do (setv ast (nth ast 3)) (continue)) ;; TCO (setv res None)) (do (setv ast a2) (continue)))) ;; TCO - + (= (Sym "fn*") a0) (setv func (fn [&rest args] (EVAL a2 (env-new env a1 (or args [])))) @@ -164,7 +164,7 @@ (for [k core.ns] (env-set repl-env (Sym k) (get core.ns k))) (env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) +(env-set repl-env (Sym "*ARGV*") (, )) ;; core.mal: defined using the language itself (REP "(def! not (fn* [a] (if a false true)))") @@ -172,17 +172,19 @@ (REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") (REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") - -(when (>= (len sys.argv) 2) - (REP (+ "(load-file \"" (get sys.argv 1) "\")")) - (sys.exit 0)) - -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))))) diff --git a/hy/stepA_mal.hy b/hy/stepA_mal.hy index 080e6b4f3d..5d9a9fb4fe 100755 --- a/hy/stepA_mal.hy +++ b/hy/stepA_mal.hy @@ -64,7 +64,7 @@ (while True (if (not (instance? tuple ast)) (setv res (eval-ast ast env)) - + ;; apply list (do (setv ast (macroexpand ast env)) @@ -76,10 +76,10 @@ (if (none? a0) (setv res ast) - + (= (Sym "def!") a0) (setv res (env-set env a1 (EVAL a2 env))) - + (= (Sym "let*") a0) (do (setv env (env-new env)) @@ -93,7 +93,7 @@ (= (Sym "quasiquote") a0) (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - + (= (Sym "defmacro!") a0) (do (setv func (EVAL a2 env) func.macro True) @@ -114,12 +114,12 @@ (EVAL (nth a2 2) (env-new env [(nth a2 1)] [exc])))) (EVAL a1 env))) - + (= (Sym "do") a0) (do (eval-ast (list (butlast (rest ast))) env) (setv ast (last ast)) (continue)) ;; TCO - + (= (Sym "if") a0) (do (setv cond (EVAL a1 env)) @@ -129,7 +129,7 @@ (do (setv ast (nth ast 3)) (continue)) ;; TCO (setv res None)) (do (setv ast a2) (continue)))) ;; TCO - + (= (Sym "fn*") a0) (setv func (fn [&rest args] (EVAL a2 (env-new env a1 (or args [])))) @@ -164,7 +164,7 @@ (for [k core.ns] (env-set repl-env (Sym k) (get core.ns k))) (env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv))))) +(env-set repl-env (Sym "*ARGV*") (, )) ;; core.mal: defined using the language itself (REP "(def! *host-language* \"Hy\")") @@ -174,18 +174,20 @@ (REP "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))") (REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))") - -(when (>= (len sys.argv) 2) - (REP (+ "(load-file \"" (get sys.argv 1) "\")")) - (sys.exit 0)) - -(REP "(println (str \"Mal [\" *host-language* \"]\"))") -(while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception (.exc_info sys))))))) +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (REP "(println (str \"Mal [\" *host-language* \"]\"))") + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))))) From bf794d15b5a3029bfdc75b6fb16a2f2043b19345 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 23:44:33 -0500 Subject: [PATCH 0175/1998] Hy: add Dockerfile --- hy/Dockerfile | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 hy/Dockerfile diff --git a/hy/Dockerfile b/hy/Dockerfile new file mode 100644 index 0000000000..c984900b5f --- /dev/null +++ b/hy/Dockerfile @@ -0,0 +1,28 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Hy +RUN apt-get -y install python-pip +RUN pip install hy && \ + mkdir /.cache && \ + chmod uog+rwx /.cache From 1872f735e440719c6134d16557592ba0f0fe79d5 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Sep 2017 23:58:14 -0500 Subject: [PATCH 0176/1998] Hy: simplify main eval loop. Dockerfile cleanup. --- hy/Dockerfile | 4 +- hy/step2_eval.hy | 26 ++++---- hy/step3_env.hy | 48 +++++++------- hy/step4_if_fn_do.hy | 90 ++++++++++++------------- hy/step5_tco.hy | 110 +++++++++++++++--------------- hy/step6_file.hy | 108 +++++++++++++++--------------- hy/step7_quote.hy | 120 +++++++++++++++++---------------- hy/step8_macros.hy | 144 ++++++++++++++++++++-------------------- hy/step9_try.hy | 155 ++++++++++++++++++++++--------------------- hy/stepA_mal.hy | 155 ++++++++++++++++++++++--------------------- 10 files changed, 485 insertions(+), 475 deletions(-) diff --git a/hy/Dockerfile b/hy/Dockerfile index c984900b5f..4d977ee8b2 100644 --- a/hy/Dockerfile +++ b/hy/Dockerfile @@ -22,7 +22,7 @@ WORKDIR /mal ########################################################## # Hy -RUN apt-get -y install python-pip -RUN pip install hy && \ +RUN apt-get -y install python-pip && \ + pip install hy && \ mkdir /.cache && \ chmod uog+rwx /.cache diff --git a/hy/step2_eval.hy b/hy/step2_eval.hy index 6eb4b0f324..7d8b8fe7a0 100755 --- a/hy/step2_eval.hy +++ b/hy/step2_eval.hy @@ -21,21 +21,21 @@ True ast)) (defn EVAL [ast env] - (if (not (instance? tuple ast)) - (eval-ast ast env) + ;; indented to match later steps + (if (not (instance? tuple ast)) + (eval-ast ast env) - ;; apply list - ;; indented to match later steps - (if - (empty? ast) - ast + ;; apply list + (if + (empty? ast) + ast - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (rest el)) - (apply f args))))) + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args))))) ;; print (defn PRINT [exp] diff --git a/hy/step3_env.hy b/hy/step3_env.hy index 2e46c3cfc3..94c9fad380 100755 --- a/hy/step3_env.hy +++ b/hy/step3_env.hy @@ -23,34 +23,34 @@ True ast)) (defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - (if (not (instance? tuple ast)) - (eval-ast ast env) + ;;(print "EVAL:" ast (type ast)) + ;; indented to match later steps + (if (not (instance? tuple ast)) + (eval-ast ast env) - ;; apply list - ;; indented to match later steps - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (EVAL a2 env)) + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (EVAL a2 env)) - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (rest el)) - (apply f args)))))) + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args)))))) ;; print (defn PRINT [exp] diff --git a/hy/step4_if_fn_do.hy b/hy/step4_if_fn_do.hy index 0fd04c442b..b75831d08d 100755 --- a/hy/step4_if_fn_do.hy +++ b/hy/step4_if_fn_do.hy @@ -24,51 +24,51 @@ True ast)) (defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (EVAL a2 env)) - - (= (Sym "do") a0) - (last (eval-ast (list (rest ast)) env)) - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (EVAL (nth ast 3) env) - None) - (EVAL a2 env))) - - (= (Sym "fn*") a0) - (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (apply f args)))))) + ;;(print "EVAL:" ast (type ast)) + ;; indented to match later steps + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (EVAL a2 env)) + + (= (Sym "do") a0) + (last (eval-ast (list (rest ast)) env)) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (EVAL (nth ast 3) env) + None) + (EVAL a2 env))) + + (= (Sym "fn*") a0) + (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args)))))) ;; print (defn PRINT [exp] diff --git a/hy/step5_tco.hy b/hy/step5_tco.hy index 8e6ec056c1..55e07d67aa 100755 --- a/hy/step5_tco.hy +++ b/hy/step5_tco.hy @@ -24,64 +24,66 @@ True ast)) (defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + ;;(print "EVAL:" ast (type ast)) + ;; indented to match later steps (setv res None) (while True - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - ;; apply list - ;; indented to match later steps - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) (continue)) ;; TCO - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (setv res (apply f args))))))) + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))) (break)) res) diff --git a/hy/step6_file.hy b/hy/step6_file.hy index 8bd4d696d0..e74ec2dc17 100755 --- a/hy/step6_file.hy +++ b/hy/step6_file.hy @@ -25,63 +25,65 @@ (defn EVAL [ast env] ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + ;; indented to match later steps (setv res None) (while True - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - ;; apply list - ;; indented to match later steps - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) (continue)) ;; TCO - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (setv res (apply f args))))))) + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))) (break)) res) diff --git a/hy/step7_quote.hy b/hy/step7_quote.hy index 532e970c53..c78259a730 100755 --- a/hy/step7_quote.hy +++ b/hy/step7_quote.hy @@ -43,69 +43,71 @@ (defn EVAL [ast env] ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + ;; indented to match later steps (setv res None) (while True - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - ;; apply list - ;; indented to match later steps - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - (setv res a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) (continue)) ;; TCO - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (setv res (apply f args))))))) + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))) (break)) res) diff --git a/hy/step8_macros.hy b/hy/step8_macros.hy index d0574ccda9..68832345d4 100755 --- a/hy/step8_macros.hy +++ b/hy/step8_macros.hy @@ -61,79 +61,81 @@ ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) (setv res None) (while True - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - ;; apply list - (do - (setv ast (macroexpand ast env)) - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - (setv res a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "defmacro!") a0) - (do (setv func (EVAL a2 env) - func.macro True) - (setv res (env-set env a1 func))) - - (= (Sym "macroexpand") a0) - (setv res (macroexpand a1 env)) - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) (continue)) ;; TCO - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (setv res (apply f args))))))))) + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (env-set env a1 func)) + + (= (Sym "macroexpand") a0) + (macroexpand a1 env) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))))) (break)) res) diff --git a/hy/step9_try.hy b/hy/step9_try.hy index ae5f936f93..b1a7d50ced 100755 --- a/hy/step9_try.hy +++ b/hy/step9_try.hy @@ -62,48 +62,48 @@ ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) (setv res None) (while True - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - ;; apply list - (do - (setv ast (macroexpand ast env)) - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - (setv res a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "defmacro!") a0) - (do (setv func (EVAL a2 env) - func.macro True) - (setv res (env-set env a1 func))) - - (= (Sym "macroexpand") a0) - (setv res (macroexpand a1 env)) - - (= (Sym "try*") a0) - (setv res + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (env-set env a1 func)) + + (= (Sym "macroexpand") a0) + (macroexpand a1 env) + + (= (Sym "try*") a0) (if (= (Sym "catch*") (nth a2 0)) (try (EVAL a1 env) @@ -113,41 +113,42 @@ (setv exc (Str (get e.args 0)))) (EVAL (nth a2 2) (env-new env [(nth a2 1)] [exc])))) - (EVAL a1 env))) - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (setv res (apply f args))))))))) + (EVAL a1 env)) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))))) (break)) res) diff --git a/hy/stepA_mal.hy b/hy/stepA_mal.hy index 5d9a9fb4fe..67c9943417 100755 --- a/hy/stepA_mal.hy +++ b/hy/stepA_mal.hy @@ -62,48 +62,48 @@ ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) (setv res None) (while True - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - ;; apply list - (do - (setv ast (macroexpand ast env)) - (if (not (instance? tuple ast)) - (setv res (eval-ast ast env)) - - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - (setv res ast) - - (= (Sym "def!") a0) - (setv res (env-set env a1 (EVAL a2 env))) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - (setv res a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "defmacro!") a0) - (do (setv func (EVAL a2 env) - func.macro True) - (setv res (env-set env a1 func))) - - (= (Sym "macroexpand") a0) - (setv res (macroexpand a1 env)) - - (= (Sym "try*") a0) - (setv res + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (env-set env a1 func)) + + (= (Sym "macroexpand") a0) + (macroexpand a1 env) + + (= (Sym "try*") a0) (if (= (Sym "catch*") (nth a2 0)) (try (EVAL a1 env) @@ -113,41 +113,42 @@ (setv exc (Str (get e.args 0)))) (EVAL (nth a2 2) (env-new env [(nth a2 1)] [exc])))) - (EVAL a1 env))) - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - (setv res None)) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1 - res func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (setv res (apply f args))))))))) + (EVAL a1 env)) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))))) (break)) res) From ccab8f5907bd80cf484687f9bd0849643267d00a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 22 Sep 2017 12:16:54 -0500 Subject: [PATCH 0177/1998] Hy: add to README and travis. --- .travis.yml | 1 + README.md | 12 +++++++++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 45fc93f27a..b021b3158d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -38,6 +38,7 @@ matrix: - {env: IMPL=haxe haxe_MODE=python, services: [docker]} - {env: IMPL=haxe haxe_MODE=cpp, services: [docker]} - {env: IMPL=haxe haxe_MODE=js, services: [docker]} + - {env: IMPL=hy, services: [docker]} - {env: IMPL=io, services: [docker]} - {env: IMPL=java, services: [docker]} - {env: IMPL=js, services: [docker]} diff --git a/README.md b/README.md index 48505bbca1..ed48a798a7 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 69 languages: +Mal is implemented in 70 languages: * Ada * GNU awk @@ -36,6 +36,7 @@ Mal is implemented in 69 languages: * GNU Smalltalk * Haskell * Haxe (Neko, Python, C++ and JavaScript) +* Hy * Io * Java * JavaScript ([Online Demo](http://kanaka.github.io/mal)) @@ -501,6 +502,15 @@ make all-js node ./stepX_YYY.js ``` +### Hy + +The Hy implementation of mal has been tested with Hy 0.13.0. + +``` +cd hy +./stepX_YYY.hy +``` + ### Io *The Io implementation was created by [Dov Murik](https://github.com/dubek)* From 21986733a1ae07ec11f74ef6e4b1a4dbbf682de1 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Tue, 12 Sep 2017 20:51:40 +0000 Subject: [PATCH 0178/1998] Yorick implementation --- Makefile | 3 +- yorick/Dockerfile | 26 +++ yorick/Makefile | 24 +++ yorick/core.i | 343 ++++++++++++++++++++++++++++++++++++++ yorick/env.i | 44 +++++ yorick/hash.i | 79 +++++++++ yorick/printer.i | 50 ++++++ yorick/reader.i | 155 +++++++++++++++++ yorick/run | 3 + yorick/step0_repl.i | 33 ++++ yorick/step1_read_print.i | 43 +++++ yorick/step2_eval.i | 96 +++++++++++ yorick/step3_env.i | 113 +++++++++++++ yorick/step4_if_fn_do.i | 155 +++++++++++++++++ yorick/step5_tco.i | 162 ++++++++++++++++++ yorick/step6_file.i | 190 +++++++++++++++++++++ yorick/step7_quote.i | 215 ++++++++++++++++++++++++ yorick/step8_macros.i | 251 ++++++++++++++++++++++++++++ yorick/step9_try.i | 265 +++++++++++++++++++++++++++++ yorick/stepA_mal.i | 270 ++++++++++++++++++++++++++++++ yorick/types.i | 166 ++++++++++++++++++ 21 files changed, 2685 insertions(+), 1 deletion(-) create mode 100644 yorick/Dockerfile create mode 100644 yorick/Makefile create mode 100644 yorick/core.i create mode 100644 yorick/env.i create mode 100644 yorick/hash.i create mode 100644 yorick/printer.i create mode 100644 yorick/reader.i create mode 100755 yorick/run create mode 100644 yorick/step0_repl.i create mode 100644 yorick/step1_read_print.i create mode 100644 yorick/step2_eval.i create mode 100644 yorick/step3_env.i create mode 100644 yorick/step4_if_fn_do.i create mode 100644 yorick/step5_tco.i create mode 100644 yorick/step6_file.i create mode 100644 yorick/step7_quote.i create mode 100644 yorick/step8_macros.i create mode 100644 yorick/step9_try.i create mode 100644 yorick/stepA_mal.i create mode 100644 yorick/types.i diff --git a/Makefile b/Makefile index 100e2f9086..dbd80c7216 100644 --- a/Makefile +++ b/Makefile @@ -83,7 +83,7 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d haxe hy io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ - ts vb vhdl vimscript livescript elm + ts vb vhdl vimscript yorick livescript elm EXTENSION = .mal @@ -238,6 +238,7 @@ ts_STEP_TO_PROG = ts/$($(1)).js vb_STEP_TO_PROG = vb/$($(1)).exe vhdl_STEP_TO_PROG = vhdl/$($(1)) vimscript_STEP_TO_PROG = vimscript/$($(1)).vim +yorick_STEP_TO_PROG = yorick/$($(1)).i guile_STEP_TO_PROG = guile/$($(1)).scm livescript_STEP_TO_PROG = livescript/$($(1)).js elm_STEP_TO_PROG = elm/$($(1)).js diff --git a/yorick/Dockerfile b/yorick/Dockerfile new file mode 100644 index 0000000000..8a3f0037f3 --- /dev/null +++ b/yorick/Dockerfile @@ -0,0 +1,26 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install yorick yorick-yeti yorick-yeti-regex + +ENV HOME /mal diff --git a/yorick/Makefile b/yorick/Makefile new file mode 100644 index 0000000000..ccc3d68740 --- /dev/null +++ b/yorick/Makefile @@ -0,0 +1,24 @@ +SOURCES_BASE = hash.i types.i reader.i printer.i +SOURCES_LISP = env.i core.i stepA_mal.i +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +.PHONY: all dist clean stats stats-lisp + +all: dist + +dist: mal + +mal: $(SOURCES) + echo "#!/usr/bin/yorick -batch" > $@ + cat $+ | grep -v "^require," >> $@ + chmod +x $@ + +clean: + rm -f mal + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/yorick/core.i b/yorick/core.i new file mode 100644 index 0000000000..167f388c81 --- /dev/null +++ b/yorick/core.i @@ -0,0 +1,343 @@ +require, "types.i" + +func mal_equal(a) { return new_boolean(equal(*a(1), *a(2))); } +func mal_throw(a) { return MalError(obj=a(1)); } + +func mal_nil_q(a) { return new_boolean(structof(*a(1)) == MalNil); } +func mal_true_q(a) { return new_boolean(structof(*a(1)) == MalTrue); } +func mal_false_q(a) { return new_boolean(structof(*a(1)) == MalFalse); } +func mal_string_q(a) { return new_boolean(structof(*a(1)) == MalString); } +func mal_symbol(a) { return MalSymbol(val=a(1)->val); } +func mal_symbol_q(a) { return new_boolean(structof(*a(1)) == MalSymbol); } +func mal_keyword(a) { return MalKeyword(val=a(1)->val); } +func mal_keyword_q(a) { return new_boolean(structof(*a(1)) == MalKeyword); } + +func string_helper(a, delimiter, readable) +{ + res = "" + for (i = 1; i <= numberof(a); ++i) { + if (i > 1) res += delimiter + res += pr_str(*a(i), readable) + } + return res +} + +func mal_pr_str(a) { return MalString(val=string_helper(a, " ", 1)); } +func mal_str(a) { return MalString(val=string_helper(a, "", 0)); } +func mal_prn(a) { write, format="%s\n", string_helper(a, " ", 1); return MAL_NIL; } +func mal_println(a) { write, format="%s\n", string_helper(a, " ", 0); return MAL_NIL; } +func mal_read_string(a) { return read_str(a(1)->val); } + +func mal_readline(a) +{ + extern stdin_file + write, format="%s", a(1)->val + line = rdline(stdin_file, prompt="") + return line ? MalString(val=line) : MAL_NIL +} + +func mal_slurp(a) +{ + f = open(a(1)->val) + lines = rdfile(f) + close, f + s = "" + for (i = 1; i <= numberof(lines); ++i) { + s += (lines(i) + "\n") + } + return MalString(val=s) +} + +func mal_lt(a) { return new_boolean(a(1)->val < a(2)->val); } +func mal_lte(a) { return new_boolean(a(1)->val <= a(2)->val); } +func mal_gt(a) { return new_boolean(a(1)->val > a(2)->val); } +func mal_gte(a) { return new_boolean(a(1)->val >= a(2)->val); } + +func mal_add(a) { return MalNumber(val=(a(1)->val + a(2)->val)); } +func mal_sub(a) { return MalNumber(val=(a(1)->val - a(2)->val)); } +func mal_mul(a) { return MalNumber(val=(a(1)->val * a(2)->val)); } +func mal_div(a) { return MalNumber(val=(a(1)->val / a(2)->val)); } + +func mal_time_ms(a) +{ + elapsed = array(double, 3) + timer, elapsed + return MalNumber(val=floor(elapsed(3) * 1000)) +} + +func mal_list(a) { return MalList(val=&a); } +func mal_list_q(a) { return new_boolean(structof(*a(1)) == MalList); } +func mal_vector(a) { return MalVector(val=&a); } +func mal_vector_q(a) { return new_boolean(structof(*a(1)) == MalVector); } +func mal_hash_map(a) { return array_to_hashmap(a); } +func mal_map_q(a) { return new_boolean(structof(*a(1)) == MalHashmap); } + +func mal_assoc(a) { + h = *(a(1)->val) + k1 = *h.keys + v1 = *h.vals + new_h = Hash(keys=&k1, vals=&v1) + for (i = 2; i <= numberof(a); i += 2) { + hash_set, new_h, hashmap_obj_to_key(*a(i)), *a(i + 1) + } + return MalHashmap(val=&new_h); +} + +func mal_dissoc(a) { + h = *(a(1)->val) + k1 = *h.keys + v1 = *h.vals + new_h = Hash(keys=&k1, vals=&v1) + for (i = 2; i <= numberof(a); ++i) { + hash_delete, new_h, hashmap_obj_to_key(*a(i)) + } + return MalHashmap(val=&new_h); +} + +func mal_get(a) { + if (structof(*a(1)) == MalNil) return MAL_NIL + h = *(a(1)->val) + key_obj = *a(2) + val = hash_get(h, hashmap_obj_to_key(key_obj)) + return is_void(val) ? MAL_NIL : val +} + +func mal_contains_q(a) { + if (structof(*a(1)) == MalNil) return MAL_FALSE + h = *(a(1)->val) + key_obj = *a(2) + return hash_has_key(h, hashmap_obj_to_key(key_obj)) ? MAL_TRUE : MAL_FALSE +} + +func mal_keys(a) { + keys_strs = *(a(1)->val->keys) + if (numberof(keys_strs) == 0) return MalList(val=&[]) + res = array(pointer, numberof(keys_strs)) + for (i = 1; i <= numberof(keys_strs); ++i) { + res(i) = &hashmap_key_to_obj(keys_strs(i)) + } + return MalList(val=&res); +} + +func mal_vals(a) { return MalList(val=a(1)->val->vals); } + +func mal_sequential_q(a) { return new_boolean(structof(*a(1)) == MalList || structof(*a(1)) == MalVector); } + +func mal_cons(a) +{ + a2_len = count(*a(2)) + seq = array(pointer, a2_len + 1) + seq(1) = a(1) + if (a2_len > 0) { + seq(2:) = *(a(2)->val) + } + return MalList(val=&seq) +} + +func mal_concat(a) +{ + seq = [] + for (i = 1; i <= numberof(a); ++i) { + grow, seq, *(a(i)->val) + } + return MalList(val=&seq) +} + +func mal_nth(a) +{ + index = a(2)->val + if (index >= count(*a(1))) return MalError(message="nth: index out of range") + return *((*(a(1)->val))(index + 1)) +} + +func mal_first(a) +{ + if (structof(*a(1)) == MalNil || count(*a(1)) == 0) return MAL_NIL + return *((*(a(1)->val))(1)) +} + +func mal_rest(a) +{ + if (structof(*a(1)) == MalNil) return MalList(val=&[]) + return rest(*a(1)) +} + +func mal_empty_q(a) { return new_boolean((structof(*a(1)) == MalNil ? 1 : count(*a(1)) == 0)); } +func mal_count(a) { return MalNumber(val=(structof(*a(1)) == MalNil ? 0 : count(*a(1)))); } + +func call_func(fn, args) +{ + if (structof(fn) == MalNativeFunction) { + return call_core_fn(fn.val, args) + } else if (structof(fn) == MalFunction) { + fn_env = env_new(fn.env, binds=*fn.binds, exprs=args) + return EVAL(*fn.ast, fn_env) + } else { + return MalError(message="Unknown function type") + } +} + +func mal_apply(a) { + mid_args = numberof(a) > 2 ? a(2:-1) : [] + return call_func(*a(1), grow(mid_args, *(a(0)->val))) +} + +func mal_map(a) { + fn = *a(1) + seq = *(a(2)->val) + if (numberof(seq) == 0) return MalList(val=&[]) + new_seq = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + new_val = call_func(fn, [seq(i)]) + if (structof(new_val) == MalError) return new_val + new_seq(i) = &new_val + } + return MalList(val=&new_seq) +} + +func mal_conj(a) +{ + obj = *a(1) + type = structof(obj) + if (type == MalList) { + res = obj + for (i = 2; i <= numberof(a); ++i) { + res = mal_cons([a(i), &res]) + } + return res + } else if (type == MalVector) { + seq = *obj.val + grow, seq, a(2:) + return MalVector(val=&seq) + } else { + return MalError(message="conj requires list or vector") + } +} + +func mal_seq(a) +{ + obj = *a(1) + type = structof(obj) + if (type == MalString) { + len = strlen(obj.val) + if (len == 0) return MAL_NIL + seq = array(pointer, len) + for (i = 1; i <= len; ++i) { + seq(i) = &MalString(val=strpart(obj.val, i:i)) + } + return MalList(val=&seq) + } else if (type == MalList) { + return count(obj) == 0 ? MAL_NIL : obj + } else if (type == MalVector) { + return count(obj) == 0 ? MAL_NIL : MalList(val=obj.val) + } else if (type == MalNil) { + return MAL_NIL + } else { + return MalError(message="seq requires string or list or vector or nil") + } +} + +func mal_meta(a) +{ + meta_obj = *(a(1)->meta) + return is_void(meta_obj) ? MAL_NIL : meta_obj +} + +func mal_with_meta(a) +{ + new_obj = *a(1) + new_obj.meta = a(2) + return new_obj +} + +func mal_atom(a) { return MalAtom(val=&MalAtomVal(val=a(1))); } +func mal_atom_q(a) { return new_boolean(structof(*a(1)) == MalAtom); } +func mal_deref(a) { return *(a(1)->val->val); } +func mal_reset_bang(a) { a(1)->val->val = a(2); return *(a(1)->val->val); } +func mal_swap_bang(a) +{ + old_val = mal_deref([a(1)]) + args = array(pointer, numberof(a) - 1) + args(1) = &old_val + if (numberof(a) > 2) args(2:) = a(3:) + new_val = call_func(*a(2), args) + if (structof(new_val) == MalError) return new_val + return mal_reset_bang([a(1), &new_val]) +} + +func mal_eval(a) { return EVAL(*a(1), repl_env); } + +core_ns = h_new() + +h_set, core_ns, "=", mal_equal +h_set, core_ns, "throw", mal_throw + +h_set, core_ns, "nil?", mal_nil_q +h_set, core_ns, "true?", mal_true_q +h_set, core_ns, "false?", mal_false_q +h_set, core_ns, "string?", mal_string_q +h_set, core_ns, "symbol", mal_symbol +h_set, core_ns, "symbol?", mal_symbol_q +h_set, core_ns, "keyword", mal_keyword +h_set, core_ns, "keyword?", mal_keyword_q + +h_set, core_ns, "pr-str", mal_pr_str +h_set, core_ns, "str", mal_str +h_set, core_ns, "prn", mal_prn +h_set, core_ns, "println", mal_println +h_set, core_ns, "read-string", mal_read_string +h_set, core_ns, "readline", mal_readline +h_set, core_ns, "slurp", mal_slurp + +h_set, core_ns, "<", mal_lt +h_set, core_ns, "<=", mal_lte +h_set, core_ns, ">", mal_gt +h_set, core_ns, ">=", mal_gte +h_set, core_ns, "+", mal_add +h_set, core_ns, "-", mal_sub +h_set, core_ns, "*", mal_mul +h_set, core_ns, "/", mal_div +h_set, core_ns, "time-ms", mal_time_ms + +h_set, core_ns, "list", mal_list +h_set, core_ns, "list?", mal_list_q +h_set, core_ns, "vector", mal_vector +h_set, core_ns, "vector?", mal_vector_q +h_set, core_ns, "hash-map", mal_hash_map +h_set, core_ns, "map?", mal_map_q +h_set, core_ns, "assoc", mal_assoc +h_set, core_ns, "dissoc", mal_dissoc +h_set, core_ns, "get", mal_get +h_set, core_ns, "contains?", mal_contains_q +h_set, core_ns, "keys", mal_keys +h_set, core_ns, "vals", mal_vals + +h_set, core_ns, "sequential?", mal_sequential_q +h_set, core_ns, "cons", mal_cons +h_set, core_ns, "concat", mal_concat +h_set, core_ns, "nth", mal_nth +h_set, core_ns, "first", mal_first +h_set, core_ns, "rest", mal_rest +h_set, core_ns, "empty?", mal_empty_q +h_set, core_ns, "count", mal_count +h_set, core_ns, "apply", mal_apply +h_set, core_ns, "map", mal_map + +h_set, core_ns, "conj", mal_conj +h_set, core_ns, "seq", mal_seq + +h_set, core_ns, "meta", mal_meta +h_set, core_ns, "with-meta", mal_with_meta +h_set, core_ns, "atom", mal_atom +h_set, core_ns, "atom?", mal_atom_q +h_set, core_ns, "deref", mal_deref +h_set, core_ns, "reset!", mal_reset_bang +h_set, core_ns, "swap!", mal_swap_bang + +h_set, core_ns, "eval", mal_eval + +func call_core_fn(name, args_list) +{ + f = h_get(core_ns, name) + return f(args_list) +} diff --git a/yorick/env.i b/yorick/env.i new file mode 100644 index 0000000000..d1e8a9cdc0 --- /dev/null +++ b/yorick/env.i @@ -0,0 +1,44 @@ +require, "hash.i" +require, "types.i" + +struct Env { + pointer outer + Hash data +} + +func env_new(outer_ptr, binds=, exprs=) +{ + env = Env(outer=outer_ptr, data=hash_new()) + for (i = 1; i <= numberof(binds); ++i) { + if (binds(i)->val == "&") { + rest_args = numberof(exprs) >= i ? exprs(i:) : [] + env_set, env, binds(i + 1)->val, MalList(val=&rest_args) + break + } else { + env_set, env, binds(i)->val, *exprs(i) + } + } + return env +} + +func env_find(env, key) +{ + if (hash_has_key(env.data, key)) return env + if (is_void(*env.outer)) return nil + return env_find(*env.outer, key) +} + +func env_get(env, key) +{ + found_env = env_find(env, key) + if (is_void(found_env)) return MalError(message=("'" + key + "' not found")) + return hash_get(found_env.data, key) +} + +func env_set(&env, key, val) +{ + d = env.data + hash_set, d, key, val + env.data = d + return val +} diff --git a/yorick/hash.i b/yorick/hash.i new file mode 100644 index 0000000000..250e4c72dc --- /dev/null +++ b/yorick/hash.i @@ -0,0 +1,79 @@ +// Implement our old naive O(n) map because Yeti's hash table (h_new()) cannot +// be used inside arrays and structs (we can't get a pointer to hash table). +// This prevents saving pointer to environment in MalFunction for example. + +struct Hash { + pointer keys + pointer vals +} + +func hash_new(void) +{ + return Hash(keys=&[], vals=&[]) +} + +func hash_get(h, key) +{ + for (i = 1; i <= numberof(*h.keys); ++i) { + if ((*h.keys)(i) == key) return *((*h.vals)(i)) + } + return nil +} + +func hash_has_key(h, key) +{ + for (i = 1; i <= numberof(*h.keys); ++i) { + if ((*h.keys)(i) == key) return 1 + } + return 0 +} + +func hash_set(&h, key, val) +{ + if (is_void(*h.keys)) { + h.keys = &[key] + h.vals = &[&val] + return + } + for (i = 1; i <= numberof(*h.keys); ++i) { + if ((*h.keys)(i) == key) { + (*h.vals)(i) = &val + return + } + } + tmp = *h.keys + grow, tmp, [key] + h.keys = &tmp + tmp = *h.vals + grow, tmp, [&val] + h.vals = &tmp +} + +func hash_delete(&h, key) +{ + if (is_void(*h.keys) || numberof(*h.keys) == 0) return + k = *h.keys + v = *h.vals + if (numberof(k) == 1) { + if (k(1) == key) { + h.keys = &[] + h.vals = &[] + return + } + } + for (i = 1; i <= numberof(k); ++i) { + if (k(i) == key) { + if (i == 1) { + h.keys = &(k(i+1:)) + h.vals = &(v(i+1:)) + } else if (i == numberof(k)) { + h.keys = &(k(1:i-1)) + h.vals = &(v(1:i-1)) + } else { + h.keys = &grow(k(1:i-1), k(i+1:)) + h.vals = &grow(v(1:i-1), v(i+1:)) + } + return + } + } +} diff --git a/yorick/printer.i b/yorick/printer.i new file mode 100644 index 0000000000..acefd17c26 --- /dev/null +++ b/yorick/printer.i @@ -0,0 +1,50 @@ +require, "types.i" + +func format_seq(val, start_char, end_char, readable) +{ + seq = *val + res = "" + for (i = 1; i <= numberof(seq); ++i) { + if (i > 1) res += " " + res += pr_str(*seq(i), readable) + } + return start_char + res + end_char +} + +func format_hashmap(h, readable) +{ + res = "" + for (i = 1; i <= numberof(*h.keys); ++i) { + if (i > 1) res += " " + key = hashmap_key_to_obj((*h.keys)(i)) + res += pr_str(key, readable) + " " + pr_str(*((*h.vals)(i)), readable) + } + return "{" + res + "}" +} + +func escape(s) +{ + s1 = streplaceall(s, "\\", "\\\\") + s2 = streplaceall(s1, "\"", "\\\"") + s3 = streplaceall(s2, "\n", "\\n") + return "\"" + s3 + "\"" +} + +func pr_str(ast, readable) +{ + type = structof(ast) + if (type == MalNil) return "nil" + else if (type == MalTrue) return "true" + else if (type == MalFalse) return "false" + else if (type == MalNumber) return totxt(ast.val) + else if (type == MalSymbol) return ast.val + else if (type == MalString) return readable ? escape(ast.val) : ast.val + else if (type == MalKeyword) return ":" + ast.val + else if (type == MalList) return format_seq(ast.val, "(", ")", readable) + else if (type == MalVector) return format_seq(ast.val, "[", "]", readable) + else if (type == MalHashmap) return format_hashmap(*ast.val, readable) + else if (type == MalAtom) return "(atom " + pr_str(*(ast.val->val), readable) + ")" + else if (type == MalNativeFunction) return "#" + else if (type == MalFunction) return "#" + else MalError(message=("Unknown type " + totxt(type))) +} diff --git a/yorick/reader.i b/yorick/reader.i new file mode 100644 index 0000000000..3b7e90f09b --- /dev/null +++ b/yorick/reader.i @@ -0,0 +1,155 @@ +#include "yeti_regex.i" +require, "types.i" + +TOKENIZER_REGEXP = regcomp("[[:space:],]*(~@|[][{}()'`~@]|\"([\\].|[^\\\"])*\"|;.*|[^][[:space:]{}()'\"`~@,;]*)", newline=1) + +func tokenize(str) +{ + match0 = "" + match1 = "" + pos = 1 + tokens = [] + while (1) { + m = regmatch(TOKENIZER_REGEXP, str, match0, match1, start=pos, indices=1) + if (m == 0) break + b = match1(1) + e = match1(2) - 1 + if (e < b) { + pos = match1(2) + 1 + continue + } + token = strpart(str, b:e) + pos = match1(2) + if (strpart(token, 1:1) == ";") continue + grow, tokens, [token] + } + return tokens +} + +struct Reader { + pointer tokens + int pos +} + +func reader_peek(rdr) +{ + if (rdr.pos > numberof(*rdr.tokens)) return string(0) + return (*rdr.tokens)(rdr.pos) +} + +func reader_next(rdr) +{ + token = reader_peek(rdr) + rdr.pos += 1 + return token +} + +NUMBER_REGEXP = regcomp("^-?[0-9]+$") + +func unescape(s) +{ + s1 = strpart(s, 2:-1) // remove surrounding quotes + s2 = streplaceall(s1, "\\n", "\n") + s3 = streplaceall(s2, "\\\"", "\"") + return streplaceall(s3, "\\\\", "\\") +} + +func read_atom(rdr) +{ + token = reader_next(rdr) + if (token == "nil") return MAL_NIL + else if (token == "true") return MAL_TRUE + else if (token == "false") return MAL_FALSE + else if (regmatch(NUMBER_REGEXP, token)) return MalNumber(val=tonum(token)) + else if (strpart(token, 1:1) == "\"") return MalString(val=unescape(token)) + else if (strpart(token, 1:1) == ":") return MalKeyword(val=strpart(token, 2:)) + else return MalSymbol(val=token) +} + +func read_seq(rdr, start_char, end_char) +{ + token = reader_next(rdr) + if (token != start_char) { + return MalError(message=("expected '" + start_char + "'")) + } + + elements = [] + token = reader_peek(rdr) + while (token != end_char) { + if (token == string(0)) { + return MalError(message=("expected '" + end_char + "'")) + } + e = read_form(rdr) + if (structof(e) == MalError) return e + grow, elements, [&e] + token = reader_peek(rdr) + } + token = reader_next(rdr) + return elements +} + +func read_list(rdr) +{ + seq = read_seq(rdr, "(", ")") + if (structof(seq) == MalError) return seq + return MalList(val=&seq) +} + +func read_vector(rdr) +{ + seq = read_seq(rdr, "[", "]") + if (structof(seq) == MalError) return seq + return MalVector(val=&seq) +} + +func read_hashmap(rdr) +{ + seq = read_seq(rdr, "{", "}") + if (structof(seq) == MalError) return seq + return array_to_hashmap(seq) +} + +func reader_macro(rdr, symbol_name) +{ + shortcut = reader_next(rdr) + form = read_form(rdr) + if (structof(form) == MalError) return form + seq = [&MalSymbol(val=symbol_name), &form] + return MalList(val=&seq) +} + +func reader_with_meta_macro(rdr) +{ + shortcut = reader_next(rdr) + meta = read_form(rdr) + if (structof(meta) == MalError) return meta + form = read_form(rdr) + if (structof(form) == MalError) return form + seq = [&MalSymbol(val="with-meta"), &form, &meta] + return MalList(val=&seq) +} + +func read_form(rdr) +{ + token = reader_peek(rdr) + if (token == "'") return reader_macro(rdr, "quote") + else if (token == "`") return reader_macro(rdr, "quasiquote") + else if (token == "~") return reader_macro(rdr, "unquote") + else if (token == "~@") return reader_macro(rdr, "splice-unquote") + else if (token == "@") return reader_macro(rdr, "deref") + else if (token == "^") return reader_with_meta_macro(rdr) + else if (token == "(") return read_list(rdr) + else if (token == ")") return MalError(message="unexpected ')'") + else if (token == "[") return read_vector(rdr) + else if (token == "]") return MalError(message="unexpected ']'") + else if (token == "{") return read_hashmap(rdr) + else if (token == "}") return MalError(message="unexpected '}'") + else return read_atom(rdr) +} + +func read_str(str) +{ + tokens = tokenize(str) + rdr = Reader(tokens=&tokens, pos=1) + return read_form(rdr) +} diff --git a/yorick/run b/yorick/run new file mode 100755 index 0000000000..c54589bb04 --- /dev/null +++ b/yorick/run @@ -0,0 +1,3 @@ +#!/bin/bash +export YORICK_MAL_PATH="$(dirname $0)" +exec yorick -batch "$YORICK_MAL_PATH/${STEP:-stepA_mal}.i" "${@}" diff --git a/yorick/step0_repl.i b/yorick/step0_repl.i new file mode 100644 index 0000000000..6a7fa25016 --- /dev/null +++ b/yorick/step0_repl.i @@ -0,0 +1,33 @@ +func READ(str) +{ + return str +} + +func EVAL(exp, env) +{ + return exp +} + +func PRINT(exp) +{ + return exp +} + +func REP(str) +{ + return PRINT(EVAL(READ(str), "")) +} + +func main(void) +{ + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) write, format="%s\n", REP(line) + } + write, "" +} + +main; diff --git a/yorick/step1_read_print.i b/yorick/step1_read_print.i new file mode 100644 index 0000000000..8a97cb8cf1 --- /dev/null +++ b/yorick/step1_read_print.i @@ -0,0 +1,43 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" + +func READ(str) +{ + return read_str(str) +} + +func EVAL(exp, env) +{ + if (structof(exp) == MalError) return exp + return exp +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func REP(str) +{ + return PRINT(EVAL(READ(str), "")) +} + +func main(void) +{ + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step2_eval.i b/yorick/step2_eval.i new file mode 100644 index 0000000000..2e59df84ca --- /dev/null +++ b/yorick/step2_eval.i @@ -0,0 +1,96 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + val = h_get(env, ast.val) + if (is_void(val)) return MalError(message=("'" + ast.val + "' not found")) + return val + } else if (type == MalList) { + seq = *(ast.val) + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + if (numberof(*ast.val) == 0) return ast + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = h_new() + h_set, repl_env, "+", MalNativeFunction(val="+") + h_set, repl_env, "-", MalNativeFunction(val="-") + h_set, repl_env, "*", MalNativeFunction(val="*") + h_set, repl_env, "/", MalNativeFunction(val="/") + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step3_env.i b/yorick/step3_env.i new file mode 100644 index 0000000000..4cb21e5ff6 --- /dev/null +++ b/yorick/step3_env.i @@ -0,0 +1,113 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + return EVAL(*lst(3), let_env) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = env_new(pointer(0)) + env_set, repl_env, "+", MalNativeFunction(val="+") + env_set, repl_env, "-", MalNativeFunction(val="-") + env_set, repl_env, "*", MalNativeFunction(val="*") + env_set, repl_env, "/", MalNativeFunction(val="/") + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step4_if_fn_do.i b/yorick/step4_if_fn_do.i new file mode 100644 index 0000000000..34308be913 --- /dev/null +++ b/yorick/step4_if_fn_do.i @@ -0,0 +1,155 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + return EVAL(*lst(3), let_env) + } else if (a1 == "do") { + ret = nil + for (i = 2; i <= numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + return ret + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + return EVAL(*lst(4), env) + } else { + return MAL_NIL + } + } else { + return EVAL(*lst(3), env) + } + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + return EVAL(*fn.ast, fn_env) + } else { + return MalError(message="Unknown function type") + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step5_tco.i b/yorick/step5_tco.i new file mode 100644 index 0000000000..4005b03123 --- /dev/null +++ b/yorick/step5_tco.i @@ -0,0 +1,162 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step6_file.i b/yorick/step6_file.i new file mode 100644 index 0000000000..70dfe901fc --- /dev/null +++ b/yorick/step6_file.i @@ -0,0 +1,190 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step7_quote.i b/yorick/step7_quote.i new file mode 100644 index 0000000000..bf9cbd1aad --- /dev/null +++ b/yorick/step7_quote.i @@ -0,0 +1,215 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func is_pair(ast) +{ + type = structof(ast) + return ((type == MalList) || (type == MalVector)) && count(ast) > 0 +} + +func quasiquote(ast) +{ + if (!is_pair(ast)) return MalList(val=&[&MalSymbol(val="quote"), &ast]) + lst = *ast.val + ast1 = *lst(1) + if (structof(ast1) == MalSymbol && ast1.val == "unquote") return *lst(2) + if (is_pair(ast1)) { + ast11 = *((*ast1.val)(1)) + if (structof(ast11) == MalSymbol && ast11.val == "splice-unquote") { + return MalList(val=&[&MalSymbol(val="concat"), (*ast1.val)(2), &quasiquote(rest(ast))]) + } + } + return MalList(val=&[&MalSymbol(val="cons"), &quasiquote(ast1), &quasiquote(rest(ast))]) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step8_macros.i b/yorick/step8_macros.i new file mode 100644 index 0000000000..c5c5fb840f --- /dev/null +++ b/yorick/step8_macros.i @@ -0,0 +1,251 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func is_pair(ast) +{ + type = structof(ast) + return ((type == MalList) || (type == MalVector)) && count(ast) > 0 +} + +func quasiquote(ast) +{ + if (!is_pair(ast)) return MalList(val=&[&MalSymbol(val="quote"), &ast]) + lst = *ast.val + ast1 = *lst(1) + if (structof(ast1) == MalSymbol && ast1.val == "unquote") return *lst(2) + if (is_pair(ast1)) { + ast11 = *((*ast1.val)(1)) + if (structof(ast11) == MalSymbol && ast11.val == "splice-unquote") { + return MalList(val=&[&MalSymbol(val="concat"), (*ast1.val)(2), &quasiquote(rest(ast))]) + } + } + return MalList(val=&[&MalSymbol(val="cons"), &quasiquote(ast1), &quasiquote(rest(ast))]) +} + +func is_macro_call(ast, env) +{ + if (structof(ast) != MalList) return 0 + if (count(ast) == 0) return 0 + a1 = *((*ast.val)(1)) + if (structof(a1) != MalSymbol) return 0 + var_name = a1.val + found_env = env_find(env, var_name) + if (is_void(found_env)) return 0 + obj = env_get(env, var_name) + return is_macro(obj) +} + +func macroexpand(ast, env) +{ + while (is_macro_call(ast, env)) { + macro_name = (*ast.val)(1)->val + macro_obj = env_get(env, macro_name) + macro_args = *rest(ast).val + fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) + ast = EVAL(*macro_obj.ast, fn_env) + } + return ast +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "defmacro!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + new_value.macro = 1 + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "macroexpand") { + return macroexpand(*lst(2), env) + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env + RE, "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env + RE, "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/step9_try.i b/yorick/step9_try.i new file mode 100644 index 0000000000..a4434974ea --- /dev/null +++ b/yorick/step9_try.i @@ -0,0 +1,265 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func is_pair(ast) +{ + type = structof(ast) + return ((type == MalList) || (type == MalVector)) && count(ast) > 0 +} + +func quasiquote(ast) +{ + if (!is_pair(ast)) return MalList(val=&[&MalSymbol(val="quote"), &ast]) + lst = *ast.val + ast1 = *lst(1) + if (structof(ast1) == MalSymbol && ast1.val == "unquote") return *lst(2) + if (is_pair(ast1)) { + ast11 = *((*ast1.val)(1)) + if (structof(ast11) == MalSymbol && ast11.val == "splice-unquote") { + return MalList(val=&[&MalSymbol(val="concat"), (*ast1.val)(2), &quasiquote(rest(ast))]) + } + } + return MalList(val=&[&MalSymbol(val="cons"), &quasiquote(ast1), &quasiquote(rest(ast))]) +} + +func is_macro_call(ast, env) +{ + if (structof(ast) != MalList) return 0 + if (count(ast) == 0) return 0 + a1 = *((*ast.val)(1)) + if (structof(a1) != MalSymbol) return 0 + var_name = a1.val + found_env = env_find(env, var_name) + if (is_void(found_env)) return 0 + obj = env_get(env, var_name) + return is_macro(obj) +} + +func macroexpand(ast, env) +{ + while (is_macro_call(ast, env)) { + macro_name = (*ast.val)(1)->val + macro_obj = env_get(env, macro_name) + macro_args = *rest(ast).val + fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) + ast = EVAL(*macro_obj.ast, fn_env) + } + return ast +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "defmacro!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + new_value.macro = 1 + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "macroexpand") { + return macroexpand(*lst(2), env) + } else if (a1 == "try*") { + ret = EVAL(*lst(2), env) + if (structof(ret) == MalError) { + exc = *ret.obj + if (is_void(exc)) { + exc = MalString(val=ret.message) + } + catch_lst = *(lst(3)->val) + catch_env = env_new(&env) + env_set, catch_env, catch_lst(2)->val, exc + return EVAL(*catch_lst(3), catch_env) + } else { + return ret + } + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env + RE, "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env + RE, "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/stepA_mal.i b/yorick/stepA_mal.i new file mode 100644 index 0000000000..53829636dc --- /dev/null +++ b/yorick/stepA_mal.i @@ -0,0 +1,270 @@ +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func is_pair(ast) +{ + type = structof(ast) + return ((type == MalList) || (type == MalVector)) && count(ast) > 0 +} + +func quasiquote(ast) +{ + if (!is_pair(ast)) return MalList(val=&[&MalSymbol(val="quote"), &ast]) + lst = *ast.val + ast1 = *lst(1) + if (structof(ast1) == MalSymbol && ast1.val == "unquote") return *lst(2) + if (is_pair(ast1)) { + ast11 = *((*ast1.val)(1)) + if (structof(ast11) == MalSymbol && ast11.val == "splice-unquote") { + return MalList(val=&[&MalSymbol(val="concat"), (*ast1.val)(2), &quasiquote(rest(ast))]) + } + } + return MalList(val=&[&MalSymbol(val="cons"), &quasiquote(ast1), &quasiquote(rest(ast))]) +} + +func is_macro_call(ast, env) +{ + if (structof(ast) != MalList) return 0 + if (count(ast) == 0) return 0 + a1 = *((*ast.val)(1)) + if (structof(a1) != MalSymbol) return 0 + var_name = a1.val + found_env = env_find(env, var_name) + if (is_void(found_env)) return 0 + obj = env_get(env, var_name) + return is_macro(obj) +} + +func macroexpand(ast, env) +{ + while (is_macro_call(ast, env)) { + macro_name = (*ast.val)(1)->val + macro_obj = env_get(env, macro_name) + macro_args = *rest(ast).val + fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) + ast = EVAL(*macro_obj.ast, fn_env) + } + return ast +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_key = EVAL(hashmap_key_to_obj((*h.keys)(i)), env) + if (structof(new_key) == MalError) return new_key + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, hashmap_obj_to_key(new_key), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "defmacro!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + new_value.macro = 1 + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "macroexpand") { + return macroexpand(*lst(2), env) + } else if (a1 == "try*") { + ret = EVAL(*lst(2), env) + if (structof(ret) == MalError) { + exc = *ret.obj + if (is_void(exc)) { + exc = MalString(val=ret.message) + } + catch_lst = *(lst(3)->val) + catch_env = env_new(&env) + env_set, catch_env, catch_lst(2)->val, exc + return EVAL(*catch_lst(3), catch_env) + } else { + return ret + } + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil +stdin_file = open("/dev/stdin", "r") + +func main(void) +{ + extern repl_env + extern stdin_file + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! *host-language* \"yorick\")", repl_env + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env + RE, "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env + RE, "(def! *gensym-counter* (atom 0))", repl_env + RE, "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))", repl_env + RE, "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + RE, "(println (str \"Mal [\" *host-language* \"]\"))", repl_env + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/yorick/types.i b/yorick/types.i new file mode 100644 index 0000000000..a171e31dd1 --- /dev/null +++ b/yorick/types.i @@ -0,0 +1,166 @@ +require, "hash.i" + +struct MalError { + string message + pointer obj +} + +struct MalNil { + int val +} + +MAL_NIL = MalNil() + +struct MalTrue { + int val +} + +MAL_TRUE = MalTrue() + +struct MalFalse { + int val +} + +MAL_FALSE = MalFalse() + +struct MalNumber { + int val +} + +func new_number(s) +{ + return MalNumber(val=atoi(s)) +} + +struct MalSymbol { + string val + pointer meta +} + +struct MalString { + string val + pointer meta +} + +struct MalKeyword { + string val + pointer meta +} + +struct MalList { + pointer val + pointer meta +} + +struct MalVector { + pointer val + pointer meta +} + +func count(obj) { return numberof(*obj.val); } + +func rest(obj) { + seq = count(obj) <= 1 ? [] : ((*obj.val)(2:)) + return MalList(val=&seq) +} + +struct MalHashmap { + pointer val + pointer meta +} + +func hashmap_obj_to_key(obj) { + if (structof(obj) == MalString) return "str:" + obj.val + else if (structof(obj) == MalSymbol) return "sym:" + obj.val + else if (structof(obj) == MalKeyword) return "key:" + obj.val + else error, "Unsupported obj type for hash key" +} + +func hashmap_key_to_obj(key) { + type_str = strpart(key, 1:4) + val = strpart(key, 5:) + if (type_str == "str:") return MalString(val=val) + else if (type_str == "sym:") return MalSymbol(val=val) + else if (type_str == "key:") return MalKeyword(val=val) + else error, "Unsupported key type" +} + +func array_to_hashmap(seq) +{ + if (numberof(seq) % 2 != 0) return MalError(message="Odd number of elements in hashmap") + h = hash_new() + for (i = 1; i <= numberof(seq); i += 2) { + hash_set, h, hashmap_obj_to_key(*seq(i)), *seq(i + 1) + } + return MalHashmap(val=&h) +} + +struct MalNativeFunction { + string val + pointer meta +} + +struct MalFunction { + pointer env + pointer binds + pointer ast + int macro + pointer meta +} + +struct MalAtom { + pointer val + pointer meta +} + +func is_macro(obj) { return (structof(obj) == MalFunction && obj.macro); } + +struct MalAtomVal { + pointer val +} + +func new_boolean(b) { + if (b) return MAL_TRUE + return MAL_FALSE +} + +func equal_seq(seq_a, seq_b) { + if (numberof(seq_a) != numberof(seq_b)) return 0 + for (i = 1; i <= numberof(seq_a); ++i) { + if (!equal(*seq_a(i), *seq_b(i))) return 0 + } + return 1 +} + +func equal_hash(hm_a, hm_b) { + if (numberof(*hm_a.keys) != numberof(*hm_b.keys)) return 0 + for (i = 1; i <= numberof(*hm_a.keys); ++i) { + key_a = (*hm_a.keys)(i) + val_a = *((*hm_a.vals)(i)) + val_b = hash_get(hm_b, key_a) + if (is_void(val_b) || !equal(val_a, val_b)) return 0 + } + return 1 +} + +func equal(a, b) { + ta = structof(a) + tb = structof(b) + if (ta == MalNil) return tb == MalNil + else if (ta == MalTrue) return tb == MalTrue + else if (ta == MalFalse) return tb == MalFalse + else if (ta == MalNumber) return tb == MalNumber && a.val == b.val + else if (ta == MalSymbol) return tb == MalSymbol && a.val == b.val + else if (ta == MalString) return tb == MalString && a.val == b.val + else if (ta == MalKeyword) return tb == MalKeyword && a.val == b.val + else if (ta == MalList || ta == MalVector) { + return (tb == MalList || tb == MalVector) && equal_seq(*(a.val), *(b.val)) + } + else if (ta == MalHashmap) return tb == MalHashmap && equal_hash(*a.val, *b.val) + else return 0 +} + +func streplaceall(s, pattern, subst) +{ + return streplace(s, strfind(pattern, s, n=999), subst) +} From a3665311219cc95d2f3ecd55faf86eb2861cd6b5 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Fri, 22 Sep 2017 21:14:35 +0000 Subject: [PATCH 0179/1998] README: Add Yorick (the 71st implementation) --- README.md | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index ed48a798a7..8e9c9433da 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 70 languages: +Mal is implemented in 71 languages: * Ada * GNU awk @@ -78,6 +78,7 @@ Mal is implemented in 70 languages: * VHDL * Vimscript * Visual Basic.NET +* Yorick Mal is a learning tool. See the [make-a-lisp process @@ -1006,6 +1007,17 @@ make mono ./stepX_YYY.exe ``` +### Yorick + +*The Yorick implementation was created by [Dov Murik](https://github.com/dubek)* + +The Yorick implementation of mal was tested on Yorick 2.2.04. + +``` +cd yorick +yorick -batch ./stepX_YYY.i +``` + ## Running tests From d64619ac508fd98ee2d0c8337c5d09e278a4e947 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Fri, 22 Sep 2017 21:15:43 +0000 Subject: [PATCH 0180/1998] travis: Add yorick to build matrix --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index b021b3158d..2f641cb216 100644 --- a/.travis.yml +++ b/.travis.yml @@ -89,6 +89,7 @@ matrix: - {env: IMPL=vb, services: [docker]} - {env: IMPL=vhdl, services: [docker]} - {env: IMPL=vimscript, services: [docker]} + - {env: IMPL=yorick, services: [docker]} script: # Build From c81a869e46aba5e8fb9fb700be5501a57e901492 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sun, 24 Sep 2017 08:45:59 +0000 Subject: [PATCH 0181/1998] yorick: Add `yorick-eval` interop support --- yorick/core.i | 19 +++++++++++++++++++ yorick/tests/stepA_mal.mal | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+) create mode 100644 yorick/tests/stepA_mal.mal diff --git a/yorick/core.i b/yorick/core.i index 167f388c81..c4d6ed447a 100644 --- a/yorick/core.i +++ b/yorick/core.i @@ -267,6 +267,24 @@ func mal_swap_bang(a) func mal_eval(a) { return EVAL(*a(1), repl_env); } +func yorick_to_mal(e) +{ + if (is_void(e)) return MAL_NIL + if (is_scalar(e)) { + if (is_numerical(e)) return MalNumber(val=e) + else if (is_string(e)) return MalString(val=e) + else return MalString(val=totxt(e)) + } else { + seq = array(pointer, numberof(e)) + for (i = 1; i <= numberof(e); ++i) { + seq(i) = &yorick_to_mal(e(i)) + } + return MalList(val=&seq) + } +} + +func mal_yorick_eval(a) { return yorick_to_mal(exec(a(1)->val)); } + core_ns = h_new() h_set, core_ns, "=", mal_equal @@ -335,6 +353,7 @@ h_set, core_ns, "reset!", mal_reset_bang h_set, core_ns, "swap!", mal_swap_bang h_set, core_ns, "eval", mal_eval +h_set, core_ns, "yorick-eval", mal_yorick_eval func call_core_fn(name, args_list) { diff --git a/yorick/tests/stepA_mal.mal b/yorick/tests/stepA_mal.mal new file mode 100644 index 0000000000..8c2229a12d --- /dev/null +++ b/yorick/tests/stepA_mal.mal @@ -0,0 +1,33 @@ +;; Testing basic Yorick interop + +(yorick-eval "7") +;=>7 + +(yorick-eval "\"7\" + \"89\"") +;=>"789" + +(yorick-eval "123 == 123") +;=>1 + +(yorick-eval "123 == 456") +;=>0 + +(yorick-eval "[7, 8, 9]") +;=>(7 8 9) + +(yorick-eval "write, format=\"%s-%d\\x0A\", \"hello\", 1234; return nil;") +; hello-1234 +;=>nil + +(yorick-eval "extern my_global_var; my_global_var = 8; return nil;") +(yorick-eval "my_global_var") +;=>8 + +(yorick-eval "a = [7, 8, 9]; return a + 10;") +;=>(17 18 19) + +(yorick-eval "[\"ab\", \"cd\", \"ef\"] + [\"X\", \"Y\", \"Z\"]") +;=>("abX" "cdY" "efZ") + +(yorick-eval "strpart(\"ABCDEFGHIJ\", 4:7)") +;=>"DEFG" From 33f404afd46184ca1163a639530a59608aa48d40 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 25 Sep 2017 19:53:49 +0000 Subject: [PATCH 0182/1998] yorick: Fix unescaping of "\\n" --- yorick/reader.i | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/yorick/reader.i b/yorick/reader.i index 3b7e90f09b..b6bb15e92f 100644 --- a/yorick/reader.i +++ b/yorick/reader.i @@ -48,10 +48,11 @@ NUMBER_REGEXP = regcomp("^-?[0-9]+$") func unescape(s) { - s1 = strpart(s, 2:-1) // remove surrounding quotes - s2 = streplaceall(s1, "\\n", "\n") - s3 = streplaceall(s2, "\\\"", "\"") - return streplaceall(s3, "\\\\", "\\") + s = strpart(s, 2:-1) // remove surrounding quotes + s = streplaceall(s, "\\\\", "\x01") + s = streplaceall(s, "\\n", "\n") + s = streplaceall(s, "\\\"", "\"") + return streplaceall(s, "\x01", "\\") } func read_atom(rdr) From a9f64691635a7a6ee0952c1aceff3c42d85a5fe0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 25 Sep 2017 15:25:47 -0500 Subject: [PATCH 0183/1998] Makefile: alphabetize implementations. --- Makefile | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/Makefile b/Makefile index dbd80c7216..4a7b236a6e 100644 --- a/Makefile +++ b/Makefile @@ -78,12 +78,12 @@ DOCKERIZE = # Implementation specific settings # -IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs dart \ - erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ - haxe hy io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ - nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ +IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ + elisp elixir elm erlang es6 factor forth fsharp go groovy gst guile haskell \ + haxe hy io java js julia kotlin livescript logo lua make mal matlab miniMAL \ + nim objc objpascal ocaml perl perl6 php pil plpgsql plsql powershell ps \ python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ - ts vb vhdl vimscript yorick livescript elm + ts vb vhdl vimscript yorick EXTENSION = .mal @@ -136,9 +136,9 @@ dist_EXCLUDES += guile io julia matlab swift logo_TEST_OPTS = --start-timeout 60 --test-timeout 120 mal_TEST_OPTS = --start-timeout 60 --test-timeout 120 miniMAL_TEST_OPTS = --start-timeout 60 --test-timeout 120 +perl6_TEST_OPTS = --test-timeout=60 plpgsql_TEST_OPTS = --start-timeout 60 --test-timeout 180 plsql_TEST_OPTS = --start-timeout 120 --test-timeout 120 -perl6_TEST_OPTS = --test-timeout=60 vimscript_TEST_OPTS = --test-timeout 30 ifeq ($(MAL_IMPL),vimscript) mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 @@ -154,14 +154,14 @@ endif basic_STEP_TO_PROG_cbm = basic/$($(1)).bas basic_STEP_TO_PROG_qbasic = basic/$($(1)) +clojure_STEP_TO_PROG_clj = clojure/target/$($(1)).jar +clojure_STEP_TO_PROG_cljs = clojure/src/mal/$($(1)).cljc + haxe_STEP_TO_PROG_neko = haxe/$($(1)).n haxe_STEP_TO_PROG_python = haxe/$($(1)).py haxe_STEP_TO_PROG_cpp = haxe/cpp/$($(1)) haxe_STEP_TO_PROG_js = haxe/$($(1)).js -clojure_STEP_TO_PROG_clj = clojure/target/$($(1)).jar -clojure_STEP_TO_PROG_cljs = clojure/src/mal/$($(1)).cljc - scheme_STEP_TO_PROG_chibi = scheme/$($(1)).scm scheme_STEP_TO_PROG_kawa = scheme/out/$($(1)).class scheme_STEP_TO_PROG_gauche = scheme/$($(1)).scm @@ -174,10 +174,8 @@ scheme_STEP_TO_PROG_foment = scheme/$($(1)).scm ada_STEP_TO_PROG = ada/$($(1)) awk_STEP_TO_PROG = awk/$($(1)).awk bash_STEP_TO_PROG = bash/$($(1)).sh -basic_STEP_TO_PROG = basic/$($(1)).bas basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) c_STEP_TO_PROG = c/$($(1)) -d_STEP_TO_PROG = d/$($(1)) chuck_STEP_TO_PROG = chuck/$($(1)).ck clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(clojure_MODE)) coffee_STEP_TO_PROG = coffee/$($(1)).coffee @@ -185,9 +183,11 @@ common-lisp_STEP_TO_PROG = common-lisp/$($(1)) cpp_STEP_TO_PROG = cpp/$($(1)) crystal_STEP_TO_PROG = crystal/$($(1)) cs_STEP_TO_PROG = cs/$($(1)).exe +d_STEP_TO_PROG = d/$($(1)) dart_STEP_TO_PROG = dart/$($(1)).dart elisp_STEP_TO_PROG = elisp/$($(1)).el elixir_STEP_TO_PROG = elixir/lib/mix/tasks/$($(1)).ex +elm_STEP_TO_PROG = elm/$($(1)).js erlang_STEP_TO_PROG = erlang/$($(1)) es6_STEP_TO_PROG = es6/build/$($(1)).js factor_STEP_TO_PROG = factor/$($(1))/$($(1)).factor @@ -196,23 +196,26 @@ fsharp_STEP_TO_PROG = fsharp/$($(1)).exe go_STEP_TO_PROG = go/$($(1)) groovy_STEP_TO_PROG = groovy/$($(1)).groovy gst_STEP_TO_PROG = gst/$($(1)).st -java_STEP_TO_PROG = java/target/classes/mal/$($(1)).class +guile_STEP_TO_PROG = guile/$($(1)).scm haskell_STEP_TO_PROG = haskell/$($(1)) haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(haxe_MODE)) hy_STEP_TO_PROG = hy/$($(1)).hy io_STEP_TO_PROG = io/$($(1)).io -julia_STEP_TO_PROG = julia/$($(1)).jl +java_STEP_TO_PROG = java/target/classes/mal/$($(1)).class js_STEP_TO_PROG = js/$($(1)).js +julia_STEP_TO_PROG = julia/$($(1)).jl kotlin_STEP_TO_PROG = kotlin/$($(1)).jar +livescript_STEP_TO_PROG = livescript/$($(1)).js +logo_STEP_TO_PROG = logo/$($(1)).lg lua_STEP_TO_PROG = lua/$($(1)).lua make_STEP_TO_PROG = make/$($(1)).mk mal_STEP_TO_PROG = mal/$($(1)).mal -ocaml_STEP_TO_PROG = ocaml/$($(1)) matlab_STEP_TO_PROG = matlab/$($(1)).m miniMAL_STEP_TO_PROG = miniMAL/$($(1)).json nim_STEP_TO_PROG = nim/$($(1)) objc_STEP_TO_PROG = objc/$($(1)) objpascal_STEP_TO_PROG = objpascal/$($(1)) +ocaml_STEP_TO_PROG = ocaml/$($(1)) perl_STEP_TO_PROG = perl/$($(1)).pl perl6_STEP_TO_PROG = perl6/$($(1)).pl php_STEP_TO_PROG = php/$($(1)).php @@ -239,9 +242,6 @@ vb_STEP_TO_PROG = vb/$($(1)).exe vhdl_STEP_TO_PROG = vhdl/$($(1)) vimscript_STEP_TO_PROG = vimscript/$($(1)).vim yorick_STEP_TO_PROG = yorick/$($(1)).i -guile_STEP_TO_PROG = guile/$($(1)).scm -livescript_STEP_TO_PROG = livescript/$($(1)).js -elm_STEP_TO_PROG = elm/$($(1)).js # From 8e59b7151b176b829d36fed944a693084cf9b60f Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 25 Sep 2017 20:24:48 +0000 Subject: [PATCH 0184/1998] tests: Add test for unescaping "\\n" in step4 Several implementations fail when unescaping "\\n" in their reader module because string-wide replacements of the two chars '\' and 'n' by a newline char will replace the last two chars. --- tests/step4_if_fn_do.mal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal index 0b69031ac1..6e503f9748 100644 --- a/tests/step4_if_fn_do.mal +++ b/tests/step4_if_fn_do.mal @@ -273,6 +273,9 @@ a "abc\\def\\ghi" ;=>"abc\\def\\ghi" +"\\n" +;=>"\\n" + ;; Testing pr-str (pr-str) From e73fcefe8fa80f8674710a0d42186a52381fb1df Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 27 Sep 2017 07:02:07 +0000 Subject: [PATCH 0185/1998] Fix unescaping in rexx, skew, vimscript --- rexx/reader.rexx | 3 ++- skew/reader.sk | 2 +- vimscript/reader.vim | 18 +++++++++++++----- 3 files changed, 16 insertions(+), 7 deletions(-) diff --git a/rexx/reader.rexx b/rexx/reader.rexx index 3afc8620d0..3b992f9679 100644 --- a/rexx/reader.rexx +++ b/rexx/reader.rexx @@ -95,9 +95,10 @@ is_number: procedure /* is_number(token) */ parse_string: procedure /* parse_string(token) */ token = arg(1) res = substr(token, 2, length(token) - 2) /* Remove quotes */ + res = changestr("\\", res, '01'x) res = changestr("\n", res, '0A'x) res = changestr('\"', res, '"') - res = changestr("\\", res, '5C'x) + res = changestr('01'x, res, '5C'x) return res parse_keyword: procedure /* parse_keyword(token) */ diff --git a/skew/reader.sk b/skew/reader.sk index 457e88865f..0aa723ba27 100644 --- a/skew/reader.sk +++ b/skew/reader.sk @@ -30,7 +30,7 @@ def tokenize(str string) List { } def unescape(s string) string { - return s.replaceAll("\\\"", "\"").replaceAll("\\n", "\n").replaceAll("\\\\", "\\") + return s.replaceAll("\\\\", "\x01").replaceAll("\\\"", "\"").replaceAll("\\n", "\n").replaceAll("\x01", "\\") } def read_atom(rdr Reader) MalVal { diff --git a/vimscript/reader.vim b/vimscript/reader.vim index 38510cd45e..f22debe6db 100644 --- a/vimscript/reader.vim +++ b/vimscript/reader.vim @@ -42,12 +42,20 @@ function Tokenize(str) return tokens endfunction +function UnescapeChar(seq) + if a:seq == '\"' + return '"' + elseif a:seq == '\n' + return "\n" + elseif a:seq == '\\' + return '\' + else + return a:seq + endif +endfunction + function ParseString(token) - let str = a:token[1:-2] - let str = substitute(str, '\\"', '"', "g") - let str = substitute(str, '\\n', "\n", "g") - let str = substitute(str, '\\\\', "\\", "g") - return str + return substitute(a:token[1:-2], '\\.', '\=UnescapeChar(submatch(0))', "g") endfunction function ReadAtom(rdr) From 0794206dc5a61b141ffcb9b7096864f79efedca2 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 27 Sep 2017 07:19:29 +0000 Subject: [PATCH 0186/1998] Fix unescaping in go, perl --- go/src/reader/reader.go | 6 ++++-- perl/reader.pm | 5 ++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/go/src/reader/reader.go b/go/src/reader/reader.go index 6411d72ce2..dc0f54f46f 100644 --- a/go/src/reader/reader.go +++ b/go/src/reader/reader.go @@ -69,9 +69,11 @@ func read_atom(rdr Reader) (MalType, error) { str := (*token)[1 : len(*token)-1] return strings.Replace( strings.Replace( - strings.Replace(str, `\"`, `"`, -1), + strings.Replace( + strings.Replace(str, `\\`, "\u029e", -1), + `\"`, `"`, -1), `\n`, "\n", -1), - `\\`, "\\", -1), nil + "\u029e", "\\", -1), nil } else if (*token)[0] == ':' { return NewKeyword((*token)[1:len(*token)]) } else if *token == "nil" { diff --git a/perl/reader.pm b/perl/reader.pm index 9527231df3..a4196badb0 100644 --- a/perl/reader.pm +++ b/perl/reader.pm @@ -32,10 +32,9 @@ sub read_atom { given ($token) { when(/^-?[0-9]+$/) { return Integer->new($token) } when(/^"/) { + my %escaped_chars = ( "\\\\" => "\\", "\\\"" => "\"", "\\n" => "\n" ); my $str = substr $token, 1, -1; - $str =~ s/\\"/"/g; - $str =~ s/\\n/\n/g; - $str =~ s/\\\\/\\/g; + $str =~ s/\\./$escaped_chars{$&}/ge; return String->new($str) } when(/^:/) { return _keyword(substr($token,1)) } From 1b17329dd5b3f2e78904d1db77bffb9f289522b1 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Wed, 27 Sep 2017 12:13:15 +0530 Subject: [PATCH 0187/1998] Fix unescaping strings for racket, elixir and io --- elixir/lib/mal/reader.ex | 6 ++---- io/MalReader.io | 3 ++- racket/reader.rkt | 8 +------- 3 files changed, 5 insertions(+), 12 deletions(-) diff --git a/elixir/lib/mal/reader.ex b/elixir/lib/mal/reader.ex index 59365c7f78..82ecc8d7d6 100644 --- a/elixir/lib/mal/reader.ex +++ b/elixir/lib/mal/reader.ex @@ -85,10 +85,8 @@ defmodule Mal.Reader do cond do String.starts_with?(token, "\"") and String.ends_with?(token, "\"") -> token - |> String.slice(1..-2) - |> String.replace("\\\"", "\"") - |> String.replace("\\n", "\n") - |> String.replace("\\\\", "\\") + |> Code.string_to_quoted + |> elem(1) integer?(token) -> Integer.parse(token) diff --git a/io/MalReader.io b/io/MalReader.io index 6192cb52fc..b753913706 100644 --- a/io/MalReader.io +++ b/io/MalReader.io @@ -28,7 +28,8 @@ MalReader := Object clone do ( numberRegex := Regex with("^-?[0-9]+$") read_string := method(token, - token exSlice(1, -1) replaceSeq("\\\"", "\"") replaceSeq("\\n", "\n") replaceSeq("\\\\", "\\") + placeholder := 127 asCharacter + token exSlice(1, -1) replaceSeq("\\\\", placeholder) replaceSeq("\\\"", "\"") replaceSeq("\\n", "\n") replaceSeq(placeholder, "\\") ) read_atom := method(rdr, diff --git a/racket/reader.rkt b/racket/reader.rkt index 280b9af2a0..6ff34cfb99 100644 --- a/racket/reader.rkt +++ b/racket/reader.rkt @@ -32,13 +32,7 @@ [(regexp-match #px"^-?[0-9][0-9.]*$" token) (string->number token)] [(regexp-match #px"^\".*\"$" token) - (string-replace - (string-replace - (string-replace - (substring token 1 (- (string-length token) 1)) - "\\\"" "\"") - "\\n" "\n") - "\\\\" "\\")] + (with-input-from-string token read)] [(regexp-match #px"^:" token) (_keyword (substring token 1))] [(equal? "nil" token) nil] [(equal? "true" token) #t] From 9ce82e328979f8c14a45aa88a299cf7b760fb2f8 Mon Sep 17 00:00:00 2001 From: Iqbal Ansari Date: Wed, 27 Sep 2017 19:06:43 +0530 Subject: [PATCH 0188/1998] Fix unescaping of strings for factor --- factor/lib/reader/reader.factor | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/factor/lib/reader/reader.factor b/factor/lib/reader/reader.factor index 587ed90ab7..767241ae26 100644 --- a/factor/lib/reader/reader.factor +++ b/factor/lib/reader/reader.factor @@ -1,18 +1,26 @@ ! Copyright (C) 2015 Jordan Lewis. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators grouping hashtables kernel lists -locals make lib.types math.parser regexp sequences splitting ; +USING: arrays combinators grouping hashtables kernel lists locals +make lib.types math.parser regexp sequences splitting strings ; IN: lib.reader CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)~^@]+)/ DEFER: read-form +: (read-string) ( str -- maltype ) + rest but-last R/ \\./ [ + { + { [ dup >string "\\\\" = ] [ drop "\\" ] } + { [ dup >string "\\n" = ] [ drop "\n" ] } + { [ dup >string "\\\"" = ] [ drop "\"" ] } + [ ] + } cond + ] re-replace-with ; + : (read-atom) ( str -- maltype ) { - { [ dup first CHAR: " = ] [ rest but-last "\\\"" "\"" replace - "\\n" "\n" replace - "\\\\" "\\" replace ] } + { [ dup first CHAR: " = ] [ (read-string) ] } { [ dup first CHAR: : = ] [ rest ] } { [ dup "false" = ] [ drop f ] } { [ dup "true" = ] [ drop t ] } From ea02f4644594bb66f7ed80844c8ca28eb748517e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 09:12:29 -0500 Subject: [PATCH 0189/1998] Fix unescaping in bash, basic, es6, js, ruby, rust. --- bash/reader.sh | 3 ++- basic/reader.in.bas | 3 ++- es6/reader.js | 4 +--- js/reader.js | 4 +--- ruby/reader.rb | 2 +- rust/src/printer.rs | 9 +++++---- 6 files changed, 12 insertions(+), 13 deletions(-) diff --git a/bash/reader.sh b/bash/reader.sh index 688fc8b442..fa6064ce73 100644 --- a/bash/reader.sh +++ b/bash/reader.sh @@ -14,9 +14,10 @@ READ_ATOM () { [0-9]*) _number "${token}" ;; -[0-9]*) _number "${token}" ;; \"*) token="${token:1:-1}" + token="${token//\\\\/${__keyw}}" token="${token//\\\"/\"}" token="${token//\\n/$'\n'}" - token="${token//\\\\/\\}" + token="${token//${__keyw}/\\}" _string "${token}" ;; :*) _keyword "${token:1}" ;; nil) r="${__nil}" ;; diff --git a/basic/reader.in.bas b/basic/reader.in.bas index daafb43ca9..ee2e864e8d 100644 --- a/basic/reader.in.bas +++ b/basic/reader.in.bas @@ -168,10 +168,11 @@ SUB READ_FORM C=ASC(MID$(T$,LEN(T$),1)) IF C<>34 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"'":GOTO READ_FORM_RETURN R$=MID$(T$,2,LEN(T$)-2) + S1$=CHR$(92)+CHR$(92):S2$=CHR$(127):GOSUB REPLACE: REM protect backslashes S1$=CHR$(92)+CHR$(34):S2$=CHR$(34):GOSUB REPLACE: REM unescape quotes #cbm S1$=CHR$(92)+"n":S2$=CHR$(13):GOSUB REPLACE: REM unescape newlines #qbasic S1$=CHR$(92)+"n":S2$=CHR$(10):GOSUB REPLACE: REM unescape newlines - S1$=CHR$(92)+CHR$(92):S2$=CHR$(92):GOSUB REPLACE: REM unescape backslashes + S1$=CHR$(127):S2$=CHR$(92):GOSUB REPLACE: REM unescape backslashes REM intern string value B$=R$:T=4:GOSUB STRING GOTO READ_FORM_RETURN diff --git a/es6/reader.js b/es6/reader.js index e7afe00318..fb2c2f2fac 100644 --- a/es6/reader.js +++ b/es6/reader.js @@ -31,9 +31,7 @@ function read_atom (reader) { return parseFloat(token,10) // float } else if (token[0] === "\"") { return token.slice(1,token.length-1) - .replace(/\\"/g, '"') - .replace(/\\n/g, "\n") - .replace(/\\\\/g, "\\") // string + .replace(/\\(.)/g, (_, c) => c === "n" ? "\n" : c) } else if (token[0] === ":") { return _keyword(token.slice(1)) } else if (token === "nil") { diff --git a/js/reader.js b/js/reader.js index d2bcd91bc4..b147c13b8a 100644 --- a/js/reader.js +++ b/js/reader.js @@ -33,9 +33,7 @@ function read_atom (reader) { return parseFloat(token,10); // float } else if (token[0] === "\"") { return token.slice(1,token.length-1) - .replace(/\\"/g, '"') - .replace(/\\n/g, "\n") - .replace(/\\\\/g, "\\"); // string + .replace(/\\(.)/g, function (_, c) { return c === "n" ? "\n" : c}) } else if (token[0] === ":") { return types._keyword(token.slice(1)); } else if (token === "nil") { diff --git a/ruby/reader.rb b/ruby/reader.rb index 1e601744e1..446f7ae5d7 100644 --- a/ruby/reader.rb +++ b/ruby/reader.rb @@ -23,7 +23,7 @@ def tokenize(str) end def parse_str(t) # trim and unescape - return t[1..-2].gsub(/\\"/, '"').gsub(/\\n/, "\n").gsub(/\\\\/, "\\") + return t[1..-2].gsub(/\\./, {"\\\\" => "\\", "\\n" => "\n", "\\\"" => '"'}) end def read_atom(rdr) diff --git a/rust/src/printer.rs b/rust/src/printer.rs index 4150d39d27..1bb11e3c27 100644 --- a/rust/src/printer.rs +++ b/rust/src/printer.rs @@ -1,4 +1,5 @@ use types::MalVal; +use regex::Captures; pub fn escape_str(s: &str) -> String { let mut escaped = String::new(); @@ -22,10 +23,10 @@ pub fn escape_str(s: &str) -> String { } pub fn unescape_str(s: &str) -> String { - let re1 = regex!(r#"\\""#); - let re2 = regex!(r#"\\n"#); - let re3 = regex!(r#"\\\\"#); - re3.replace_all(&re2.replace_all(&re1.replace_all(&s, "\""), "\n"), "\\") + let re = regex!(r#"\\(.)"#); + re.replace_all(&s, |caps: &Captures| { + format!("{}", if &caps[1] == "n" { "\n" } else { &caps[1] }) + }) } pub fn pr_list(lst: &Vec, pr: bool, From 273226aa7465a43ec11b0a2747721f8dfd8f2eac Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 10:34:49 -0500 Subject: [PATCH 0190/1998] Fix unescaping in matlab, miniMAL and rpython. --- matlab/reader.m | 3 ++- miniMAL/reader.json | 12 ++++++------ rpython/reader.py | 3 ++- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/matlab/reader.m b/matlab/reader.m index ada1af6f1b..8cea773ac4 100644 --- a/matlab/reader.m +++ b/matlab/reader.m @@ -16,9 +16,10 @@ atm = str2double(token); elseif strcmp(token(1), '"') atm = token(2:length(token)-1); + atm = strrep(atm, '\\', char(255)); atm = strrep(atm, '\"', '"'); atm = strrep(atm, '\n', char(10)); - atm = strrep(atm, '\\', '\'); + atm = strrep(atm, char(255), '\'); elseif strcmp(token(1), ':') s = token(2:end); atm = type_utils.keyword(s); diff --git a/miniMAL/reader.json b/miniMAL/reader.json index d9ceeddb1c..830158e96e 100644 --- a/miniMAL/reader.json +++ b/miniMAL/reader.json @@ -38,12 +38,12 @@ ["parseInt", "token", 10], ["if", ["=", ["`", "\""], ["get", "token", 0]], [".", - [".", - [".", - ["slice", "token", 1, ["-", ["count", "token"], 1]], - ["`", "replace"], ["RegExp", ["`", "\\\\\""], ["`", "g"]], ["`", "\""]], - ["`", "replace"], ["RegExp", ["`", "\\\\n"], ["`", "g"]], ["`", "\n"]], - ["`", "replace"], ["RegExp", ["`", "\\\\\\\\"], ["`", "g"]], ["`", "\\"]], + ["slice", "token", 1, ["-", ["count", "token"], 1]], + ["`", "replace"], ["RegExp", ["`", "\\\\(.)"], ["`", "g"]], + ["fn", ["_", "c"], + ["if", ["=", "c", ["`", "n"]], + ["`", "\n"], + "c"]]], ["if", ["=", ["`", ":"], ["get", "token", 0]], ["keyword", ["slice", "token", 1]], ["if", ["=", ["`", "nil"], "token"], diff --git a/rpython/reader.py b/rpython/reader.py index 1e5acf6cb4..5f8af46b22 100644 --- a/rpython/reader.py +++ b/rpython/reader.py @@ -51,9 +51,10 @@ def read_atom(reader): return MalStr(u"") else: s = unicode(token[1:end]) + s = types._replace(u'\\\\', u"\u029e", s) s = types._replace(u'\\"', u'"', s) s = types._replace(u'\\n', u"\n", s) - s = types._replace(u'\\\\', u"\\", s) + s = types._replace(u"\u029e", u"\\", s) return MalStr(s) elif token[0] == ':': return _keywordu(unicode(token[1:])) elif token == "nil": return types.nil From 42aecee642b36aeb0b0aec15cfbc6b0007ca7b24 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 12:12:15 -0500 Subject: [PATCH 0191/1998] Fix unescaping in cs, hy, nim, objpascal, ps, rpython, vb --- cs/reader.cs | 7 ++++--- hy/reader.hy | 7 ++++--- nim/Dockerfile | 6 +++--- nim/reader.nim | 2 +- objpascal/reader.pas | 7 ++++--- ps/reader.ps | Bin 8867 -> 8895 bytes rpython/reader.py | 6 +++--- vb/reader.vb | 7 ++++--- 8 files changed, 23 insertions(+), 19 deletions(-) diff --git a/cs/reader.cs b/cs/reader.cs index a644309a8a..60798e37bf 100644 --- a/cs/reader.cs +++ b/cs/reader.cs @@ -71,9 +71,10 @@ public static MalVal read_atom(Reader rdr) { } else if (match.Groups[6].Value != String.Empty) { string str = match.Groups[6].Value; str = str.Substring(1, str.Length-2) - .Replace("\\\"", "\"") - .Replace("\\n", "\n") - .Replace("\\\\", "\\"); + .Replace("\\\\", "\u029e") + .Replace("\\\"", "\"") + .Replace("\\n", "\n") + .Replace("\u029e", "\\"); return new Mal.types.MalString(str); } else if (match.Groups[7].Value != String.Empty) { return new Mal.types.MalString("\u029e" + match.Groups[7].Value); diff --git a/hy/reader.hy b/hy/reader.hy index 41abec29d3..4c9bd1d525 100644 --- a/hy/reader.hy +++ b/hy/reader.hy @@ -25,9 +25,10 @@ (!= (get t 0) ";"))) (defn unescape [s] - (-> s (.replace "\\\"" "\"") - (.replace "\\n" "\n") - (.replace "\\\\" "\\"))) + (-> s (.replace "\\\\" "\u029e") + (.replace "\\\"" "\"") + (.replace "\\n" "\n") + (.replace "\u029e" "\\"))) (defn read-atom [rdr] (setv token (.next rdr)) diff --git a/nim/Dockerfile b/nim/Dockerfile index 9744753e93..1ffef105b5 100644 --- a/nim/Dockerfile +++ b/nim/Dockerfile @@ -26,10 +26,10 @@ RUN apt-get -y install g++ # Nim RUN apt-get -y install xz-utils -RUN cd /tmp && curl -O http://nim-lang.org/download/nim-0.17.0.tar.xz \ - && tar xvJf /tmp/nim-0.17.0.tar.xz && cd nim-0.17.0 \ +RUN cd /tmp && curl -O https://nim-lang.org/download/nim-0.17.2.tar.xz \ + && tar xvJf /tmp/nim-0.17.2.tar.xz && cd nim-0.17.2 \ && make && sh install.sh /usr/local/bin \ && cp bin/nim /usr/local/bin/ \ - && rm -r /tmp/nim-0.17.0 + && rm -r /tmp/nim-0.17.2 ENV HOME /mal diff --git a/nim/reader.nim b/nim/reader.nim index 4df8c9c5b6..6bc2997fee 100644 --- a/nim/reader.nim +++ b/nim/reader.nim @@ -61,7 +61,7 @@ proc read_hash_map(r: var Reader): MalType = proc read_atom(r: var Reader): MalType = let t = r.next if t.match(intRE): number t.parseInt - elif t[0] == '"': str t[1 .. '' then begin Str := copy(Token, 2, Length(Token)-2); - Str := StringReplace(Str, '\"', '"', [rfReplaceAll]); - Str := StringReplace(Str, '\n', #10, [rfReplaceAll]); - Str := StringReplace(Str, '\\', '\', [rfReplaceAll]); + Str := StringReplace(Str, '\\', #127, [rfReplaceAll]); + Str := StringReplace(Str, '\"', '"', [rfReplaceAll]); + Str := StringReplace(Str, '\n', #10, [rfReplaceAll]); + Str := StringReplace(Str, #127, '\', [rfReplaceAll]); read_atom := TMalString.Create(Str) end else if RE.Match[7] <> '' then diff --git a/ps/reader.ps b/ps/reader.ps index 3574242f0ecce270e028a6e3c1a03f298f05d28f..c5e19bf15848f0b6fcf9e542c0f241f52ccb5377 100644 GIT binary patch delta 88 zcmZ4Ny5DufL~iex7)=F@7(;V&O@*S=f}F(UR4xS|(1?jq(gadK0!=s%Bpd@IQN@8K KY(BvKSPTGL<`}I2 delta 42 vcmdn*y4ZEYL~bS}&B^Py#l String.Empty Then return New Mal.types.MalString(ChrW(&H029e) & match.Groups(7).Value) Else If match.Groups(8).Value <> String.Empty Then From e91c55c2b65cf7628760433f1fcce84f40e645df Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 26 Sep 2017 22:07:49 +0200 Subject: [PATCH 0192/1998] Fix unescaping in chuck, common-lisp, gst, guile, python --- chuck/types/boxed/String.ck | 3 ++- common-lisp/src/reader.lisp | 16 ++++++++++++---- gst/util.st | 6 ++++-- guile/reader.scm | 15 ++++----------- python/reader.py | 4 ++-- 5 files changed, 24 insertions(+), 20 deletions(-) diff --git a/chuck/types/boxed/String.ck b/chuck/types/boxed/String.ck index c0ec6f71e2..4c7390a8b3 100644 --- a/chuck/types/boxed/String.ck +++ b/chuck/types/boxed/String.ck @@ -112,9 +112,10 @@ public class String fun static string parse(string input) { slice(input, 1, input.length() - 1) => string output; + replaceAll(output, "\\\\", "\177") => output; replaceAll(output, "\\\"", "\"") => output; replaceAll(output, "\\n", "\n") => output; - replaceAll(output, "\\\\", "\\") => output; + replaceAll(output, "\177", "\\") => output; return output; } diff --git a/common-lisp/src/reader.lisp b/common-lisp/src/reader.lisp index 5391b4dd89..cfcb5ae8dd 100644 --- a/common-lisp/src/reader.lisp +++ b/common-lisp/src/reader.lisp @@ -90,12 +90,20 @@ raised" reader) (defun parse-string (token) + ;; read-from-string doesn't handle \n (if (and (> (length token) 1) (scan *string-re* token)) - (read-from-string (utils:replace-all token - "\\n" - " -")) + (let ((input (subseq token 1 (1- (length token))))) + (with-output-to-string (out) + (with-input-from-string (in input) + (loop while (peek-char nil in nil) + do (let ((char (read-char in))) + (if (eql char #\\ ) + (let ((char (read-char in))) + (if (eql char #\n) + (terpri out) + (princ char out))) + (princ char out))))))) (error 'eof :context "string"))) (defun expand-quote (reader) diff --git a/gst/util.st b/gst/util.st index 5a73576e27..4a0009e6b0 100644 --- a/gst/util.st +++ b/gst/util.st @@ -10,12 +10,14 @@ SequenceableCollection extend [ String extend [ parse [ - |text| + |text canary| + canary := 8r177 asCharacter asString. text := self copyFrom: 2 to: self size - 1. + text := text copyReplaceAll: '\\' with: canary. text := text copyReplaceAll: '\"' with: '"'. text := text copyReplaceAll: '\n' with: ' '. - text := text copyReplaceAll: '\\' with: '\'. + text := text copyReplaceAll: canary with: '\'. ^text ] diff --git a/guile/reader.scm b/guile/reader.scm index c734759e03..38cebbe066 100644 --- a/guile/reader.scm +++ b/guile/reader.scm @@ -78,21 +78,14 @@ (lp (cddr next))))))))) (define (read_atom reader) - (define (->str s) - (string-sub - (string-sub - (string-sub s "\\\\\"" "\"") - "\\\\n" "\n") - "\\\\\\\\" "\\")) (let ((token (reader 'next))) (cond ((string-match "^-?[0-9][0-9.]*$" token) => (lambda (m) (string->number (match:substring m 0)))) - ((string-match "^\"(.*)(.)$" token) - => (lambda (m) - (if (string=? "\"" (match:substring m 2)) - (->str (match:substring m 1)) - (throw 'mal-error "expected '\"'")))) + ((eqv? (string-ref token 0) #\") + (if (eqv? (string-ref token (- (string-length token) 1)) #\") + (with-input-from-string token read) + (throw 'mal-error "expected '\"'"))) ((string-match "^:(.*)" token) => (lambda (m) (string->keyword (match:substring m 1)))) ((string=? "nil" token) nil) diff --git a/python/reader.py b/python/reader.py index 44c9d741cc..84c46c5d92 100644 --- a/python/reader.py +++ b/python/reader.py @@ -1,5 +1,5 @@ import re -from mal_types import (_symbol, _keyword, _list, _vector, _hash_map, _s2u) +from mal_types import (_symbol, _keyword, _list, _vector, _hash_map, _s2u, _u) class Blank(Exception): pass @@ -23,7 +23,7 @@ def tokenize(str): return [t for t in re.findall(tre, str) if t[0] != ';'] def _unescape(s): - return s.replace('\\"', '"').replace('\\n', '\n').replace('\\\\', '\\') + return s.replace('\\\\', _u('\u029e')).replace('\\"', '"').replace('\\n', '\n').replace(_u('\u029e'), '\\') def read_atom(reader): int_re = re.compile(r"-?[0-9]+$") From a821cd720423678f14baea7c9a59ebc08aebfbb4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 14:04:01 -0500 Subject: [PATCH 0193/1998] Fix unescaping in c, coffee, crystal, haxe, plpgsql and r. --- c/reader.c | 15 +-------------- coffee/reader.coffee | 4 +--- crystal/Makefile | 14 +++++++++++++- crystal/reader.cr | 6 +++--- haxe/reader/Reader.hx | 19 ++++++++++++------- plpgsql/reader.sql | 3 ++- r/reader.r | 5 +++-- 7 files changed, 35 insertions(+), 31 deletions(-) diff --git a/c/reader.c b/c/reader.c index c50e5e97a4..2528b3a1d0 100644 --- a/c/reader.c +++ b/c/reader.c @@ -78,14 +78,6 @@ Reader *tokenize(char *line) { } -char *replace_str(const char *str, const char *old, const char *new) -{ - GRegex *reg = g_regex_new (old, 0, 0, NULL); - char *str_tmp = g_regex_replace_literal(reg, str, -1, 0, new, 0, NULL); - MAL_GC_FREE(reg); - return str_tmp; -} - MalVal *read_atom(Reader *reader) { char *token; GRegex *regex; @@ -117,12 +109,7 @@ MalVal *read_atom(Reader *reader) { atom = &mal_false; } else if (g_match_info_fetch_pos(matchInfo, 6, &pos, NULL) && pos != -1) { //g_print("read_atom string: %s\n", token); - char *str_tmp = replace_str(g_match_info_fetch(matchInfo, 6), "\\\\\"", "\""); - char *str_tmp2 = replace_str(str_tmp, "\\\\n", "\n"); - MAL_GC_FREE(str_tmp); - char *str_tmp3 = replace_str(str_tmp2, "\\\\\\\\", "\\"); - MAL_GC_FREE(str_tmp2); - atom = malval_new_string(str_tmp3); + atom = malval_new_string(g_strcompress(g_match_info_fetch(matchInfo, 6))); } else if (g_match_info_fetch_pos(matchInfo, 7, &pos, NULL) && pos != -1) { //g_print("read_atom keyword\n"); atom = malval_new_keyword(MAL_GC_STRDUP(g_match_info_fetch(matchInfo, 7))); diff --git a/coffee/reader.coffee b/coffee/reader.coffee index 1c9ab3e6d0..c6fb7d9179 100644 --- a/coffee/reader.coffee +++ b/coffee/reader.coffee @@ -24,9 +24,7 @@ read_atom = (rdr) -> else if token.match /^-?[0-9][0-9.]*$/ then parseFloat token,10 else if token[0] == '"' token.slice(1, token.length-1) - .replace(/\\"/g, '"') - .replace(/\\n/g, "\n") - .replace(/\\\\/g, "\\") + .replace(/\\(.)/g, (_, c) -> if c == 'n' then '\n' else c) else if token[0] == ':' then types._keyword(token[1..]) else if token == "nil" then null else if token == "true" then true diff --git a/crystal/Makefile b/crystal/Makefile index e33eadbef6..a26b02d13e 100644 --- a/crystal/Makefile +++ b/crystal/Makefile @@ -2,6 +2,12 @@ STEPS = step0_repl.cr step1_read_print.cr step2_eval.cr step3_env.cr \ step4_if_fn_do.cr step5_tco.cr step6_file.cr step7_quote.cr \ step8_macros.cr step9_try.cr stepA_mal.cr +STEP0_DEPS = readline.cr +STEP1_DEPS = $(STEP0_DEPS) reader.cr printer.cr +STEP2_DEPS = $(STEP1_DEPS) types.cr +STEP3_DEPS = $(STEP2_DEPS) env.cr +STEP4_DEPS = $(STEP3_DEPS) core.cr error.cr + STEP_BINS = $(STEPS:%.cr=%) LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) @@ -12,9 +18,15 @@ dist: mal mal: $(LAST_STEP_BIN) cp $< $@ -$(STEP_BINS): %: %.cr $(MAL_LIB) +$(STEP_BINS): %: %.cr crystal compile --release $< +step0_repl: $(STEP0_DEPS) +step1_read_print: $(STEP1_DEPS) +step2_eval: $(STEP2_DEPS) +step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + clean: rm -rf $(STEP_BINS) mal .crystal diff --git a/crystal/reader.cr b/crystal/reader.cr index b02c47a39b..34b469220c 100644 --- a/crystal/reader.cr +++ b/crystal/reader.cr @@ -81,9 +81,9 @@ class Reader when token == "true" then true when token == "false" then false when token == "nil" then nil - when token[0] == '"' then token[1..-2].gsub(/\\"/, "\"") - .gsub(/\\n/, "\n") - .gsub(/\\\\/, "\\") + when token[0] == '"' then token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", + "\\n" => "\n", + "\\\\" => "\\"}) when token[0] == ':' then "\u029e#{token[1..-1]}" else Mal::Symbol.new token end diff --git a/haxe/reader/Reader.hx b/haxe/reader/Reader.hx index e6d601d49f..3955a3d4d5 100644 --- a/haxe/reader/Reader.hx +++ b/haxe/reader/Reader.hx @@ -58,15 +58,20 @@ class Reader { case _ if (re_int.match(token)): MalInt(Std.parseInt(token)); case _ if (re_str.match(token)): - var re1 = ~/\\"/g, + var re1 = ~/\\\\/g, re2 = ~/\\n/g, - re3 = ~/\\\\/g, + re3 = ~/\\"/g, + re4 = ~/\x7f/g, s = token.substr(1, token.length-2); - MalString(re3.replace( - re2.replace( - re1.replace(s, "\""), - "\n"), - "\\")); + MalString(re4.replace( + re3.replace( + re2.replace( + re1.replace( + s, + "\x7f"), + "\n"), + "\""), + "\\")); case _: MalSymbol(token); } diff --git a/plpgsql/reader.sql b/plpgsql/reader.sql index f0b96bb2a1..2368df23e3 100644 --- a/plpgsql/reader.sql +++ b/plpgsql/reader.sql @@ -39,9 +39,10 @@ BEGIN ELSIF token ~ '^".*"' THEN -- string -- string str := substring(token FROM 2 FOR (char_length(token)-2)); + str := replace(str, '\\', chr(CAST(x'7f' AS integer))); str := replace(str, '\"', '"'); str := replace(str, '\n', E'\n'); - str := replace(str, '\\', E'\\'); + str := replace(str, chr(CAST(x'7f' AS integer)), E'\\'); result := types._stringv(str); ELSIF token ~ '^:.*' THEN -- keyword -- keyword diff --git a/r/reader.r b/r/reader.r index 030581093c..b2729f840e 100644 --- a/r/reader.r +++ b/r/reader.r @@ -43,10 +43,11 @@ read_atom <- function(rdr) { } else if (re_match("^-?[0-9][0-9.]*$", token)) { as.double(token) } else if (substr(token,1,1) == "\"") { - gsub("\\\\\\\\", "\\\\", + gsub("\x7f", "\\\\", gsub("\\\\n", "\n", gsub("\\\\\"", "\"", - substr(token, 2, nchar(token)-1)))) + gsub("\\\\\\\\", "\x7f", + substr(token, 2, nchar(token)-1))))) } else if (substr(token,1,1) == ":") { new.keyword(substring(token,2)) } else if (token == "nil") { From da9aef124aa86998f19afe6c729d1d3105f0506a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 15:31:50 -0500 Subject: [PATCH 0194/1998] Fix unescaping in lua, objc, php, powershell, swift3 and ts. --- lua/reader.lua | 3 ++- objc/reader.m | 5 +++-- php/reader.php | 7 ++++--- powershell/reader.psm1 | 3 ++- swift3/Sources/reader.swift | 5 +++-- ts/Makefile | 2 +- ts/reader.ts | 4 +--- 7 files changed, 16 insertions(+), 13 deletions(-) diff --git a/lua/reader.lua b/lua/reader.lua index ee0a61e6d7..261f3ecbc3 100644 --- a/lua/reader.lua +++ b/lua/reader.lua @@ -45,9 +45,10 @@ function M.read_atom(rdr) elseif float_re:exec(token) then return tonumber(token) elseif string.sub(token,1,1) == '"' then local sval = string.sub(token,2,string.len(token)-1) + sval = string.gsub(sval, '\\\\', '\177') sval = string.gsub(sval, '\\"', '"') sval = string.gsub(sval, '\\n', '\n') - sval = string.gsub(sval, '\\\\', '\\') + sval = string.gsub(sval, '\177', '\\') return sval elseif string.sub(token,1,1) == ':' then return "\177" .. string.sub(token,2) diff --git a/objc/reader.m b/objc/reader.m index 49320e33cb..2755ffd419 100644 --- a/objc/reader.m +++ b/objc/reader.m @@ -98,10 +98,11 @@ - (NSString *)peek { return [MalFalse alloc]; // TODO: intern } else if ([match rangeAtIndex:6].location < -1ULL/2) { // string NSString * str = [token substringWithRange:[match rangeAtIndex:6]]; - return [[[str + return [[[[str + stringByReplacingOccurrencesOfString:@"\\\\" withString:@"\u029e"] stringByReplacingOccurrencesOfString:@"\\\"" withString:@"\""] stringByReplacingOccurrencesOfString:@"\\n" withString:@"\n"] - stringByReplacingOccurrencesOfString:@"\\\\" withString:@"\\"]; + stringByReplacingOccurrencesOfString:@"\u029e" withString:@"\\"]; } else if ([match rangeAtIndex:7].location < -1ULL/2) { // keyword return [NSString stringWithFormat:@"\u029e%@", [token substringWithRange:[match rangeAtIndex:7]]]; diff --git a/php/reader.php b/php/reader.php index 68c21eaad1..54ed8b11c2 100644 --- a/php/reader.php +++ b/php/reader.php @@ -38,9 +38,10 @@ function read_atom($reader) { return intval($token, 10); } elseif ($token[0] === "\"") { $str = substr($token, 1, -1); - $str = preg_replace('/\\\\"/', '"', $str); - $str = preg_replace('/\\\\n/', "\n", $str); - $str = preg_replace('/\\\\\\\\/', "\\", $str); + $str = str_replace('\\\\', chr(0x7f), $str); + $str = str_replace('\\"', '"', $str); + $str = str_replace('\\n', "\n", $str); + $str = str_replace(chr(0x7f), "\\", $str); return $str; } elseif ($token[0] === ":") { return _keyword(substr($token,1)); diff --git a/powershell/reader.psm1 b/powershell/reader.psm1 index 88712e0e25..b957ca2055 100644 --- a/powershell/reader.psm1 +++ b/powershell/reader.psm1 @@ -33,9 +33,10 @@ function read_atom([Reader] $rdr) { return [convert]::ToInt32($token, 10) } elseif ($token -match "^`".*`"") { $s = $token.Substring(1,$token.Length-2) + $s = $s -replace "\\\\", "$([char]0x29e)" $s = $s -replace "\\`"", "`"" $s = $s -replace "\\n", "`n" - $s = $s -replace "\\\\", "\" + $s = $s -replace "$([char]0x29e)", "\" return $s } elseif ($token -match ":.*") { return "$([char]0x29e)$($token.substring(1))" diff --git a/swift3/Sources/reader.swift b/swift3/Sources/reader.swift index c4eacf4272..66cef2d3a2 100644 --- a/swift3/Sources/reader.swift +++ b/swift3/Sources/reader.swift @@ -79,9 +79,10 @@ func read_string(_ rdr: Reader) throws -> MalVal { } let matchStr = rdr.str.substring(with: rdr.str.index(after: start).. c == 'n' ? '\n' : c) return new MalString(v); } if (token[0] === ":") { From 051685d1a206849b25e21ba093105b37934a7cf8 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 16:29:30 -0500 Subject: [PATCH 0195/1998] Fix unescaping in julia and kotlin. --- julia/reader.jl | 9 +++------ kotlin/src/mal/reader.kt | 6 +++++- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/julia/reader.jl b/julia/reader.jl index 487dfe8211..29b5dc9548 100644 --- a/julia/reader.jl +++ b/julia/reader.jl @@ -38,12 +38,9 @@ function read_atom(rdr) elseif ismatch(r"^-?[0-9][0-9.]*$", token) float(token) elseif ismatch(r"^\".*\"$", token) - replace( - replace( - replace(token[2:end-1], - "\\\"", "\""), - "\\n", "\n"), - "\\\\", "\\") + replace(token[2:end-1], r"\\.", (r) -> get(Dict("\\n"=>"\n", + "\\\""=>"\"", + "\\\\"=>"\\"), r, r)) elseif token[1] == ':' "\u029e$(token[2:end])" elseif token == "nil" diff --git a/kotlin/src/mal/reader.kt b/kotlin/src/mal/reader.kt index 2adddcbeb0..3b23be5f04 100644 --- a/kotlin/src/mal/reader.kt +++ b/kotlin/src/mal/reader.kt @@ -139,7 +139,11 @@ fun read_atom(reader: Reader): MalType { } else if (groups[4]?.value != null) { FALSE } else if (groups[5]?.value != null) { - MalString((groups[5]?.value as String).replace("\\n", "\n").replace("\\\"", "\"").replace("\\\\", "\\")) + MalString((groups[5]?.value as String).replace(Regex("""\\(.)""")) + { m: MatchResult -> + if (m.groups[1]?.value == "n") "\n" + else m.groups[1]?.value.toString() + }) } else if (groups[6]?.value != null) { MalKeyword(groups[6]?.value as String) } else if (groups[7]?.value != null) { From a7d9ace3bef8586c2307462bc0a2bc6163ed8516 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Sep 2017 17:45:32 -0500 Subject: [PATCH 0196/1998] Fix unescaping in awk, d, dart. --- awk/reader.awk | 3 ++- d/reader.d | 5 ++++- dart/reader.dart | 5 ++--- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/awk/reader.awk b/awk/reader.awk index 95824ee549..6dcaf804f0 100644 --- a/awk/reader.awk +++ b/awk/reader.awk @@ -1,9 +1,10 @@ function reader_read_string(token, v, r) { token = substr(token, 1, length(token) - 1) - gsub(/\\\\/, "\\", token) + gsub(/\\\\/, "\u029e", token) gsub(/\\"/, "\"", token) gsub(/\\n/, "\n", token) + gsub("\u029e", "\\", token) return token } diff --git a/d/reader.d b/d/reader.d index 9cd39653f1..ac33b84656 100644 --- a/d/reader.d +++ b/d/reader.d @@ -61,11 +61,14 @@ string[] tokenize(string str) MalString parse_string(string token) { + // TODO: this could be done with replaceAll + // https://dlang.org/library/std/regex/replace_all.html string unescaped = token[1..$-1] // Remove surrounding quotes + .replace("\\\\", "\u029e") .replace("\\n", "\n") .replace("\\\"", "\"") - .replace("\\\\", "\\"); + .replace("\u029e", "\\"); return new MalString(unescaped); } diff --git a/dart/reader.dart b/dart/reader.dart index 5734fce0f8..e440ae054b 100644 --- a/dart/reader.dart +++ b/dart/reader.dart @@ -118,9 +118,8 @@ MalType read_atom(Reader reader) { var sanitizedToken = token // remove surrounding quotes .substring(1, token.length - 1) - .replaceAll(r'\"', '"') - .replaceAll(r'\n', '\n') - .replaceAll(r'\\', '\\'); + .replaceAllMapped(new RegExp("\\\\(.)"), + (Match m) => m[1] == 'n' ? '\n' : m[1]); return new MalString(sanitizedToken); } From 150008c9fcbefef690584416a19cbafbe79129b2 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 27 Sep 2017 11:00:15 -0500 Subject: [PATCH 0197/1998] Fix unescaping in scala. --- scala/reader.scala | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/scala/reader.scala b/scala/reader.scala index c8d75e4360..891e677c03 100644 --- a/scala/reader.scala +++ b/scala/reader.scala @@ -26,7 +26,11 @@ object reader { } def parse_str(s: String): String = { - s.replace("\\\"", "\"").replace("\\n", "\n").replace("\\\\", "\\") + // TODO: use re.replaceAllIn instead for single pass + s.replace("\\\\", "\u029e") + .replace("\\\"", "\"") + .replace("\\n", "\n") + .replace("\u029e", "\\") } def read_atom(rdr: Reader): Any = { From 130fdf5d189495dff3f455f2c1e29fd28df29725 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 27 Sep 2017 22:08:49 -0500 Subject: [PATCH 0198/1998] Ignore rust/matlab runtime dirs. Typo in TODO. --- .gitignore | 2 ++ docs/TODO | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index a0cf920095..a1651f2bf9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ .bash_history .cache +.cargo .config .mal-history .crystal @@ -79,6 +80,7 @@ lua/linenoise.so lua/mal.lua make/mal.mk mal/mal.mal +matlab/octave-workspace miniMAL/mal.json nim/nimcache* objc/*.d diff --git a/docs/TODO b/docs/TODO index a2ef21b955..7cea51ed2f 100644 --- a/docs/TODO +++ b/docs/TODO @@ -85,7 +85,7 @@ Make: - allow '_' in make variable names - hash-map with space in key string - errors should propagate up from within load-file - - GC: explore using "undefined" directive in Make 3.82 + - GC: explore using "undefine" directive in Make 3.82 Mal: - line numbers in errors From a11a023558c5a660d4d1b1d7d85ff3129d81d828 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 27 Sep 2017 22:10:24 -0500 Subject: [PATCH 0199/1998] ES6: Use ES6 modules. Update node. --- .gitignore | 2 +- Makefile | 2 +- es6/Dockerfile | 7 +-- es6/Makefile | 52 +++++-------------- es6/{core.js => core.mjs} | 18 +++---- es6/{env.js => env.mjs} | 0 es6/node_readline.js | 5 +- es6/package.json | 9 ++-- es6/{printer.js => printer.mjs} | 4 +- es6/{reader.js => reader.mjs} | 4 +- es6/run | 2 +- es6/{step0_repl.js => step0_repl.mjs} | 0 ...ep1_read_print.js => step1_read_print.mjs} | 0 es6/{step2_eval.js => step2_eval.mjs} | 0 es6/{step3_env.js => step3_env.mjs} | 0 es6/{step4_if_fn_do.js => step4_if_fn_do.mjs} | 0 es6/{step5_tco.js => step5_tco.mjs} | 0 es6/{step6_file.js => step6_file.mjs} | 0 es6/{step7_quote.js => step7_quote.mjs} | 0 es6/{step8_macros.js => step8_macros.mjs} | 0 es6/{step9_try.js => step9_try.mjs} | 0 es6/{stepA_mal.js => stepA_mal.mjs} | 0 es6/{types.js => types.mjs} | 34 ++++++------ 23 files changed, 55 insertions(+), 84 deletions(-) rename es6/{core.js => core.mjs} (86%) rename es6/{env.js => env.mjs} (100%) rename es6/{printer.js => printer.mjs} (92%) rename es6/{reader.js => reader.mjs} (96%) rename es6/{step0_repl.js => step0_repl.mjs} (100%) rename es6/{step1_read_print.js => step1_read_print.mjs} (100%) rename es6/{step2_eval.js => step2_eval.mjs} (100%) rename es6/{step3_env.js => step3_env.mjs} (100%) rename es6/{step4_if_fn_do.js => step4_if_fn_do.mjs} (100%) rename es6/{step5_tco.js => step5_tco.mjs} (100%) rename es6/{step6_file.js => step6_file.mjs} (100%) rename es6/{step7_quote.js => step7_quote.mjs} (100%) rename es6/{step8_macros.js => step8_macros.mjs} (100%) rename es6/{step9_try.js => step9_try.mjs} (100%) rename es6/{stepA_mal.js => stepA_mal.mjs} (100%) rename es6/{types.js => types.mjs} (62%) diff --git a/.gitignore b/.gitignore index a1651f2bf9..5ecac391f2 100644 --- a/.gitignore +++ b/.gitignore @@ -52,7 +52,7 @@ erlang/ebin erlang/.rebar erlang/src/*.beam es6/mal.js -es6/build +es6/.esm-cache factor/mal.factor forth/mal.fs fsharp/*.exe diff --git a/Makefile b/Makefile index 4a7b236a6e..8bf6a66f3f 100644 --- a/Makefile +++ b/Makefile @@ -189,7 +189,7 @@ elisp_STEP_TO_PROG = elisp/$($(1)).el elixir_STEP_TO_PROG = elixir/lib/mix/tasks/$($(1)).ex elm_STEP_TO_PROG = elm/$($(1)).js erlang_STEP_TO_PROG = erlang/$($(1)) -es6_STEP_TO_PROG = es6/build/$($(1)).js +es6_STEP_TO_PROG = es6/$($(1)).mjs factor_STEP_TO_PROG = factor/$($(1))/$($(1)).factor forth_STEP_TO_PROG = forth/$($(1)).fs fsharp_STEP_TO_PROG = fsharp/$($(1)).exe diff --git a/es6/Dockerfile b/es6/Dockerfile index 208e7f660e..ddcadb5b86 100644 --- a/es6/Dockerfile +++ b/es6/Dockerfile @@ -25,15 +25,10 @@ WORKDIR /mal RUN apt-get -y install g++ # Add nodesource apt repo config for 7.X -RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - +RUN curl -sL https://deb.nodesource.com/setup_8.x | bash - # Install nodejs RUN apt-get -y install nodejs # Link common name -RUN ln -sf nodejs /usr/bin/node - ENV NPM_CONFIG_CACHE /mal/.npm - -# ES6 -RUN npm install -g babel-cli babel-plugin-transform-es2015-modules-commonjs diff --git a/es6/Makefile b/es6/Makefile index 775b814f26..b88fd2a0d1 100644 --- a/es6/Makefile +++ b/es6/Makefile @@ -1,56 +1,32 @@ -export PATH := $(PATH):node_modules/.bin/ - -BABEL_OPTS = --source-maps true \ - --plugins transform-es2015-modules-commonjs - -SOURCES_BASE = node_readline.js types.js reader.js printer.js -SOURCES_LISP = env.js core.js stepA_mal.js +SOURCES_BASE = node_readline.js types.mjs reader.mjs printer.mjs +SOURCES_LISP = env.mjs core.mjs stepA_mal.mjs SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal +STEPS = step0_repl.mjs step1_read_print.mjs step2_eval.mjs step3_env.mjs \ + step4_if_fn_do.mjs step5_tco.mjs step6_file.mjs \ + step7_quote.mjs step8_macros.mjs step9_try.mjs stepA_mal.mjs -all: node_modules $(foreach s,$(STEPS),build/$(s).js) +all: node_modules dist: mal.js mal -build/%.js: %.js node_modules - @mkdir -p $(dir $@) - babel $(BABEL_OPTS) $< --out-file $@ - @echo >> $@ # workaround node-uglifier bug +node_modules: + npm install + +$(STEPS): node_modules -mal.js: $(foreach s,$(SOURCES),build/$(s)) - node -e 'nu = new (require("node-uglifier"))("./build/stepA_mal.js"); nu.merge().exportToFile("$@")' +mal.js: $(SOURCES) + cat $+ | sed 's/^export //' | grep -v "^import " >> $@ mal: mal.js echo "#!/usr/bin/env node" > $@ cat $< >> $@ chmod +x $@ -STEP0_DEPS = build/node_readline.js -STEP1_DEPS = $(STEP0_DEPS) build/types.js build/reader.js build/printer.js -STEP3_DEPS = $(STEP1_DEPS) build/env.js -STEP4_DEPS = $(STEP3_DEPS) build/core.js - -build/step0_repl.js: $(STEP0_DEPS) -build/step1_read_print.js: $(STEP1_DEPS) -build/step2_eval.js: $(STEP1_DEPS) -build/step3_env.js: $(STEP3_DEPS) -build/step4_if_fn_do.js: $(STEP4_DEPS) -build/step5_tco.js: $(STEP4_DEPS) -build/step6_file.js: $(STEP4_DEPS) -build/step7_quote.js: $(STEP4_DEPS) -build/step8_macros.js: $(STEP4_DEPS) -build/step9_try.js: $(STEP4_DEPS) -build/stepA_mal.js: $(STEP4_DEPS) - - -node_modules: - npm install clean: - rm -f build/* mal.js mal + rm -f mal.js mal + rm -rf node_modules .PHONY: stats tests $(TESTS) diff --git a/es6/core.js b/es6/core.mjs similarity index 86% rename from es6/core.js rename to es6/core.mjs index cd11a8372a..7b9e1f5219 100644 --- a/es6/core.js +++ b/es6/core.mjs @@ -1,5 +1,5 @@ -import { _equal_Q, _clone, _keyword, _keyword_Q, - _list_Q, Vector, _assoc_BANG, _dissoc_BANG, Atom } from './types' +import { _equal_Q, _clone, _keyword, _keyword_Q } from './types' +import { _list_Q, Vector, _assoc_BANG, Atom } from './types' import { pr_str } from './printer' import { readline } from './node_readline' import { read_str } from './reader' @@ -22,16 +22,12 @@ function slurp(f) { } // Sequence functions -function conj(o, ...a) { - return _list_Q(o) ? a.reverse().concat(o) : Vector.from(o.concat(a)) -} - function seq(obj) { if (_list_Q(obj)) { return obj.length > 0 ? obj : null } else if (obj instanceof Vector) { return obj.length > 0 ? Array.from(obj.slice(0)) : null - } else if (typeof obj === "string" && obj[0] !== '\u029e') { + } else if (typeof obj === "string" && !_keyword_Q(obj)) { return obj.length > 0 ? obj.split('') : null } else if (obj === null) { return null @@ -48,7 +44,7 @@ export const core_ns = new Map([ ['nil?', a => a === null], ['true?', a => a === true], ['false?', a => a === false], - ['string?', a => typeof a === "string" && a[0] !== '\u029e'], + ['string?', a => typeof a === "string" && !_keyword_Q(a)], ['symbol', a => Symbol.for(a)], ['symbol?', a => typeof a === 'symbol'], ['keyword', _keyword], @@ -79,7 +75,8 @@ export const core_ns = new Map([ ['hash-map', (...a) => _assoc_BANG(new Map(), ...a)], ['map?', a => a instanceof Map], ['assoc', (m,...a) => _assoc_BANG(_clone(m), ...a)], - ['dissoc', (m,...a) => _dissoc_BANG(_clone(m), ...a)], + ['dissoc', (m,...a) => { let n = _clone(m); a.forEach(k => n.delete(k)); + return n}], ['get', (m,a) => m === null ? null : m.has(a) ? m.get(a) : null], ['contains?', (m,a) => m.has(a)], ['keys', a => Array.from(a.keys())], @@ -96,7 +93,8 @@ export const core_ns = new Map([ ['apply', (f,...a) => f(...a.slice(0, -1).concat(a[a.length-1]))], ['map', (f,a) => Array.from(a.map(x => f(x)))], - ['conj', conj], + ['conj', (s,...a) => _list_Q(s) ? a.reverse().concat(s) + : Vector.from(s.concat(a))], ['seq', seq], ['meta', a => 'meta' in a ? a['meta'] : null], diff --git a/es6/env.js b/es6/env.mjs similarity index 100% rename from es6/env.js rename to es6/env.mjs diff --git a/es6/node_readline.js b/es6/node_readline.js index dd5db0b68e..9e2fb864ba 100644 --- a/es6/node_readline.js +++ b/es6/node_readline.js @@ -13,7 +13,7 @@ var rllib = ffi.Library(RL_LIB, { var rl_history_loaded = false; -export function readline(prompt) { +function readline(prompt) { prompt = prompt || "user> "; if (!rl_history_loaded) { @@ -41,3 +41,6 @@ export function readline(prompt) { return line; }; + +//exports.readline = readline +module.exports = {readline: readline} diff --git a/es6/package.json b/es6/package.json index d836e6d663..627da97fec 100644 --- a/es6/package.json +++ b/es6/package.json @@ -3,11 +3,10 @@ "version": "0.0.1", "description": "Make a Lisp (mal) language implemented in ES6 (ECMAScript 6 / ECMAScript 2015)", "dependencies": { - "ffi": "2.0.x", - "node-uglifier": "0.4.3" + "@std/esm": "^0.11.0", + "ffi": "2.0.x" }, - "devDependencies": { - "babel-cli": "^6.0.0", - "babel-plugin-transform-es2015-modules-commonjs": "*" + "@std/esm": { + "cjs": true } } diff --git a/es6/printer.js b/es6/printer.mjs similarity index 92% rename from es6/printer.js rename to es6/printer.mjs index 18e5d350cb..82230f5d89 100644 --- a/es6/printer.js +++ b/es6/printer.mjs @@ -1,4 +1,4 @@ -import { _symbol, _list_Q, Vector, Atom } from './types' +import { _list_Q, _keyword_Q, Vector, Atom } from './types' export function pr_str(obj, print_readably) { if (typeof print_readably === 'undefined') { print_readably = true } @@ -14,7 +14,7 @@ export function pr_str(obj, print_readably) { } return "{" + ret.join(' ') + "}" } else if (typeof obj === "string") { - if (obj[0] === '\u029e') { + if (_keyword_Q(obj)) { return ':' + obj.slice(1) } else if (_r) { return '"' + obj.replace(/\\/g, "\\\\") diff --git a/es6/reader.js b/es6/reader.mjs similarity index 96% rename from es6/reader.js rename to es6/reader.mjs index fb2c2f2fac..ae23ddf084 100644 --- a/es6/reader.js +++ b/es6/reader.mjs @@ -1,4 +1,4 @@ -import { _keyword, Vector, _assoc_BANG } from './types' +import { _keyword, _assoc_BANG, Vector } from './types'; export class BlankException extends Error {} @@ -66,7 +66,7 @@ function read_list(reader, start, end) { // read vector of tokens function read_vector(reader) { - return Vector.from(read_list(reader, '[', ']')) + return Vector.from(read_list(reader, '[', ']')); } // read hash-map key/value pairs diff --git a/es6/run b/es6/run index 24d7d2b86b..a6c8bf8387 100755 --- a/es6/run +++ b/es6/run @@ -1,2 +1,2 @@ #!/bin/bash -exec node $(dirname $0)/build/${STEP:-stepA_mal}.js "${@}" +exec node -r @std/esm $(dirname $0)/${STEP:-stepA_mal}.mjs "${@}" diff --git a/es6/step0_repl.js b/es6/step0_repl.mjs similarity index 100% rename from es6/step0_repl.js rename to es6/step0_repl.mjs diff --git a/es6/step1_read_print.js b/es6/step1_read_print.mjs similarity index 100% rename from es6/step1_read_print.js rename to es6/step1_read_print.mjs diff --git a/es6/step2_eval.js b/es6/step2_eval.mjs similarity index 100% rename from es6/step2_eval.js rename to es6/step2_eval.mjs diff --git a/es6/step3_env.js b/es6/step3_env.mjs similarity index 100% rename from es6/step3_env.js rename to es6/step3_env.mjs diff --git a/es6/step4_if_fn_do.js b/es6/step4_if_fn_do.mjs similarity index 100% rename from es6/step4_if_fn_do.js rename to es6/step4_if_fn_do.mjs diff --git a/es6/step5_tco.js b/es6/step5_tco.mjs similarity index 100% rename from es6/step5_tco.js rename to es6/step5_tco.mjs diff --git a/es6/step6_file.js b/es6/step6_file.mjs similarity index 100% rename from es6/step6_file.js rename to es6/step6_file.mjs diff --git a/es6/step7_quote.js b/es6/step7_quote.mjs similarity index 100% rename from es6/step7_quote.js rename to es6/step7_quote.mjs diff --git a/es6/step8_macros.js b/es6/step8_macros.mjs similarity index 100% rename from es6/step8_macros.js rename to es6/step8_macros.mjs diff --git a/es6/step9_try.js b/es6/step9_try.mjs similarity index 100% rename from es6/step9_try.js rename to es6/step9_try.mjs diff --git a/es6/stepA_mal.js b/es6/stepA_mal.mjs similarity index 100% rename from es6/stepA_mal.js rename to es6/stepA_mal.mjs diff --git a/es6/types.js b/es6/types.mjs similarity index 62% rename from es6/types.js rename to es6/types.mjs index 458538ff55..d6198b6dce 100644 --- a/es6/types.js +++ b/es6/types.mjs @@ -19,12 +19,19 @@ export function _equal_Q (a, b) { export function _clone(obj, new_meta) { let new_obj = null - if (_list_Q(obj)) { new_obj = obj.slice(0) } - else if (obj instanceof Vector) { new_obj = Vector.from(obj.slice(0)) } - else if (obj instanceof Map) { new_obj = new Map(obj.entries()) } - else if (obj instanceof Function) { new_obj = obj.clone() } - else { throw Error("Invalid clone") } - if (new_meta !== undefined) { new_obj.meta = new_meta } + if (_list_Q(obj)) { + new_obj = obj.slice(0) + } else if (obj instanceof Vector) { + new_obj = Vector.from(obj) + } else if (obj instanceof Map) { + new_obj = new Map(obj.entries()) + } else if (obj instanceof Function) { + let f = (...a) => obj.apply(f, a) // new function instance + new_obj = Object.assign(f, obj) // copy original properties + } else { + throw Error('Unsupported type for clone') + } + if (typeof new_meta !== 'undefined') { new_obj.meta = new_meta } return new_obj } @@ -33,33 +40,26 @@ export function _malfunc(f, ast, env, params, meta=null, ismacro=false) { return Object.assign(f, {ast, env, params, meta, ismacro}) } export const _malfunc_Q = f => f.ast ? true : false -Function.prototype.clone = function() { - let f = (...a) => this.apply(f, a) // new function instance - return Object.assign(f, this) // copy original properties -} // Keywords export const _keyword = obj => _keyword_Q(obj) ? obj : '\u029e' + obj export const _keyword_Q = obj => typeof obj === 'string' && obj[0] === '\u029e' -// Sequence collections +// Lists export const _list_Q = obj => Array.isArray(obj) && !(obj instanceof Vector) -export class Vector extends Array {} +// Vectors +export class Vector extends Array { } +// Maps export function _assoc_BANG(hm, ...args) { if (args.length % 2 === 1) { throw new Error('Odd number of assoc arguments') } - // Use iterator/Array.from when it works for (let i=0; i Date: Sat, 30 Sep 2017 13:14:06 +0200 Subject: [PATCH 0200/1998] fix typo in guide --- process/guide.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/process/guide.md b/process/guide.md index aa996c743d..554c145c5b 100644 --- a/process/guide.md +++ b/process/guide.md @@ -351,7 +351,7 @@ expression support. subclass type. For example, if your language is object oriented, then you can define a top level MalType (in `types.qx`) that all your mal data types inherit from. The MalList type (which also - inherits from MalType) will contains a list/array of other MalTypes. + inherits from MalType) will contain a list/array of other MalTypes. If your language is dynamically typed then you can likely just return a plain list/array of other mal types. From 0ad505e829a6ad0877856c7f6c95ee9f844e96a4 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 9 Oct 2017 00:10:03 +0100 Subject: [PATCH 0201/1998] Step0 (input/output) passes tests * String handling simplified, will not handle very long strings * Memory allocation missing, always using the same buffer currently --- Makefile | 3 +- nasm/Makefile | 3 + nasm/run | 3 + nasm/step0_repl.asm | 326 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 334 insertions(+), 1 deletion(-) create mode 100644 nasm/Makefile create mode 100755 nasm/run create mode 100644 nasm/step0_repl.asm diff --git a/Makefile b/Makefile index 8bf6a66f3f..d88cd89741 100644 --- a/Makefile +++ b/Makefile @@ -81,7 +81,7 @@ DOCKERIZE = IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ elisp elixir elm erlang es6 factor forth fsharp go groovy gst guile haskell \ haxe hy io java js julia kotlin livescript logo lua make mal matlab miniMAL \ - nim objc objpascal ocaml perl perl6 php pil plpgsql plsql powershell ps \ + nasm nim objc objpascal ocaml perl perl6 php pil plpgsql plsql powershell ps \ python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ ts vb vhdl vimscript yorick @@ -212,6 +212,7 @@ make_STEP_TO_PROG = make/$($(1)).mk mal_STEP_TO_PROG = mal/$($(1)).mal matlab_STEP_TO_PROG = matlab/$($(1)).m miniMAL_STEP_TO_PROG = miniMAL/$($(1)).json +nasm_STEP_TO_PROG = nasm/$($(1)) nim_STEP_TO_PROG = nim/$($(1)) objc_STEP_TO_PROG = objc/$($(1)) objpascal_STEP_TO_PROG = objpascal/$($(1)) diff --git a/nasm/Makefile b/nasm/Makefile new file mode 100644 index 0000000000..511d7c665e --- /dev/null +++ b/nasm/Makefile @@ -0,0 +1,3 @@ +step0_repl: + nasm -felf64 step0_repl.asm + ld -o $@ step0_repl.o diff --git a/nasm/run b/nasm/run new file mode 100755 index 0000000000..0ecd249cae --- /dev/null +++ b/nasm/run @@ -0,0 +1,3 @@ +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" + diff --git a/nasm/step0_repl.asm b/nasm/step0_repl.asm new file mode 100644 index 0000000000..decdf4de2e --- /dev/null +++ b/nasm/step0_repl.asm @@ -0,0 +1,326 @@ +;; nasm -felf64 mal.asm && ld mal.o && ./a.out + +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +;; Data structures +;; Memory management is done by having two fixed-size datatypes, +;; Cons and Array. +;; +;; Both Cons and Array have the following in common: +;; a type field at the start, a reference count, followed by data +;; [ type (8) | (8) | refs (16) | data ] + + +;; +STRUC Cons +.typecar: RESB 1 ; Type information for car (8 bit) +.typecdr: RESB 1 ; Type information for cdr (8 bits) +.refcount: RESW 1 ; Number of references to this Cons (16 bit) +.car: RESQ 1 ; First value (64 bit) +.cdr: RESQ 1 ; Second value (64 bit) +.size: ; Total size of struc +ENDSTRUC + + +%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk + +STRUC Array +.type: RESB 1 ; Type information (8 bits) +.control: RESB 1 ; Control data (8 bits) +.refcount: RESW 1 ; Number of references to this Array (16 bit) +.length: RESD 1 ; Number of elements in array (32 bit) +.next RESQ 1 ; Pointer to the next chunk (64 bit) +.data: RESQ array_chunk_len ; Data storage +.size: ; Total size of struc +ENDSTRUC + +;; Type information +%define type_char 1 ; Character type +%define type_integer 2 ; Integer type +%define type_float 3 ; Floating point number +%define type_array 128 ; Last bit tests if array or cons + + + + global _start + +section .data + +str: ISTRUC Array +AT Array.type, db type_char + type_array +AT Array.length, dd 6 +AT Array.data, db 'hello',10 +IEND + +prompt_string: db 10,"user> " ; The string to print at the prompt +.len: equ $ - prompt_string + +error_msg_print_string: db "Error in print string",10 +.len: equ $ - error_msg_print_string + +section .bss + +section .text + +;; ------------------------------------------ +;; Array alloc_array() +;; +;; Returns the address of an Array object in RAX +alloc_array: + mov rax, str + ret + +;; ------------------------------------------- +;; Prints a raw string to stdout +;; String address in rsi, string length in rdx +print_rawstring: + push rax + push rdi + + ; write(1, string, length) + mov rax, 1 ; system call 1 is write + mov rdi, 1 ; file handle 1 is stdout + syscall + + pop rdi + pop rax + + ret + +;; ------------------------------------------ +;; void print_string(char array) +;; Address of the char Array should be in RSI +print_string: + ; Push registers we're going to use + push rax + push rdi + push rdx + push rsi + + ; Check that we have a char array + mov al, [rsi] + cmp al, type_char + type_array + jne .error + + ; write(1, string, length) + mov edx, [rsi + Array.length] ; number of bytes + add rsi, Array.data ; address of raw string to output + call print_rawstring + + ; Restore registers + pop rsi + pop rdx + pop rdi + pop rax + + ret +.error: + ; An error occurred + mov rdx, error_msg_print_string.len ; number of bytes + mov rsi, error_msg_print_string ; address of raw string to output + call print_rawstring + ; exit + jmp quit_error + +;; ------------------------------------------ +;; String itostring(Integer number) +;; +;; Converts an integer to a string (array of chars) +;; +;; Input in RAX +;; Return string address in RAX +itostring: + ; Save registers to restore afterwards + push rcx + push rdx + push rsi + push rdi + + mov rcx, 0 ; counter of how many bytes we need to print in the end + +.divideLoop: + inc rcx ; count each byte to print - number of characters + xor rdx, rdx + mov rsi, 10 + idiv rsi ; divide rax by rsi + add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction + ; Character is now in DL + dec rsp + mov BYTE [rsp], dl ; Put onto stack + + cmp rax, 0 ; can the integer be divided anymore? + jnz .divideLoop ; jump if not zero to the label divideLoop + + ; Get an Array object to put the string into + call alloc_array ; Address in RAX + + ; put length into string + mov [rax + Array.length], ecx + + ; copy data from stack into string + ; Note: Currently this does not handle long strings + mov rdi, rax + add rdi, Array.data ; Address where raw string will go +.copyLoop: + mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient + mov [rdi], BYTE dl + inc rsp + inc rdi + dec rcx + cmp rcx, 0 + jnz .copyLoop + + ; Restore registers + pop rdi + pop rsi + pop rdx + pop rcx + + ret + +;; ---------------------------- +;; int stringtoi(String) +;; +;; Convert a string (char array) to an integer +;; +;; Address of input string is in RSI +;; Output integer in RAX +stringtoi: + + ret + +;------------------------------------------ +; void exit() +; Exit program and restore resources +quit: + mov eax, 60 ; system call 60 is exit + xor rdi, rdi ; exit code 0 + syscall ; invoke operating system to exit + +quit_error: + mov eax, 60 ; system call 60 is exit + mov rdi, 1 ; exit code 1 + syscall + + +;; Takes a string as input and processes it into a form +read: + mov rax, rsi ; Return the input + ret + +;; Evaluates a form +eval: + mov rax, rsi ; Return the input + ret + +;; Prints the result +print: + mov rax, rsi ; Return the input + ret + +;; Read-Eval-Print in sequence +rep_seq: + call read + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call print + mov rsi, rax ; Return value + ret + +;; Read a line from stdin +;; Gets a new string array, fills it until a newline or EOF is reached +;; Returns pointer to string in RAX +read_line: + ; Get an array to put the string into + ; Address in rax + call alloc_array + ; Mark it as a character array (string) + mov BYTE [rax + Array.type], type_char + type_array + + push rax ; Save pointer to string + + ; Read character by character until either newline or end of input + mov ebx, 0 ; Count how many characters read + mov rsi, rax + add rsi, Array.data ; Point to the data +.readLoop: + mov rax, 0 ; sys_read + mov rdi, 0 ; stdin + mov rdx, 1 ; count + syscall + + ; Characters read in RAX + cmp rax, 0 ; end loop if read <= 0 + jle .readLoopEnd + + mov cl, BYTE [rsi] + + cmp cl, 10 ; End if we read a newline + je .readLoopEnd + + cmp cl, 8 ; Backspace? + je .handleBackspace + + cmp cl, 31 ; Below space + jle .readLoop ; Ignore, keep going + + cmp cl, 127 ; DEL or above + jge .readLoop ; Ignore, keep going + + inc ebx + inc rsi ; Move to next point in the array + jmp .readLoop ; Get another character + +.handleBackspace: + ; Check if we've read any characters + cmp ebx, 0 + je .readLoop ; If not, carry on the loop + ; Characters have been read. Remove one + dec ebx + dec rsi + jmp .readLoop +.readLoopEnd: + pop rax ; Restore pointer to string + mov DWORD [rax + Array.length], ebx ; Set string length + ret + + + +_start: + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + mov rdx, prompt_string.len ; number of bytes + mov rsi, prompt_string ; address of raw string to output + call print_rawstring + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + mov rsi, rax ; Put into input of print_string + call print_string + + jmp .mainLoop +.mainLoopEnd: + + ;mov rdx, 1 + ;mov rsi, + ;call print_rawstring + ;inc rsp + + ;mov rax, 1223 + ;call itostring + ;mov rsi, rax + ;call print_string + + jmp quit + From 424b9aa5884be1bc415a587c9bb212b1c11e9106 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 9 Oct 2017 21:46:50 +0200 Subject: [PATCH 0202/1998] Elisp: Do shallow copies in with-meta --- elisp/core.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/elisp/core.el b/elisp/core.el index 28b8e85d12..a684e3f287 100644 --- a/elisp/core.el +++ b/elisp/core.el @@ -223,8 +223,7 @@ (meta . ,(mal-fn (lambda (mal-object) (or (mal-meta mal-object) mal-nil)))) (with-meta . ,(mal-fn (lambda (mal-object meta) - ;; TODO: doesn't work on hashtables - (let ((mal-object* (copy-tree mal-object t))) + (let ((mal-object* (copy-sequence mal-object))) (setf (aref mal-object* 2) meta) mal-object*)))) From 03a374b4705656ec5047770c96786802ef39baa6 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 9 Oct 2017 21:47:11 +0200 Subject: [PATCH 0203/1998] Elisp: Make predicate check stricter --- elisp/types.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/types.el b/elisp/types.el index 8029e5eecf..6abcbd2ad3 100644 --- a/elisp/types.el +++ b/elisp/types.el @@ -18,7 +18,7 @@ (defun ,constructor (&optional value meta) (vector ',name value meta)) (defun ,predicate (arg) - (and (arrayp arg) (eq (aref arg 0) ',name)))))) + (and (vectorp arg) (eq (aref arg 0) ',name)))))) (mal-object nil) (mal-object true) From 59436f1a1208bfafe24809eff4015fbbd54fb683 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 9 Oct 2017 20:23:39 +0000 Subject: [PATCH 0204/1998] Add number?, fn?, macro? in stepA - tests and process guide Ref #298 --- process/guide.md | 4 ++++ process/stepA_mal.txt | 3 +++ tests/stepA_mal.mal | 41 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+) diff --git a/process/guide.md b/process/guide.md index 554c145c5b..455a76e3f1 100644 --- a/process/guide.md +++ b/process/guide.md @@ -1635,6 +1635,10 @@ For extra information read [Peter Seibel's thorough discussion about new vector is returned with the elements added to the end of the given vector. * `string?`: returns true if the parameter is a string. + * `number?`: returns true if the parameter is a number. + * `fn?`: returns true if the parameter is a function (internal or + user-defined). + * `macro?`: returns true if the parameter is a macro. * `seq`: takes a list, vector, string, or nil. If an empty list, empty vector, or empty string ("") is passed in then nil is returned. Otherwise, a list is returned unchanged, a vector is diff --git a/process/stepA_mal.txt b/process/stepA_mal.txt index 431a4b98ee..f16d6e3363 100644 --- a/process/stepA_mal.txt +++ b/process/stepA_mal.txt @@ -87,6 +87,9 @@ ns = {'=: equal?, 'symbol?: symbol?, 'keyword: keyword, 'keyword?: keyword?, + 'number?: number?, + 'fn?: fn?, + 'macro?: macro?, 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), diff --git a/tests/stepA_mal.mal b/tests/stepA_mal.mal index a349c09b6b..5c458e1e3e 100644 --- a/tests/stepA_mal.mal +++ b/tests/stepA_mal.mal @@ -96,6 +96,47 @@ (get @e "bar") ;=>(1 2 3) +;; ------------------------------------------------------------------ +;; TODO move these to optional functionality after adding them to all +;; implementations +;; +;; Testing string? function +(number? 123) +;=>true +(number? -1) +;=>true +(number? nil) +;=>false +(number? false) +;=>false +(number? "123") +;=>false + +;; Testing fn? function +(fn? +) +;=>true +(fn? not) +;=>true +(fn? cond) +;=>false +(fn? "+") +;=>false +(fn? :+) +;=>false + +;; Testing macro? function +(macro? cond) +;=>true +(macro? +) +;=>false +(macro? not) +;=>false +(macro? "+") +;=>false +(macro? :+) +;=>false + +;; ------------------------------------------------------------------ ;>>> soft=True ;>>> optional=True From 2e13db63248c5c1deb7af5af3460a693e87bdfff Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 9 Oct 2017 20:25:08 +0000 Subject: [PATCH 0205/1998] ruby: Add number?, fn?, macro? --- ruby/core.rb | 3 +++ ruby/suggest.mal | 7 +++++++ 2 files changed, 10 insertions(+) create mode 100644 ruby/suggest.mal diff --git a/ruby/core.rb b/ruby/core.rb index 0b68c4a284..0c26c8de55 100644 --- a/ruby/core.rb +++ b/ruby/core.rb @@ -13,6 +13,9 @@ :symbol? => lambda {|a| a.is_a? Symbol}, :keyword => lambda {|a| "\u029e"+a}, :keyword? => lambda {|a| (a.is_a? String) && "\u029e" == a[0]}, + :number? => lambda {|a| a.is_a? Numeric}, + :fn? => lambda {|a| (a.is_a? Proc) && (!(a.is_a? Function) || !a.is_macro)}, + :macro? => lambda {|a| (a.is_a? Function) && a.is_macro}, :"pr-str" => lambda {|*a| a.map {|e| _pr_str(e, true)}.join(" ")}, :str => lambda {|*a| a.map {|e| _pr_str(e, false)}.join("")}, diff --git a/ruby/suggest.mal b/ruby/suggest.mal new file mode 100644 index 0000000000..685a5d1db2 --- /dev/null +++ b/ruby/suggest.mal @@ -0,0 +1,7 @@ +(def! read-args (fn* [args] + (let* [arg (readline "arg> ")] + (if (or (nil? arg) (empty? arg)) + args + (read-args (conj args arg)))))) + +(prn "The args you entered are:" (read-args [])) From 7cecb87a7d3dfd23143ac8556b60cf1cabf562ce Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 9 Oct 2017 20:52:46 +0000 Subject: [PATCH 0206/1998] go, rexx, vimscript, yorick: Add number?, fn?, macro? --- go/src/core/core.go | 20 ++++++++++++++++++++ go/src/types/types.go | 5 +++++ rexx/core.rexx | 12 ++++++++++++ rexx/t.mal | 1 + rexx/types.rexx | 3 +++ vimscript/core.vim | 3 +++ yorick/core.i | 10 ++++++++++ 7 files changed, 54 insertions(+) create mode 100644 rexx/t.mal diff --git a/go/src/core/core.go b/go/src/core/core.go index 646135f046..abbaae8986 100644 --- a/go/src/core/core.go +++ b/go/src/core/core.go @@ -20,6 +20,19 @@ func throw(a []MalType) (MalType, error) { return nil, MalError{a[0]} } +func fn_q(a []MalType) (MalType, error) { + switch f := a[0].(type) { + case MalFunc: + return !f.GetMacro(), nil + case Func: + return true, nil + case func([]MalType) (MalType, error): + return true, nil + default: + return false, nil + } +} + // String functions func pr_str(a []MalType) (MalType, error) { @@ -464,6 +477,13 @@ var NS = map[string]MalType{ "keyword?": func(a []MalType) (MalType, error) { return Keyword_Q(a[0]), nil }, + "number?": func(a []MalType) (MalType, error) { + return Number_Q(a[0]), nil + }, + "fn?": fn_q, + "macro?": func(a []MalType) (MalType, error) { + return MalFunc_Q(a[0]) && a[0].(MalFunc).GetMacro(), nil + }, "pr-str": func(a []MalType) (MalType, error) { return pr_str(a) }, "str": func(a []MalType) (MalType, error) { return str(a) }, diff --git a/go/src/types/types.go b/go/src/types/types.go index d5bff952ac..9d4cb10b5f 100644 --- a/go/src/types/types.go +++ b/go/src/types/types.go @@ -41,6 +41,11 @@ func False_Q(obj MalType) bool { return ok && b == false } +func Number_Q(obj MalType) bool { + _, ok := obj.(int) + return ok +} + // Symbols type Symbol struct { Val string diff --git a/rexx/core.rexx b/rexx/core.rexx index d458fcf03c..2b9c749b07 100644 --- a/rexx/core.rexx +++ b/rexx/core.rexx @@ -34,6 +34,15 @@ mal_keyword: procedure expose values. /* mal_keyword(a) */ mal_keyword?: procedure expose values. /* mal_keyword?(a) */ return new_boolean(keyword?(arg(1))) +mal_number?: procedure expose values. /* mal_number?(a) */ + return new_boolean(number?(arg(1))) + +mal_fn?: procedure expose values. /* mal_fn?(a) */ + return new_boolean(nativefn?(arg(1)) | (func?(arg(1)) & (func_is_macro(arg(1)) \= 1))) + +mal_macro?: procedure expose values. /* mal_macro?(a) */ + return new_boolean(func_macro?(arg(1))) + mal_pr_str: procedure expose values. /* mal_pr_str(...) */ res = "" do i=1 to arg() @@ -439,6 +448,9 @@ get_core_ns: procedure /* get_core_ns() */ "symbol? mal_symbol?" , "keyword mal_keyword" , "keyword? mal_keyword?" , + "number? mal_number?" , + "fn? mal_fn?" , + "macro? mal_macro?" , , "pr-str mal_pr_str" , "str mal_str" , diff --git a/rexx/t.mal b/rexx/t.mal new file mode 100644 index 0000000000..0c27e43547 --- /dev/null +++ b/rexx/t.mal @@ -0,0 +1 @@ +(prn (+ 4 5)) diff --git a/rexx/types.rexx b/rexx/types.rexx index c9b1ad3e9a..ba60256727 100644 --- a/rexx/types.rexx +++ b/rexx/types.rexx @@ -44,6 +44,9 @@ new_number: procedure /* new_number(n) */ n = arg(1) return "numb_" || n +number?: procedure /* number?(obj) */ + return obj_type(arg(1)) == "numb" + new_nil: procedure /* new_nil() */ return "nill_0" diff --git a/vimscript/core.vim b/vimscript/core.vim index f85cd83139..5dfda3307a 100644 --- a/vimscript/core.vim +++ b/vimscript/core.vim @@ -188,6 +188,9 @@ let CoreNs = { \ "string?": NewNativeFnLambda({a -> BoolNew(StringQ(a[0]))}), \ "keyword": NewNativeFnLambda({a -> KeywordNew(a[0].val)}), \ "keyword?": NewNativeFnLambda({a -> BoolNew(KeywordQ(a[0]))}), + \ "number?": NewNativeFnLambda({a -> BoolNew(IntegerQ(a[0]))}), + \ "fn?": NewNativeFnLambda({a -> BoolNew(NativeFunctionQ(a[0]) || FunctionQ(a[0]))}), + \ "macro?": NewNativeFnLambda({a -> BoolNew(MacroQ(a[0]))}), \ "list": NewNativeFnLambda({a -> ListNew(a)}), \ "list?": NewNativeFnLambda({a -> BoolNew(ListQ(a[0]))}), \ "vector": NewNativeFnLambda({a -> VectorNew(a)}), diff --git a/yorick/core.i b/yorick/core.i index c4d6ed447a..38dc622505 100644 --- a/yorick/core.i +++ b/yorick/core.i @@ -11,6 +11,13 @@ func mal_symbol(a) { return MalSymbol(val=a(1)->val); } func mal_symbol_q(a) { return new_boolean(structof(*a(1)) == MalSymbol); } func mal_keyword(a) { return MalKeyword(val=a(1)->val); } func mal_keyword_q(a) { return new_boolean(structof(*a(1)) == MalKeyword); } +func mal_number_q(a) { return new_boolean(structof(*a(1)) == MalNumber); } +func mal_fn_q(a) +{ + if (structof(*a(1)) == MalNativeFunction) return MAL_TRUE; + return new_boolean(structof(*a(1)) == MalFunction && !a(1)->macro); +} +func mal_macro_q(a) { return new_boolean(structof(*a(1)) == MalFunction && a(1)->macro); } func string_helper(a, delimiter, readable) { @@ -298,6 +305,9 @@ h_set, core_ns, "symbol", mal_symbol h_set, core_ns, "symbol?", mal_symbol_q h_set, core_ns, "keyword", mal_keyword h_set, core_ns, "keyword?", mal_keyword_q +h_set, core_ns, "number?", mal_number_q +h_set, core_ns, "fn?", mal_fn_q +h_set, core_ns, "macro?", mal_macro_q h_set, core_ns, "pr-str", mal_pr_str h_set, core_ns, "str", mal_str From 3eb7df5a61926815bedd7fe4cc098ce9550c90bb Mon Sep 17 00:00:00 2001 From: Stephen Thirlwall Date: Tue, 10 Oct 2017 09:45:31 +1100 Subject: [PATCH 0207/1998] cpp makefile uses latest homebrew readline version /usr/local/opt/$package is a symlink to /usr/local/Cellar/$package/$latest_version --- cpp/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cpp/Makefile b/cpp/Makefile index 5e464d51e8..ad20eb8360 100644 --- a/cpp/Makefile +++ b/cpp/Makefile @@ -3,7 +3,7 @@ uname_S := $(shell sh -c 'uname -s 2>/dev/null || echo not') ifeq ($(uname_S),Darwin) # Native build on yosemite. Requires: brew install readline CXX=g++ - READLINE=/usr/local/Cellar/readline/6.3.8 + READLINE=/usr/local/opt/readline INCPATHS=-I$(READLINE)/include LIBPATHS=-L$(READLINE)/lib else From d53749f28e076ff44e4312a48e9689be3586c6c6 Mon Sep 17 00:00:00 2001 From: Stephen Thirlwall Date: Tue, 10 Oct 2017 10:02:09 +1100 Subject: [PATCH 0208/1998] cpp: add number?, fn? and macro? --- cpp/Core.cpp | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/cpp/Core.cpp b/cpp/Core.cpp index 0e02cf8096..6ae1f5eaa0 100644 --- a/cpp/Core.cpp +++ b/cpp/Core.cpp @@ -64,6 +64,7 @@ BUILTIN_ISA("atom?", malAtom); BUILTIN_ISA("keyword?", malKeyword); BUILTIN_ISA("list?", malList); BUILTIN_ISA("map?", malHash); +BUILTIN_ISA("number?", malInteger); BUILTIN_ISA("sequential?", malSequence); BUILTIN_ISA("string?", malString); BUILTIN_ISA("symbol?", malSymbol); @@ -241,6 +242,19 @@ BUILTIN("first") return seq->first(); } +BUILTIN("fn?") +{ + CHECK_ARGS_IS(1); + malValuePtr arg = *argsBegin++; + + // Lambdas are functions, unless they're macros. + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, arg)) { + return mal::boolean(!lambda->isMacro()); + } + // Builtins are functions. + return mal::boolean(DYNAMIC_CAST(malBuiltIn, arg)); +} + BUILTIN("get") { CHECK_ARGS_IS(2); @@ -270,6 +284,15 @@ BUILTIN("keyword") return mal::keyword(":" + token->value()); } +BUILTIN("macro?") +{ + CHECK_ARGS_IS(1); + + // Macros are implemented as lambdas, with a special flag. + const malLambda* lambda = DYNAMIC_CAST(malLambda, *argsBegin); + return mal::boolean((lambda != NULL) && lambda->isMacro()); +} + BUILTIN("meta") { CHECK_ARGS_IS(1); From e21edd83c3c703c747e7e60a1476098c68e9d2e4 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 10 Oct 2017 00:22:10 +0100 Subject: [PATCH 0209/1998] Adding memory allocation, started reader Simple fixed-size memory manager, which uses reference counting and a list of free blocks. Not properly tested yet, particularly the Cons version (linked list) which is more complicated than the Array type. --- nasm/reader.asm | 24 ++ nasm/step1_read_print.asm | 553 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 577 insertions(+) create mode 100644 nasm/reader.asm create mode 100644 nasm/step1_read_print.asm diff --git a/nasm/reader.asm b/nasm/reader.asm new file mode 100644 index 0000000000..e78226de02 --- /dev/null +++ b/nasm/reader.asm @@ -0,0 +1,24 @@ + +section .bss + +;; State of Reader + + +section .text + +read_str: + ; Convert the input string into a list of tokens + call tokenizer + ; RAX now contains address of list of tokens + ret + +;; ----------------------------- +;; list(tokens) tokenizer (string) +;; +;; Input string address in RSI +;; Creates a list of tokens, returns address in RAX +tokenizer: + + ; Get a new + call alloc_array + ret diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm new file mode 100644 index 0000000000..2b2d6d14f8 --- /dev/null +++ b/nasm/step1_read_print.asm @@ -0,0 +1,553 @@ +;; +;; nasm -felf64 step1_read_print.asm && ld step1_read_print.o && ./a.out + +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +;; Data structures +;; Memory management is done by having two fixed-size datatypes, +;; Cons and Array. +;; +;; Both Cons and Array have the following in common: +;; a type field at the start, a reference count, followed by data +;; [ type (8) | (8) | refs (16) | data ] + + +;; +STRUC Cons +.typecar: RESB 1 ; Type information for car (8 bit) +.typecdr: RESB 1 ; Type information for cdr (8 bits) +.refcount: RESW 1 ; Number of references to this Cons (16 bit) +.car: RESQ 1 ; First value (64 bit) +.cdr: RESQ 1 ; Second value (64 bit) +.size: ; Total size of struc +ENDSTRUC + + +%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk + +STRUC Array +.type: RESB 1 ; Type information (8 bits) +.control: RESB 1 ; Control data (8 bits) +.refcount: RESW 1 ; Number of references to this Array (16 bit) +.length: RESD 1 ; Number of elements in array (32 bit) +.next RESQ 1 ; Pointer to the next chunk (64 bit) +.data: RESQ array_chunk_len ; Data storage +.size: ; Total size of struc +ENDSTRUC + +;; Type information +%define type_char 1 ; Character type +%define type_integer 2 ; Integer type +%define type_float 3 ; Floating point number +%define type_atom 64 ; 1 if just an atom, not a list or array +%define type_array 128 ; Last bit tests if array or cons + +%include "reader.asm" + + + global _start + +section .data + +;str: ISTRUC Array +;AT Array.type, db type_char + type_array +;AT Array.length, dd 6 +;AT Array.data, db 'hello',10 +;IEND + +;; ------------------------------------------ +;; Fixed strings for printing + +prompt_string: db 10,"user> " ; The string to print at the prompt +.len: equ $ - prompt_string + +error_msg_print_string: db "Error in print string",10 +.len: equ $ - error_msg_print_string + +error_array_memory_limit: db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 +.len: equ $ - error_array_memory_limit + +error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 +.len: equ $ - error_cons_memory_limit + +;; ------------------------------------------ +;; Memory management +;; +;; For each object (Cons or Array), there is a block of memory (in BSS). +;; When an object is requested it is first taken from the free list +;; If the free list is empty (address 0) then the next object in the block +;; is used, and the heap_x_number counter is incremented. When an object +;; is free'd it is pushed onto the heap_x_free list. + + +%define heap_cons_limit 1 ; Number of cons objects which can be created + +heap_cons_next: dd heap_cons_store ; Address of next cons in memory +heap_cons_free: dq 0 ; Address of start of free list + +%define heap_array_limit 1 ; Number of array objects which can be created + +heap_array_next: dd heap_array_store +heap_array_free: dq 0 + +section .bss + +;; Reserve space to store Cons and Array objects +heap_cons_store: resb heap_cons_limit * Cons.size +.end: ; Address of end of the store + +heap_array_store: resb heap_array_limit * Array.size +.end: + +section .text + +;; ------------------------------------------ +;; Array alloc_array() +;; +;; Returns the address of an Array object in RAX +alloc_array: + + ; Get the address of a free array + mov rax, [heap_array_free] ; Address of the array + + ; Check if it's null + cmp rax, 0 + je .create_array + + mov rbx, [rax + Array.next] ; Get the address of the next array in the linked list + mov [heap_array_free], rbx ; Put this address at the front of the list + jmp .initialise_array + +.create_array: + + ; Get the address of the next Array + mov rax, [heap_array_next] + ; Check if we've reached the end + cmp rax, heap_array_store.end + je .out_of_memory + + mov rbx, rax + add rbx, Array.size ; Address of the next array + mov [heap_array_next], rbx ; for next time + +.initialise_array: + ; Address of Array now in rax + mov BYTE [rax + Array.type], type_array + mov WORD [rax + Array.refcount], 1 ; Only one reference + mov DWORD [rax + Array.length], 0 + mov QWORD [rax + Array.next], 0 ; null next address + + ret + +.out_of_memory: + mov rsi, error_array_memory_limit + mov rdx, error_array_memory_limit.len + call print_rawstring + jmp quit_error + + +;; ------------------------------------------- +;; Decrements the reference count of the array in RSI +;; If the count reaches zero then push the array +;; onto the free list +release_array: + mov ax, WORD [rsi + Array.refcount] + dec ax + mov WORD [rsi + Array.refcount], ax + jz .free ; If the count reaches zero then put on free list + ret + +.free: + ; Get the next field + mov rbx, [rsi + Array.next] + + mov rax, [heap_array_free] ; Get the current head + mov [rsi + Array.next], rax ; Put current head into the "next" field + mov [heap_array_free], rsi ; Push Array onto free list + + cmp rbx, 0 + jne .release_next ; If there is another array, then need to release it + + ret + +.release_next: + ; release the next array + mov rsi, rbx + call release_array + ret + +;; ------------------------------------------ +;; Cons alloc_cons() +;; +;; Returns the address of a Cons object in RAX +alloc_cons: + + ; Get the address of a free cons + mov rax, [heap_cons_free] ; Address of the cons + + ; Check if it's null + cmp rax, 0 + je .create_cons + + mov rbx, [rax + Cons.cdr] ; Get the address of the next cons in the linked list + mov [heap_cons_free], rbx ; Put this address at the front of the list + jmp .initialise_cons + +.create_cons: + + ; Get the address of the next Cons + mov rax, [heap_cons_next] + ; Check if we've reached the end + cmp rax, heap_cons_store.end + je .out_of_memory + + mov rbx, rax + add rbx, Cons.size ; Address of the next cons + mov [heap_cons_next], rbx ; for next time + +.initialise_cons: + ; Address of Cons now in rax + mov BYTE [rax + Cons.typecar], 0 + mov BYTE [rax + Cons.typecdr], 0 + mov WORD [rax + Cons.refcount], 1 ; Only one reference + mov QWORD [rax + Cons.car], 0 + mov QWORD [rax + Cons.cdr], 0 + ret + +.out_of_memory: + mov rsi, error_cons_memory_limit + mov rdx, error_cons_memory_limit.len + call print_rawstring + jmp quit_error + + +;; ------------------------------------------- +;; Decrements the reference count of the cons in RSI +;; If the count reaches zero then push the cons +;; onto the free list +release_cons: + mov ax, WORD [rsi + Cons.refcount] + dec ax + mov WORD [rsi + Cons.refcount], ax + jz .free ; If the count reaches zero then put on free list + ret + +.free: + ; Get and push cdr onto stack + mov rcx, [rsi + Cons.cdr] + push rcx + push rsi + + mov rax, [heap_cons_free] ; Get the current head + mov [rsi + Cons.cdr], rax ; Put current head into the "cdr" field + mov [heap_cons_free], rsi ; Push Cons onto free list + + ; Check if the CAR needs to be released + + mov al, BYTE [rsi+Cons.typecar] + mov bl, type_atom + and bl, al ; bl now zero if a list or array + jnz .free_cdr + + ; Get the address stored in CAR + mov rsi, [rsi + Cons.car] + + ; test if type is array or cons + mov bl, type_array + and bl, al ; bl now zero if cons + jnz .car_array + + ; CAR is a Cons + call release_cons + jmp .free_cdr + +.car_array: + ; CAR is an Array + call release_array + +.free_cdr: + pop rcx ; This was rsi, the original Cons + pop rsi ; This was rcx, the original Cons.cdr + + ; Get the type from the original Cons + mov al, BYTE [rcx+Cons.typecdr] + mov bl, type_atom + and bl, al ; bl now zero if a list or array + jnz .done + + ; test if type is array or cons + mov bl, type_array + and bl, al ; bl now zero if cons + jnz .cdr_array + + ; CAR is a Cons + call release_cons + ret + +.cdr_array: + ; CAR is an Array + call release_array +.done: + ret + + +;; ------------------------------------------- +;; Prints a raw string to stdout +;; String address in rsi, string length in rdx +print_rawstring: + push rax + push rdi + + ; write(1, string, length) + mov rax, 1 ; system call 1 is write + mov rdi, 1 ; file handle 1 is stdout + syscall + + pop rdi + pop rax + + ret + +;; ------------------------------------------ +;; void print_string(char array) +;; Address of the char Array should be in RSI +print_string: + ; Push registers we're going to use + push rax + push rdi + push rdx + push rsi + + ; Check that we have a char array + mov al, [rsi] + cmp al, type_char + type_array + jne .error + + ; write(1, string, length) + mov edx, [rsi + Array.length] ; number of bytes + add rsi, Array.data ; address of raw string to output + call print_rawstring + + ; Restore registers + pop rsi + pop rdx + pop rdi + pop rax + + ret +.error: + ; An error occurred + mov rdx, error_msg_print_string.len ; number of bytes + mov rsi, error_msg_print_string ; address of raw string to output + call print_rawstring + ; exit + jmp quit_error + +;; ------------------------------------------ +;; String itostring(Integer number) +;; +;; Converts an integer to a string (array of chars) +;; +;; Input in RAX +;; Return string address in RAX +itostring: + ; Save registers to restore afterwards + push rcx + push rdx + push rsi + push rdi + + mov rcx, 0 ; counter of how many bytes we need to print in the end + +.divideLoop: + inc rcx ; count each byte to print - number of characters + xor rdx, rdx + mov rsi, 10 + idiv rsi ; divide rax by rsi + add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction + ; Character is now in DL + dec rsp + mov BYTE [rsp], dl ; Put onto stack + + cmp rax, 0 ; can the integer be divided anymore? + jnz .divideLoop ; jump if not zero to the label divideLoop + + ; Get an Array object to put the string into + call alloc_array ; Address in RAX + + ; put length into string + mov [rax + Array.length], ecx + + ; copy data from stack into string + ; Note: Currently this does not handle long strings + mov rdi, rax + add rdi, Array.data ; Address where raw string will go +.copyLoop: + mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient + mov [rdi], BYTE dl + inc rsp + inc rdi + dec rcx + cmp rcx, 0 + jnz .copyLoop + + ; Restore registers + pop rdi + pop rsi + pop rdx + pop rcx + + ret + +;; ---------------------------- +;; int stringtoi(String) +;; +;; Convert a string (char array) to an integer +;; +;; Address of input string is in RSI +;; Output integer in RAX +stringtoi: + + ret + +;------------------------------------------ +; void exit() +; Exit program and restore resources +quit: + mov eax, 60 ; system call 60 is exit + xor rdi, rdi ; exit code 0 + syscall ; invoke operating system to exit + +quit_error: + mov eax, 60 ; system call 60 is exit + mov rdi, 1 ; exit code 1 + syscall + + +;; Takes a string as input and processes it into a form +read: + mov rax, rsi ; Return the input + ret + +;; Evaluates a form +eval: + mov rax, rsi ; Return the input + ret + +;; Prints the result +print: + mov rax, rsi ; Return the input + ret + +;; Read-Eval-Print in sequence +rep_seq: + call read + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call print + mov rsi, rax ; Return value + ret + +;; Read a line from stdin +;; Gets a new string array, fills it until a newline or EOF is reached +;; Returns pointer to string in RAX +read_line: + ; Get an array to put the string into + ; Address in rax + call alloc_array + ; Mark it as a character array (string) + mov BYTE [rax + Array.type], type_char + type_array + + push rax ; Save pointer to string + + ; Read character by character until either newline or end of input + mov ebx, 0 ; Count how many characters read + mov rsi, rax + add rsi, Array.data ; Point to the data +.readLoop: + mov rax, 0 ; sys_read + mov rdi, 0 ; stdin + mov rdx, 1 ; count + syscall + + ; Characters read in RAX + cmp rax, 0 ; end loop if read <= 0 + jle .readLoopEnd + + mov cl, BYTE [rsi] + + cmp cl, 10 ; End if we read a newline + je .readLoopEnd + + cmp cl, 8 ; Backspace? + je .handleBackspace + + cmp cl, 31 ; Below space + jle .readLoop ; Ignore, keep going + + cmp cl, 127 ; DEL or above + jge .readLoop ; Ignore, keep going + + inc ebx + inc rsi ; Move to next point in the array + jmp .readLoop ; Get another character + +.handleBackspace: + ; Check if we've read any characters + cmp ebx, 0 + je .readLoop ; If not, carry on the loop + ; Characters have been read. Remove one + dec ebx + dec rsi + jmp .readLoop +.readLoopEnd: + pop rax ; Restore pointer to string + mov DWORD [rax + Array.length], ebx ; Set string length + ret + + + +_start: + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + mov rdx, prompt_string.len ; number of bytes + mov rsi, prompt_string ; address of raw string to output + call print_rawstring + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release the string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + ;mov rdx, 1 + ;mov rsi, + ;call print_rawstring + ;inc rsp + + ;mov rax, 1223 + ;call itostring + ;mov rsi, rax + ;call print_string + + jmp quit + From 7cabea4f759d0e4c47ff3e7e67050c54d156119e Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 10 Oct 2017 18:29:36 +0200 Subject: [PATCH 0210/1998] elisp, chuck, pil, gst, scheme: Add number?, fn?, macro? --- chuck/core.ck | 7 +++++-- chuck/step2_eval.ck | 1 + chuck/step3_env.ck | 1 + chuck/step4_if_fn_do.ck | 2 +- chuck/step5_tco.ck | 2 +- chuck/step6_file.ck | 2 +- chuck/step7_quote.ck | 2 +- chuck/step8_macros.ck | 2 +- chuck/step9_try.ck | 2 +- chuck/types/subr/MalIsFn.ck | 15 +++++++++++++++ chuck/types/subr/MalIsMacro.ck | 14 ++++++++++++++ chuck/types/subr/MalIsNumber.ck | 14 ++++++++++++++ elisp/core.el | 10 ++++++++++ gst/core.st | 9 +++++++++ pil/core.l | 3 +++ scheme/lib/core.sld | 4 ++++ 16 files changed, 82 insertions(+), 8 deletions(-) create mode 100644 chuck/types/subr/MalIsFn.ck create mode 100644 chuck/types/subr/MalIsMacro.ck create mode 100644 chuck/types/subr/MalIsNumber.ck diff --git a/chuck/core.ck b/chuck/core.ck index 7c1eb63388..7f3f21fb8c 100644 --- a/chuck/core.ck +++ b/chuck/core.ck @@ -14,10 +14,10 @@ public class Core "nth", "first", "rest", "throw", "apply", "map", - "nil?", "true?", "false?", "symbol?", "keyword?", "vector?", "map?", + "nil?", "true?", "false?", "number?", "symbol?", "keyword?", "vector?", "map?", "symbol", "keyword", "vector", "hash-map", "assoc", "dissoc", "get", "contains?", "keys", "vals", - "sequential?", + "sequential?", "fn?", "macro?", "readline", "meta", "with-meta", "time-ms", "conj", "string?", "seq"] @=> Core.names; MalSubr ns[0] @=> Core.ns; @@ -67,6 +67,7 @@ new MalMap @=> Core.ns["map"]; new MalIsNil @=> Core.ns["nil?"]; new MalIsTrue @=> Core.ns["true?"]; new MalIsFalse @=> Core.ns["false?"]; +new MalIsNumber @=> Core.ns["number?"]; new MalIsSymbol @=> Core.ns["symbol?"]; new MalIsKeyword @=> Core.ns["keyword?"]; new MalIsVector @=> Core.ns["vector?"]; @@ -85,6 +86,8 @@ new MalKeys @=> Core.ns["keys"]; new MalVals @=> Core.ns["vals"]; new MalSequential @=> Core.ns["sequential?"]; +new MalIsFn @=> Core.ns["fn?"]; +new MalIsMacro @=> Core.ns["macro?"]; new MalReadline @=> Core.ns["readline"]; new MalMeta @=> Core.ns["meta"]; diff --git a/chuck/step2_eval.ck b/chuck/step2_eval.ck index 6795783153..d3753ae8ce 100644 --- a/chuck/step2_eval.ck +++ b/chuck/step2_eval.ck @@ -17,6 +17,7 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck diff --git a/chuck/step3_env.ck b/chuck/step3_env.ck index 2d2b1bae1f..7c0bb7cd31 100644 --- a/chuck/step3_env.ck +++ b/chuck/step3_env.ck @@ -17,6 +17,7 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck diff --git a/chuck/step4_if_fn_do.ck b/chuck/step4_if_fn_do.ck index 09c0ae5667..16a4cd91e5 100644 --- a/chuck/step4_if_fn_do.ck +++ b/chuck/step4_if_fn_do.ck @@ -17,10 +17,10 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck // @import core.ck -// @import func.ck fun MalObject READ(string input) { diff --git a/chuck/step5_tco.ck b/chuck/step5_tco.ck index da2a23008f..cc07f5f780 100644 --- a/chuck/step5_tco.ck +++ b/chuck/step5_tco.ck @@ -17,10 +17,10 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck // @import core.ck -// @import func.ck fun MalObject READ(string input) { diff --git a/chuck/step6_file.ck b/chuck/step6_file.ck index 0102daad5d..f9c5a4b583 100644 --- a/chuck/step6_file.ck +++ b/chuck/step6_file.ck @@ -17,10 +17,10 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck // @import core.ck -// @import func.ck fun MalObject READ(string input) { diff --git a/chuck/step7_quote.ck b/chuck/step7_quote.ck index c89d91d604..d1aef647e7 100644 --- a/chuck/step7_quote.ck +++ b/chuck/step7_quote.ck @@ -17,10 +17,10 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck // @import core.ck -// @import func.ck fun MalObject READ(string input) { diff --git a/chuck/step8_macros.ck b/chuck/step8_macros.ck index a9020ea681..09b3a54ffe 100644 --- a/chuck/step8_macros.ck +++ b/chuck/step8_macros.ck @@ -17,10 +17,10 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck // @import core.ck -// @import func.ck fun MalObject READ(string input) { diff --git a/chuck/step9_try.ck b/chuck/step9_try.ck index a95cb5a935..c040462929 100644 --- a/chuck/step9_try.ck +++ b/chuck/step9_try.ck @@ -17,10 +17,10 @@ // @import reader.ck // @import printer.ck // @import env.ck +// @import func.ck // @import types/MalSubr.ck // @import types/subr/*.ck // @import core.ck -// @import func.ck fun MalObject READ(string input) { diff --git a/chuck/types/subr/MalIsFn.ck b/chuck/types/subr/MalIsFn.ck new file mode 100644 index 0000000000..a3df6131f7 --- /dev/null +++ b/chuck/types/subr/MalIsFn.ck @@ -0,0 +1,15 @@ +public class MalIsFn extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "subr" || ( args[0].type == "func" && + !(args[0]$Func).isMacro ) ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/chuck/types/subr/MalIsMacro.ck b/chuck/types/subr/MalIsMacro.ck new file mode 100644 index 0000000000..1ed2fc73a2 --- /dev/null +++ b/chuck/types/subr/MalIsMacro.ck @@ -0,0 +1,14 @@ +public class MalIsMacro extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "func" && (args[0]$Func).isMacro ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/chuck/types/subr/MalIsNumber.ck b/chuck/types/subr/MalIsNumber.ck new file mode 100644 index 0000000000..09231ceff8 --- /dev/null +++ b/chuck/types/subr/MalIsNumber.ck @@ -0,0 +1,14 @@ +public class MalIsNumber extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "int" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/elisp/core.el b/elisp/core.el index 28b8e85d12..a9ecbd4315 100644 --- a/elisp/core.el +++ b/elisp/core.el @@ -177,6 +177,7 @@ (true? . ,(mal-fn (lambda (arg) (if (mal-true-p arg) mal-true mal-false)))) (false? . ,(mal-fn (lambda (arg) (if (mal-false-p arg) mal-true mal-false)))) + (number? . ,(mal-fn (lambda (arg) (if (mal-number-p arg) mal-true mal-false)))) (symbol? . ,(mal-fn (lambda (arg) (if (mal-symbol-p arg) mal-true mal-false)))) (keyword? . ,(mal-fn (lambda (arg) (if (mal-keyword-p arg) mal-true mal-false)))) (string? . ,(mal-fn (lambda (arg) (if (mal-string-p arg) mal-true mal-false)))) @@ -193,6 +194,15 @@ (mal-map map))))) (sequential? . ,(mal-fn 'mal-seq-p)) + (fn? . ,(mal-fn (lambda (arg) (if (or (mal-fn-p arg) + (and (mal-func-p arg) + (not (mal-func-macro-p arg)))) + mal-true + mal-false)))) + (macro? . ,(mal-fn (lambda (arg) (if (and (mal-func-p arg) + (mal-func-macro-p arg)) + mal-true + mal-false)))) (get . ,(mal-fn (lambda (map key) (if (mal-map-p map) (or (gethash key (mal-value map)) mal-nil) mal-nil)))) (contains? . ,(mal-fn (lambda (map key) (if (gethash key (mal-value map)) mal-true mal-false)))) diff --git a/gst/core.st b/gst/core.st index d1c52de0ce..bb85438c80 100644 --- a/gst/core.st +++ b/gst/core.st @@ -195,6 +195,8 @@ Core Ns at: #'true?' put: (Fn new: [ :args | Core coerce: [ args first type = #true ] ]). Core Ns at: #'false?' put: (Fn new: [ :args | Core coerce: [ args first type = #false ] ]). +Core Ns at: #'number?' put: + (Fn new: [ :args | Core coerce: [ args first type = #number ] ]). Core Ns at: #'symbol?' put: (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]). Core Ns at: #'keyword?' put: @@ -208,6 +210,13 @@ Core Ns at: #'map?' put: Core Ns at: #'sequential?' put: (Fn new: [ :args | Core coerce: [ args first type = #list or: [ args first type = #vector ] ] ]). +Core Ns at: #'fn?' put: + (Fn new: [ :args | Core coerce: [ args first type = #fn or: + [ args first type = #func and: + [ args first isMacro not ] ] ] ]). +Core Ns at: #'macro?' put: + (Fn new: [ :args | Core coerce: [ args first type = #func and: + [ args first isMacro ] ] ]). Core Ns at: #symbol put: (Fn new: [ :args | MALSymbol new: args first value asSymbol ]). diff --git a/pil/core.l b/pil/core.l index 5a22963b2c..0ef572c948 100644 --- a/pil/core.l +++ b/pil/core.l @@ -146,12 +146,15 @@ (nil? . `(MAL-fn '((X) (if (= (MAL-type X) 'nil) *MAL-true *MAL-false)))) (true? . `(MAL-fn '((X) (if (= (MAL-type X) 'true) *MAL-true *MAL-false)))) (false? . `(MAL-fn '((X) (if (= (MAL-type X) 'false) *MAL-true *MAL-false)))) + (number? . `(MAL-fn '((X) (if (= (MAL-type X) 'number) *MAL-true *MAL-false)))) (symbol? . `(MAL-fn '((X) (if (= (MAL-type X) 'symbol) *MAL-true *MAL-false)))) (keyword? . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) *MAL-true *MAL-false)))) (string? . `(MAL-fn '((X) (if (= (MAL-type X) 'string) *MAL-true *MAL-false)))) (vector? . `(MAL-fn '((X) (if (= (MAL-type X) 'vector) *MAL-true *MAL-false)))) (map? . `(MAL-fn '((X) (if (= (MAL-type X) 'map) *MAL-true *MAL-false)))) (sequential? . `(MAL-fn '((X) (if (MAL-seq? X) *MAL-true *MAL-false)))) + (fn? . `(MAL-fn '((X) (if (or (= (MAL-type X) 'fn) (and (= (MAL-type X) 'func) (not (get X 'is-macro)))) *MAL-true *MAL-false)))) + (macro? . `(MAL-fn '((X) (if (and (= (MAL-type X) 'func) (get X 'is-macro)) *MAL-true *MAL-false)))) (symbol . `(MAL-fn '((Name) (MAL-symbol (MAL-value Name))))) (keyword . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) X (MAL-keyword (MAL-value X)))))) diff --git a/scheme/lib/core.sld b/scheme/lib/core.sld index b6cfbe33fc..4d615b8d0e 100644 --- a/scheme/lib/core.sld +++ b/scheme/lib/core.sld @@ -244,6 +244,7 @@ (nil? . ,(lambda (x) (coerce (eq? x mal-nil)))) (true? . ,(lambda (x) (coerce (eq? x mal-true)))) (false? . ,(lambda (x) (coerce (eq? x mal-false)))) + (number? . ,(lambda (x) (coerce (mal-instance-of? x 'number)))) (string? . ,(lambda (x) (coerce (mal-instance-of? x 'string)))) (symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol)))) (symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x))))) @@ -256,6 +257,9 @@ (sequential? . ,(lambda (x) (coerce (and (mal-object? x) (memq (mal-type x) '(list vector)))))) + (fn? . ,(lambda (x) (coerce (or (procedure? x) + (and (func? x) (not (func-macro? x))))))) + (macro? . ,(lambda (x) (coerce (and (func? x) (func-macro? x))))) (assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs)))) (dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys)))) From 9e1b17522935b7e58a6762729e6fa1fd4ae3ac00 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Wed, 11 Oct 2017 10:28:04 +0200 Subject: [PATCH 0211/1998] js, lua, perl, python, racket: Add number?, fn?, macro? --- js/core.js | 3 +++ js/types.js | 6 ++++++ lua/core.lua | 3 +++ lua/types.lua | 11 +++++++++++ perl/core.pm | 5 ++++- perl/types.pm | 6 +++++- python/core.py | 5 +++++ python/mal_types.py | 4 +++- racket/core.rkt | 5 +++++ 9 files changed, 45 insertions(+), 3 deletions(-) diff --git a/js/core.js b/js/core.js index 01dad97c50..9eb3ca43ca 100644 --- a/js/core.js +++ b/js/core.js @@ -194,11 +194,14 @@ var ns = {'type': types._obj_type, 'nil?': types._nil_Q, 'true?': types._true_Q, 'false?': types._false_Q, + 'number?': types._number_Q, 'string?': types._string_Q, 'symbol': types._symbol, 'symbol?': types._symbol_Q, 'keyword': types._keyword, 'keyword?': types._keyword_Q, + 'fn?': types._fn_Q, + 'macro?': types._macro_Q, 'pr-str': pr_str, 'str': str, diff --git a/js/types.js b/js/types.js index 6e7f196b05..0fb324e711 100644 --- a/js/types.js +++ b/js/types.js @@ -88,6 +88,7 @@ function _clone (obj) { function _nil_Q(a) { return a === null ? true : false; } function _true_Q(a) { return a === true ? true : false; } function _false_Q(a) { return a === false ? true : false; } +function _number_Q(obj) { return typeof obj === 'number'; } function _string_Q(obj) { return typeof obj === 'string' && obj[0] !== '\u029e'; } @@ -136,6 +137,8 @@ Function.prototype.clone = function() { } return temp; }; +function _fn_Q(obj) { return _function_Q(obj) && !obj._ismacro_; } +function _macro_Q(obj) { return _function_Q(obj) && !!obj._ismacro_; } // Lists @@ -205,6 +208,7 @@ exports._clone = types._clone = _clone; exports._nil_Q = types._nil_Q = _nil_Q; exports._true_Q = types._true_Q = _true_Q; exports._false_Q = types._false_Q = _false_Q; +exports._number_Q = types._number_Q = _number_Q; exports._string_Q = types._string_Q = _string_Q; exports._symbol = types._symbol = _symbol; exports._symbol_Q = types._symbol_Q = _symbol_Q; @@ -212,6 +216,8 @@ exports._keyword = types._keyword = _keyword; exports._keyword_Q = types._keyword_Q = _keyword_Q; exports._function = types._function = _function; exports._function_Q = types._function_Q = _function_Q; +exports._fn_Q = types._fn_Q = _fn_Q; +exports._macro_Q = types._macro_Q = _macro_Q; exports._list = types._list = _list; exports._list_Q = types._list_Q = _list_Q; exports._vector = types._vector = _vector; diff --git a/lua/core.lua b/lua/core.lua index 3376b09dce..8c8d2c54ec 100644 --- a/lua/core.lua +++ b/lua/core.lua @@ -240,11 +240,14 @@ M.ns = { ['nil?'] = function(a) return a==Nil end, ['true?'] = function(a) return a==true end, ['false?'] = function(a) return a==false end, + ['number?'] = function(a) return types._number_Q(a) end, symbol = function(a) return types.Symbol:new(a) end, ['symbol?'] = function(a) return types._symbol_Q(a) end, ['string?'] = function(a) return types._string_Q(a) and "\177" ~= string.sub(a,1,1) end, keyword = function(a) return "\177"..a end, ['keyword?'] = function(a) return types._keyword_Q(a) end, + ['fn?'] = function(a) return types._fn_Q(a) end, + ['macro?'] = function(a) return types._macro_Q(a) end, ['pr-str'] = pr_str, str = str, diff --git a/lua/types.lua b/lua/types.lua index 0155451247..62bc6a2fa9 100644 --- a/lua/types.lua +++ b/lua/types.lua @@ -94,6 +94,11 @@ function M._nil_Q(obj) return obj == Nil end +-- Numbers +function M._number_Q(obj) + return type(obj) == "number" +end + -- Strings function M._string_Q(obj) return type(obj) == "string" @@ -186,6 +191,12 @@ end function M._malfunc_Q(obj) return utils.instanceOf(obj, M.MalFunc) end +function M._fn_Q(obj) + return type(obj) == "function" or (M._malfunc_Q(obj) and not obj.ismacro) +end +function M._macro_Q(obj) + return M._malfunc_Q(obj) and obj.ismacro +end -- Atoms diff --git a/perl/core.pm b/perl/core.pm index 7810ab38ab..8c51ae2342 100644 --- a/perl/core.pm +++ b/perl/core.pm @@ -8,7 +8,7 @@ use Time::HiRes qw(time); use readline; use types qw(_sequential_Q _equal_Q _clone $nil $true $false _nil_Q _true_Q _false_Q - _symbol _symbol_Q _string_Q _keyword _keyword_Q _list_Q _vector_Q + _number_Q _symbol _symbol_Q _string_Q _keyword _keyword_Q _list_Q _vector_Q _sub_Q _function_Q _hash_map _hash_map_Q _assoc_BANG _dissoc_BANG _atom_Q); use reader qw(read_str); use printer qw(_pr_str); @@ -217,11 +217,14 @@ our $core_ns = { 'nil?' => sub { _nil_Q($_[0]->nth(0)) ? $true : $false }, 'true?' => sub { _true_Q($_[0]->nth(0)) ? $true : $false }, 'false?' => sub { _false_Q($_[0]->nth(0)) ? $true : $false }, + 'number?' => sub { _number_Q($_[0]->nth(0)) ? $true : $false }, 'symbol' => sub { Symbol->new(${$_[0]->nth(0)}) }, 'symbol?' => sub { _symbol_Q($_[0]->nth(0)) ? $true : $false }, 'string?' => sub { _string_Q($_[0]->nth(0)) ? $true : $false }, 'keyword' => sub { _keyword(${$_[0]->nth(0)}) }, 'keyword?' => sub { _keyword_Q($_[0]->nth(0)) ? $true : $false }, + 'fn?' => sub { (_sub_Q($_[0]->nth(0)) || (_function_Q($_[0]->nth(0)) && !$_[0]->nth(0)->{ismacro})) ? $true : $false }, + 'macro?' => sub { (_function_Q($_[0]->nth(0)) && $_[0]->nth(0)->{ismacro}) ? $true : $false }, 'pr-str' => sub { pr_str($_[0]) }, 'str' => sub { str($_[0]) }, diff --git a/perl/types.pm b/perl/types.pm index 4e80f3f495..4eba2b3e22 100644 --- a/perl/types.pm +++ b/perl/types.pm @@ -6,7 +6,7 @@ use feature qw(switch); use Exporter 'import'; our @EXPORT_OK = qw(_sequential_Q _equal_Q _clone $nil $true $false _nil_Q _true_Q _false_Q - _symbol _symbol_Q _string_Q _keyword _keyword_Q _list_Q _vector_Q + _number_Q _symbol _symbol_Q _string_Q _keyword _keyword_Q _list_Q _vector_Q _sub_Q _function_Q _hash_map _hash_map_Q _assoc_BANG _dissoc_BANG _atom_Q); use Data::Dumper; @@ -103,6 +103,7 @@ sub _false_Q { return $_[0] eq $false } package Integer; sub new { my $class = shift; bless \do { my $x=$_[0] }, $class } } +sub _number_Q { (ref $_[0]) =~ /^Integer/ } { @@ -213,6 +214,9 @@ sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ } } } +sub _sub_Q { (ref $_[0]) =~ /^CODE/ } +sub _function_Q { (ref $_[0]) =~ /^Function/ } + # FunctionRef diff --git a/python/core.py b/python/core.py index 5e1e963163..86a7ec8eb0 100644 --- a/python/core.py +++ b/python/core.py @@ -128,11 +128,16 @@ def swap_BANG(atm,f,*args): 'nil?': types._nil_Q, 'true?': types._true_Q, 'false?': types._false_Q, + 'number?': types._number_Q, 'string?': types._string_Q, 'symbol': types._symbol, 'symbol?': types._symbol_Q, 'keyword': types._keyword, 'keyword?': types._keyword_Q, + 'fn?': lambda x: (types._function_Q(x) and not hasattr(x, '_ismacro_')), + 'macro?': lambda x: (types._function_Q(x) and + hasattr(x, '_ismacro_') and + x._ismacro_), 'pr-str': pr_str, 'str': do_str, diff --git a/python/mal_types.py b/python/mal_types.py index 7c5e30c183..32c42e1d69 100644 --- a/python/mal_types.py +++ b/python/mal_types.py @@ -68,6 +68,7 @@ def _string_Q(exp): return len(exp) == 0 or exp[0] != _u("\u029e") else: return False +def _number_Q(exp): return type(exp) == int # Symbols class Symbol(str): pass @@ -93,7 +94,8 @@ def fn(*args): fn.__ast__ = ast fn.__gen_env__ = lambda args: Env(env, params, args) return fn -def _function_Q(f): return type(f) == type(function_Q) +def _function_Q(f): + return callable(f) # lists class List(list): diff --git a/racket/core.rkt b/racket/core.rkt index 2602f98169..e7cc53d5a7 100644 --- a/racket/core.rkt +++ b/racket/core.rkt @@ -57,11 +57,16 @@ 'nil? _nil? 'true? (lambda (x) (eq? x #t)) 'false? (lambda (x) (eq? x #f)) + 'number? number? 'symbol (lambda (s) (if (symbol? s) s (string->symbol s))) 'symbol? symbol? 'string? _string? 'keyword (lambda (s) (if (_keyword? s) s (_keyword s))) 'keyword? _keyword? + 'fn? (lambda (s) (if (malfunc? s) + (not (malfunc-macro? s)) + (procedure? s))) + 'macro? (lambda (s) (and (malfunc? s) (malfunc-macro? s))) 'pr-str (lambda a (pr_lst a #t " ")) 'str (lambda a (pr_lst a #f "")) From 5bbc7a1fb89d03467ab53b3810ca2ba501798da4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 11 Oct 2017 15:57:07 -0400 Subject: [PATCH 0212/1998] bash, basic: add number?, fn?, and macro? --- bash/core.sh | 10 ++- bash/step2_eval.sh | 3 +- bash/step3_env.sh | 5 +- bash/step4_if_fn_do.sh | 7 +- bash/step5_tco.sh | 7 +- bash/step6_file.sh | 7 +- bash/step7_quote.sh | 7 +- bash/step8_macros.sh | 4 +- bash/step9_try.sh | 6 +- bash/stepA_mal.sh | 8 +- basic/core.in.bas | 171 ++++++++++++++++++++++------------------- 11 files changed, 131 insertions(+), 104 deletions(-) diff --git a/bash/core.sh b/bash/core.sh index 99cc98c8ff..154592ff22 100644 --- a/bash/core.sh +++ b/bash/core.sh @@ -92,14 +92,14 @@ prn () { local res="" for x in "${@}"; do _pr_str "${x}" yes; res="${res} ${r}"; done echo "${res:1}" - r="${__nil}"; + r="${__nil}"; } println () { local res="" for x in "${@}"; do _pr_str "${x}"; res="${res} ${r}"; done echo "${res:1}" - r="${__nil}"; + r="${__nil}"; } readline () { @@ -119,7 +119,8 @@ slurp () { # Function functions -function? () { _function? "${1}" && r="${__true}" || r="${__false}"; } +function? () { _function? "${1}" && [ -z "${ANON["${1}_ismacro_"]}" ] && r="${__true}" || r="${__false}"; } +macro? () { _function? "${1}" && [ "${ANON["${1}_ismacro_"]}" ] && r="${__true}" || r="${__false}"; } # List functions @@ -364,6 +365,9 @@ declare -A core_ns=( [symbol?]=symbol? [keyword]=keyword [keyword?]=keyword? + [number?]=number? + [fn?]=function? + [macro?]=macro? [pr-str]=pr_str [str]=str diff --git a/bash/step2_eval.sh b/bash/step2_eval.sh index de8054fb11..15083b937e 100755 --- a/bash/step2_eval.sh +++ b/bash/step2_eval.sh @@ -48,9 +48,10 @@ EVAL () { EVAL_AST "${ast}" "${env}" return fi - _empty? "${ast}" && r="${ast}" && return # apply list + _empty? "${ast}" && r="${ast}" && return + EVAL_AST "${ast}" "${env}" [[ "${__ERROR}" ]] && return 1 local el="${r}" diff --git a/bash/step3_env.sh b/bash/step3_env.sh index 850ec0354b..2200c8362c 100755 --- a/bash/step3_env.sh +++ b/bash/step3_env.sh @@ -48,9 +48,10 @@ EVAL () { EVAL_AST "${ast}" "${env}" return fi - _empty? "${ast}" && r="${ast}" && return # apply list + _empty? "${ast}" && r="${ast}" && return + _nth "${ast}" 0; local a0="${r}" _nth "${ast}" 1; local a1="${r}" _nth "${ast}" 2; local a2="${r}" @@ -59,7 +60,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" diff --git a/bash/step4_if_fn_do.sh b/bash/step4_if_fn_do.sh index 16e745f75a..e701e9fb25 100755 --- a/bash/step4_if_fn_do.sh +++ b/bash/step4_if_fn_do.sh @@ -49,9 +49,10 @@ EVAL () { EVAL_AST "${ast}" "${env}" return fi - _empty? "${ast}" && r="${ast}" && return # apply list + _empty? "${ast}" && r="${ast}" && return + _nth "${ast}" 0; local a0="${r}" _nth "${ast}" 1; local a1="${r}" _nth "${ast}" 2; local a2="${r}" @@ -60,7 +61,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -91,7 +92,7 @@ EVAL () { EVAL "${a2}" "${env}" fi return ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" return ;; *) EVAL_AST "${ast}" "${env}" diff --git a/bash/step5_tco.sh b/bash/step5_tco.sh index fa5c7b8b68..e7eda09a7b 100755 --- a/bash/step5_tco.sh +++ b/bash/step5_tco.sh @@ -50,9 +50,10 @@ EVAL () { EVAL_AST "${ast}" "${env}" return fi - _empty? "${ast}" && r="${ast}" && return # apply list + _empty? "${ast}" && r="${ast}" && return + _nth "${ast}" 0; local a0="${r}" _nth "${ast}" 1; local a1="${r}" _nth "${ast}" 2; local a2="${r}" @@ -61,7 +62,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -99,7 +100,7 @@ EVAL () { fi # Continue loop ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" \ "${a2}" "${env}" "${a1}" return ;; diff --git a/bash/step6_file.sh b/bash/step6_file.sh index 1fe855b326..d1e7f11854 100755 --- a/bash/step6_file.sh +++ b/bash/step6_file.sh @@ -50,9 +50,10 @@ EVAL () { EVAL_AST "${ast}" "${env}" return fi - _empty? "${ast}" && r="${ast}" && return # apply list + _empty? "${ast}" && r="${ast}" && return + _nth "${ast}" 0; local a0="${r}" _nth "${ast}" 1; local a1="${r}" _nth "${ast}" 2; local a2="${r}" @@ -61,7 +62,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -99,7 +100,7 @@ EVAL () { fi # Continue loop ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" \ "${a2}" "${env}" "${a1}" return ;; diff --git a/bash/step7_quote.sh b/bash/step7_quote.sh index dc7401c028..c90074c1c0 100755 --- a/bash/step7_quote.sh +++ b/bash/step7_quote.sh @@ -87,9 +87,10 @@ EVAL () { EVAL_AST "${ast}" "${env}" return fi - _empty? "${ast}" && r="${ast}" && return # apply list + _empty? "${ast}" && r="${ast}" && return + _nth "${ast}" 0; local a0="${r}" _nth "${ast}" 1; local a1="${r}" _nth "${ast}" 2; local a2="${r}" @@ -98,7 +99,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -144,7 +145,7 @@ EVAL () { fi # Continue loop ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" \ "${a2}" "${env}" "${a1}" return ;; diff --git a/bash/step8_macros.sh b/bash/step8_macros.sh index 3675684c25..d86cdd64cf 100755 --- a/bash/step8_macros.sh +++ b/bash/step8_macros.sh @@ -132,7 +132,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -187,7 +187,7 @@ EVAL () { fi # Continue loop ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" \ "${a2}" "${env}" "${a1}" return ;; diff --git a/bash/step9_try.sh b/bash/step9_try.sh index 01efd85801..7567050a01 100755 --- a/bash/step9_try.sh +++ b/bash/step9_try.sh @@ -132,7 +132,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -162,7 +162,7 @@ EVAL () { macroexpand) MACROEXPAND "${a1}" "${env}" return ;; - try*) EVAL "${a1}" "${env}" + try__STAR__) EVAL "${a1}" "${env}" [[ -z "${__ERROR}" ]] && return _nth "${a2}" 0; local a20="${r}" if [ "${ANON["${a20}"]}" == "catch__STAR__" ]; then @@ -200,7 +200,7 @@ EVAL () { fi # Continue loop ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" \ "${a2}" "${env}" "${a1}" return ;; diff --git a/bash/stepA_mal.sh b/bash/stepA_mal.sh index fecaef61c2..f7f3e2f0cc 100755 --- a/bash/stepA_mal.sh +++ b/bash/stepA_mal.sh @@ -132,7 +132,7 @@ EVAL () { [[ "${__ERROR}" ]] && return 1 ENV_SET "${env}" "${a1}" "${r}" return ;; - let*) ENV "${env}"; local let_env="${r}" + let__STAR__) ENV "${env}"; local let_env="${r}" local let_pairs=(${ANON["${a1}"]}) local idx=0 #echo "let: [${let_pairs[*]}] for ${a2}" @@ -162,7 +162,7 @@ EVAL () { macroexpand) MACROEXPAND "${a1}" "${env}" return ;; - sh*) EVAL "${a1}" "${env}" + sh__STAR__) EVAL "${a1}" "${env}" local output="" local line="" while read line; do @@ -170,7 +170,7 @@ EVAL () { done < <(eval ${ANON["${r}"]}) _string "${output%\\n}" return ;; - try*) EVAL "${a1}" "${env}" + try__STAR__) EVAL "${a1}" "${env}" [[ -z "${__ERROR}" ]] && return _nth "${a2}" 0; local a20="${r}" if [ "${ANON["${a20}"]}" == "catch__STAR__" ]; then @@ -208,7 +208,7 @@ EVAL () { fi # Continue loop ;; - fn*) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ EVAL \"${a2}\" \"\${r}\"" \ "${a2}" "${env}" "${a1}" return ;; diff --git a/basic/core.in.bas b/basic/core.in.bas index d8b7a5025a..009d81ab7f 100644 --- a/basic/core.in.bas +++ b/basic/core.in.bas @@ -14,9 +14,9 @@ SUB APPLY APPLY_FUNCTION: REM regular function - IF Z%(F+1)<60 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE + IF Z%(F+1)<64 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>60 THEN CALL DO_TCO_FUNCTION + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION GOTO APPLY_DONE APPLY_MAL_FUNCTION: @@ -45,7 +45,7 @@ SUB DO_TCO_FUNCTION B=Z%(Z%(AR+1)+2) REM PRINT "F:"+STR$(F)+", Z%(F):"+STR$(Z%(F))+", G:"+STR$(G) - ON G-60 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG + ON G-64 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG DO_APPLY: F=A @@ -174,20 +174,22 @@ DO_FUNCTION: REM Switch on the function number REM MEMORY DEBUGGING: REM IF G>59 THEN ER=-1:E$="unknown function"+STR$(G):RETURN - ON INT(G/10)+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_59 + ON INT(G/10)+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_59,DO_60_69 DO_1_9: ON G GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q,DO_KEYWORD DO_10_19: - ON G-9 GOTO DO_KEYWORD_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP,DO_LT,DO_LTE + ON G-9 GOTO DO_KEYWORD_Q,DO_NUMBER_Q,DO_FN_Q,DO_MACRO_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE DO_20_29: - ON G-19 GOTO DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS,DO_LIST,DO_LIST_Q,DO_VECTOR + ON G-19 GOTO DO_SLURP,DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS DO_30_39: - ON G-29 GOTO DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS,DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q + ON G-29 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS DO_40_49: - ON G-39 GOTO DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_CONJ,DO_SEQ,DO_WITH_META + ON G-39 GOTO DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT DO_50_59: - ON G-49 GOTO DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE,DO_PR_MEMORY_SUMMARY + ON G-49 GOTO DO_CONJ,DO_SEQ,DO_WITH_META,DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE + DO_60_69: + ON G-59 GOTO DO_PR_MEMORY_SUMMARY DO_EQUAL_Q: GOSUB EQUAL_Q @@ -233,6 +235,18 @@ DO_FUNCTION: IF MID$(S$(A1),1,1)<>CHR$(127) THEN GOTO RETURN_TRUE_FALSE R=1 GOTO RETURN_TRUE_FALSE + DO_NUMBER_Q: + GOSUB TYPE_A + R=T=2 + GOTO RETURN_TRUE_FALSE + DO_FN_Q: + GOSUB TYPE_A + R=T=9 OR T=10 + GOTO RETURN_TRUE_FALSE + DO_MACRO_Q: + GOSUB TYPE_A + R=T=11 + GOTO RETURN_TRUE_FALSE DO_PR_STR: AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ @@ -512,16 +526,6 @@ DO_FUNCTION: Z%(A+1)=R RETURN - REM DO_PR_MEMORY: - REM P1=ZT:P2=-1:GOSUB PR_MEMORY - REM RETURN - DO_PR_MEMORY_SUMMARY: - REM GOSUB PR_MEMORY_SUMMARY - GOSUB PR_MEMORY_SUMMARY_SMALL - R=0 - GOTO INC_REF_R - RETURN - DO_EVAL: Q=E:GOSUB PUSH_Q: REM push/save environment E=D:CALL EVAL @@ -533,6 +537,16 @@ DO_FUNCTION: GOSUB READ_FILE RETURN + REM DO_PR_MEMORY: + REM P1=ZT:P2=-1:GOSUB PR_MEMORY + REM RETURN + DO_PR_MEMORY_SUMMARY: + REM GOSUB PR_MEMORY_SUMMARY + GOSUB PR_MEMORY_SUMMARY_SMALL + R=0 + GOTO INC_REF_R + RETURN + INIT_CORE_SET_FUNCTION: T=9:L=A:GOSUB ALLOC: REM native function C=R:GOSUB ENV_SET_S @@ -555,65 +569,68 @@ INIT_CORE_NS: B$="symbol?":GOSUB INIT_CORE_SET_FUNCTION: REM A=8 B$="keyword":GOSUB INIT_CORE_SET_FUNCTION: REM A=9 B$="keyword?":GOSUB INIT_CORE_SET_FUNCTION: REM A=10 - - B$="pr-str":GOSUB INIT_CORE_SET_FUNCTION: REM A=11 - B$="str":GOSUB INIT_CORE_SET_FUNCTION: REM A=12 - B$="prn":GOSUB INIT_CORE_SET_FUNCTION: REM A=13 - B$="println":GOSUB INIT_CORE_SET_FUNCTION: REM A=14 - B$="read-string":GOSUB INIT_CORE_SET_FUNCTION: REM A=15 - B$="readline":GOSUB INIT_CORE_SET_FUNCTION: REM A=16 - B$="slurp":GOSUB INIT_CORE_SET_FUNCTION: REM A=17 - - B$="<":GOSUB INIT_CORE_SET_FUNCTION: REM A=18 - B$="<=":GOSUB INIT_CORE_SET_FUNCTION: REM A=19 - B$=">":GOSUB INIT_CORE_SET_FUNCTION: REM A=20 - B$=">=":GOSUB INIT_CORE_SET_FUNCTION: REM A=21 - B$="+":GOSUB INIT_CORE_SET_FUNCTION: REM A=22 - B$="-":GOSUB INIT_CORE_SET_FUNCTION: REM A=23 - B$="*":GOSUB INIT_CORE_SET_FUNCTION: REM A=24 - B$="/":GOSUB INIT_CORE_SET_FUNCTION: REM A=25 - B$="time-ms":GOSUB INIT_CORE_SET_FUNCTION: REM A=26 - - B$="list":GOSUB INIT_CORE_SET_FUNCTION: REM A=27 - B$="list?":GOSUB INIT_CORE_SET_FUNCTION: REM A=28 - B$="vector":GOSUB INIT_CORE_SET_FUNCTION: REM A=29 - B$="vector?":GOSUB INIT_CORE_SET_FUNCTION: REM A=30 - B$="hash-map":GOSUB INIT_CORE_SET_FUNCTION: REM A=31 - B$="map?":GOSUB INIT_CORE_SET_FUNCTION: REM A=32 - B$="assoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=33 - B$="dissoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=34 - B$="get":GOSUB INIT_CORE_SET_FUNCTION: REM A=35 - B$="contains?":GOSUB INIT_CORE_SET_FUNCTION: REM A=36 - B$="keys":GOSUB INIT_CORE_SET_FUNCTION: REM A=37 - B$="vals":GOSUB INIT_CORE_SET_FUNCTION: REM A=38 - - B$="sequential?":GOSUB INIT_CORE_SET_FUNCTION: REM A=39 - B$="cons":GOSUB INIT_CORE_SET_FUNCTION: REM A=40 - B$="concat":GOSUB INIT_CORE_SET_FUNCTION: REM A=41 - B$="nth":GOSUB INIT_CORE_SET_FUNCTION: REM A=42 - B$="first":GOSUB INIT_CORE_SET_FUNCTION: REM A=43 - B$="rest":GOSUB INIT_CORE_SET_FUNCTION: REM A=44 - B$="empty?":GOSUB INIT_CORE_SET_FUNCTION: REM A=45 - B$="count":GOSUB INIT_CORE_SET_FUNCTION: REM A=46 - - B$="conj":GOSUB INIT_CORE_SET_FUNCTION: REM A=47 - B$="seq":GOSUB INIT_CORE_SET_FUNCTION: REM A=48 - - B$="with-meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=49 - B$="meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=50 - B$="atom":GOSUB INIT_CORE_SET_FUNCTION: REM A=51 - B$="atom?":GOSUB INIT_CORE_SET_FUNCTION: REM A=52 - B$="deref":GOSUB INIT_CORE_SET_FUNCTION: REM A=53 - B$="reset!":GOSUB INIT_CORE_SET_FUNCTION: REM A=54 - - B$="eval":GOSUB INIT_CORE_SET_FUNCTION: REM A=55 - B$="read-file":GOSUB INIT_CORE_SET_FUNCTION: REM A=56 - B$="pr-memory-summary":GOSUB INIT_CORE_SET_FUNCTION: REM A=57 + B$="number?":GOSUB INIT_CORE_SET_FUNCTION: REM A=11 + B$="fn?":GOSUB INIT_CORE_SET_FUNCTION: REM A=12 + B$="macro?":GOSUB INIT_CORE_SET_FUNCTION: REM A=13 + + B$="pr-str":GOSUB INIT_CORE_SET_FUNCTION: REM A=14 + B$="str":GOSUB INIT_CORE_SET_FUNCTION: REM A=15 + B$="prn":GOSUB INIT_CORE_SET_FUNCTION: REM A=16 + B$="println":GOSUB INIT_CORE_SET_FUNCTION: REM A=17 + B$="read-string":GOSUB INIT_CORE_SET_FUNCTION: REM A=18 + B$="readline":GOSUB INIT_CORE_SET_FUNCTION: REM A=19 + B$="slurp":GOSUB INIT_CORE_SET_FUNCTION: REM A=20 + + B$="<":GOSUB INIT_CORE_SET_FUNCTION: REM A=21 + B$="<=":GOSUB INIT_CORE_SET_FUNCTION: REM A=22 + B$=">":GOSUB INIT_CORE_SET_FUNCTION: REM A=23 + B$=">=":GOSUB INIT_CORE_SET_FUNCTION: REM A=24 + B$="+":GOSUB INIT_CORE_SET_FUNCTION: REM A=25 + B$="-":GOSUB INIT_CORE_SET_FUNCTION: REM A=26 + B$="*":GOSUB INIT_CORE_SET_FUNCTION: REM A=27 + B$="/":GOSUB INIT_CORE_SET_FUNCTION: REM A=28 + B$="time-ms":GOSUB INIT_CORE_SET_FUNCTION: REM A=29 + + B$="list":GOSUB INIT_CORE_SET_FUNCTION: REM A=30 + B$="list?":GOSUB INIT_CORE_SET_FUNCTION: REM A=31 + B$="vector":GOSUB INIT_CORE_SET_FUNCTION: REM A=32 + B$="vector?":GOSUB INIT_CORE_SET_FUNCTION: REM A=33 + B$="hash-map":GOSUB INIT_CORE_SET_FUNCTION: REM A=34 + B$="map?":GOSUB INIT_CORE_SET_FUNCTION: REM A=35 + B$="assoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=36 + B$="dissoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=37 + B$="get":GOSUB INIT_CORE_SET_FUNCTION: REM A=38 + B$="contains?":GOSUB INIT_CORE_SET_FUNCTION: REM A=39 + B$="keys":GOSUB INIT_CORE_SET_FUNCTION: REM A=40 + B$="vals":GOSUB INIT_CORE_SET_FUNCTION: REM A=41 + + B$="sequential?":GOSUB INIT_CORE_SET_FUNCTION: REM A=42 + B$="cons":GOSUB INIT_CORE_SET_FUNCTION: REM A=43 + B$="concat":GOSUB INIT_CORE_SET_FUNCTION: REM A=44 + B$="nth":GOSUB INIT_CORE_SET_FUNCTION: REM A=45 + B$="first":GOSUB INIT_CORE_SET_FUNCTION: REM A=46 + B$="rest":GOSUB INIT_CORE_SET_FUNCTION: REM A=47 + B$="empty?":GOSUB INIT_CORE_SET_FUNCTION: REM A=48 + B$="count":GOSUB INIT_CORE_SET_FUNCTION: REM A=49 + + B$="conj":GOSUB INIT_CORE_SET_FUNCTION: REM A=50 + B$="seq":GOSUB INIT_CORE_SET_FUNCTION: REM A=51 + + B$="with-meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=52 + B$="meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=53 + B$="atom":GOSUB INIT_CORE_SET_FUNCTION: REM A=54 + B$="atom?":GOSUB INIT_CORE_SET_FUNCTION: REM A=55 + B$="deref":GOSUB INIT_CORE_SET_FUNCTION: REM A=56 + B$="reset!":GOSUB INIT_CORE_SET_FUNCTION: REM A=57 + + B$="eval":GOSUB INIT_CORE_SET_FUNCTION: REM A=58 + B$="read-file":GOSUB INIT_CORE_SET_FUNCTION: REM A=59 + B$="pr-memory-summary":GOSUB INIT_CORE_SET_FUNCTION: REM A=60 REM these are in DO_TCO_FUNCTION - A=61 - B$="apply":GOSUB INIT_CORE_SET_FUNCTION: REM A=61 - B$="map":GOSUB INIT_CORE_SET_FUNCTION: REM A=62 - B$="swap!":GOSUB INIT_CORE_SET_FUNCTION: REM A=63 + A=65 + B$="apply":GOSUB INIT_CORE_SET_FUNCTION: REM A=65 + B$="map":GOSUB INIT_CORE_SET_FUNCTION: REM A=66 + B$="swap!":GOSUB INIT_CORE_SET_FUNCTION: REM A=67 RETURN From 2d3ea9330ef0d308e1c98684d03c25043bd2235c Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 11 Oct 2017 23:29:29 +0100 Subject: [PATCH 0213/1998] Clarifying types, tidying object release code Changed how types of containers and content are marked, and how these map onto MAL types. Simplified object release code, since data type is always now stored with the data. --- nasm/step1_read_print.asm | 156 +++++++++++++++++++++++++++----------- 1 file changed, 111 insertions(+), 45 deletions(-) diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 2b2d6d14f8..9855c53cbb 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -6,15 +6,65 @@ ;; ;; Data structures +;; =============== +;; ;; Memory management is done by having two fixed-size datatypes, ;; Cons and Array. ;; ;; Both Cons and Array have the following in common: ;; a type field at the start, a reference count, followed by data ;; [ type (8) | (8) | refs (16) | data ] - - +;; +;; +;; Type bit fields +;; --------------- +;; +;; The 8-bit type fields describe the Block, Container and Content type. +;; +;; The Block type is used for memory management, to determine the kind of memory block +;; The Container type indicates the data structure that the Cons or Array block is being used to represent +;; The Content type indicates the raw type of the data in the content +;; +;; Block type [1 bit]: +;; 0 0 - Cons memory block +;; 1 1 - Array memory block ;; +;; Container type [3 bits]: +;; 0 0 - Value (single boxed value for Cons blocks, vector for Array blocks). +;; 2 1 - List (value followed by pointer). Only for Cons blocks +;; 4 2 - Symbol (special char array). Only for Array blocks +;; 6 3 - Keyword +;; 8 4 - Map +;; 10 5 - Function +;; +;; Content type [4 bits]: +;; 0 0 - Nil +;; 16 1 - Bool +;; 32 2 - Char +;; 48 3 - Int +;; 64 4 - Float +;; 80 5 - Pointer (memory address) +;; +;; These represent MAL data types as follows: +;; +;; MAL type Block Container Content +;; --------- | -------- | ---------- | --------- +;; integer Cons Value Int +;; symbol Array Symbol Char +;; list Cons List Any +;; nil Cons Value Nil +;; true Cons Value Bool (1) +;; false Cons Value Bool (0) +;; string Array Value Char +;; keyword Array Keyword Char +;; vector Array Value Int/Float +;; hash-map Array Map Pointer (?TBD) +;; atom Cons Value Pointer +;; + +;; Cons type. +;; Used to store either a single value with type information +;; or a pair of (value, Pointer or Nil) to represent a list STRUC Cons .typecar: RESB 1 ; Type information for car (8 bit) .typecdr: RESB 1 ; Type information for cdr (8 bits) @@ -38,12 +88,38 @@ STRUC Array ENDSTRUC ;; Type information -%define type_char 1 ; Character type -%define type_integer 2 ; Integer type -%define type_float 3 ; Floating point number -%define type_atom 64 ; 1 if just an atom, not a list or array -%define type_array 128 ; Last bit tests if array or cons +%define block_mask 1 ; LSB for block type +%define container_mask 2 + 4 + 8 ; Next three bits for container type +%define content_mask 16 + 32 + 64 + 128 ; Four bits for content type + +;; Block types +%define block_cons 0 +%define block_array 1 + +;; Container types +%define container_value 0 +%define container_list 2 +%define container_symbol 4 +%define container_keyword 6 +%define container_map 8 +%define container_function 10 + +;; Content type +%define content_nil 0 +%define content_bool 16 +%define content_char 32 +%define content_int 48 +%define content_float 64 +%define content_pointer 80 ; Memory pointer (to Cons or Array) +%define content_function 96 ; Function pointer + +;; Common combinations for MAL types +%define maltype_integer (block_cons + container_value + content_int) +%define maltype_string (block_array + container_value + content_char) +%define maltype_symbol (block_array + container_symbol + content_char) + + %include "reader.asm" @@ -52,11 +128,11 @@ ENDSTRUC section .data ;str: ISTRUC Array -;AT Array.type, db type_char + type_array +;AT Array.type, db maltype_string ;AT Array.length, dd 6 ;AT Array.data, db 'hello',10 ;IEND - + ;; ------------------------------------------ ;; Fixed strings for printing @@ -102,7 +178,7 @@ heap_array_store: resb heap_array_limit * Array.size .end: section .text - + ;; ------------------------------------------ ;; Array alloc_array() ;; @@ -134,7 +210,7 @@ alloc_array: .initialise_array: ; Address of Array now in rax - mov BYTE [rax + Array.type], type_array + mov BYTE [rax + Array.type], block_array mov WORD [rax + Array.refcount], 1 ; Only one reference mov DWORD [rax + Array.length], 0 mov QWORD [rax + Array.next], 0 ; null next address @@ -237,8 +313,8 @@ release_cons: .free: ; Get and push cdr onto stack mov rcx, [rsi + Cons.cdr] - push rcx - push rsi + push rcx ; Content of CDR + push rsi ; Original Cons object being released mov rax, [heap_cons_free] ; Get the current head mov [rsi + Cons.cdr], rax ; Put current head into the "cdr" field @@ -247,51 +323,41 @@ release_cons: ; Check if the CAR needs to be released mov al, BYTE [rsi+Cons.typecar] - mov bl, type_atom - and bl, al ; bl now zero if a list or array - jnz .free_cdr + and al, content_mask ; Test content type + cmp al, content_pointer + jne .free_cdr ; Jump if CAR not pointer + ; CAR is a pointer to either a Cons or Array ; Get the address stored in CAR mov rsi, [rsi + Cons.car] - - ; test if type is array or cons - mov bl, type_array - and bl, al ; bl now zero if cons - jnz .car_array - - ; CAR is a Cons - call release_cons - jmp .free_cdr - -.car_array: - ; CAR is an Array - call release_array - + call release_object .free_cdr: pop rcx ; This was rsi, the original Cons pop rsi ; This was rcx, the original Cons.cdr ; Get the type from the original Cons mov al, BYTE [rcx+Cons.typecdr] - mov bl, type_atom - and bl, al ; bl now zero if a list or array - jnz .done + and al, content_mask ; Test content type + cmp al, content_pointer + jne .done + + call release_object +.done: + ret - ; test if type is array or cons - mov bl, type_array - and bl, al ; bl now zero if cons - jnz .cdr_array - ; CAR is a Cons +;; Releases either a Cons or Array +;; Address of object in RSI +release_object: + mov al, BYTE [rsi] ; Get first byte + and al, block_mask ; Test block type + cmp al, block_array ; Test if it's an array + je .array call release_cons ret - -.cdr_array: - ; CAR is an Array +.array: call release_array -.done: ret - ;; ------------------------------------------- ;; Prints a raw string to stdout @@ -322,7 +388,7 @@ print_string: ; Check that we have a char array mov al, [rsi] - cmp al, type_char + type_array + cmp al, maltype_string jne .error ; write(1, string, length) @@ -459,7 +525,7 @@ read_line: ; Address in rax call alloc_array ; Mark it as a character array (string) - mov BYTE [rax + Array.type], type_char + type_array + mov BYTE [rax + Array.type], maltype_string push rax ; Save pointer to string From 2df92e06552b0366bfdad1a6a55b7081ca3be763 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 11 Oct 2017 21:18:50 -0400 Subject: [PATCH 0214/1998] c, rpython, vhdl: add number?, fn?, and macro? --- c/core.c | 20 ++++++++++++++++++-- c/core.h | 2 +- rpython/core.py | 6 ++++++ vhdl/core.vhdl | 21 +++++++++++++++++++++ 4 files changed, 46 insertions(+), 3 deletions(-) diff --git a/c/core.c b/c/core.c index 55e048ee8b..3cfbb2e420 100644 --- a/c/core.c +++ b/c/core.c @@ -26,7 +26,7 @@ MalVal *equal_Q(MalVal *a, MalVal *b) { } -// Scalar functions +// Misc predicates MalVal *nil_Q(MalVal *seq) { return seq->type & MAL_NIL ? &mal_true : &mal_false; } MalVal *true_Q(MalVal *seq) { return seq->type & MAL_TRUE ? &mal_true : &mal_false; } @@ -38,6 +38,19 @@ MalVal *string_Q(MalVal *seq) { return &mal_false; } } +MalVal *number_Q(MalVal *obj) { + return obj->type & MAL_INTEGER || obj->type & MAL_FLOAT + ? &mal_true + : &mal_false; +} +MalVal *fn_Q(MalVal *obj) { + return (obj->type & MAL_FUNCTION_C || obj->type & MAL_FUNCTION_MAL) && + !obj->ismacro + ? &mal_true + : &mal_false; +} +MalVal *macro_Q(MalVal *obj) { return obj->ismacro ? &mal_true : &mal_false; } + // Symbol functions @@ -492,7 +505,7 @@ MalVal *swap_BANG(MalVal *args) { -core_ns_entry core_ns[58] = { +core_ns_entry core_ns[61] = { {"=", (void*(*)(void*))equal_Q, 2}, {"throw", (void*(*)(void*))throw, 1}, {"nil?", (void*(*)(void*))nil_Q, 1}, @@ -503,6 +516,9 @@ core_ns_entry core_ns[58] = { {"symbol?", (void*(*)(void*))symbol_Q, 1}, {"keyword", (void*(*)(void*))keyword, 1}, {"keyword?", (void*(*)(void*))keyword_Q, 1}, + {"number?", (void*(*)(void*))number_Q, 1}, + {"fn?", (void*(*)(void*))fn_Q, 1}, + {"macro?", (void*(*)(void*))macro_Q, 1}, {"pr-str", (void*(*)(void*))pr_str, -1}, {"str", (void*(*)(void*))str, -1}, diff --git a/c/core.h b/c/core.h index 9d612a66f0..4c8909b67f 100644 --- a/c/core.h +++ b/c/core.h @@ -10,6 +10,6 @@ typedef struct { int arg_cnt; } core_ns_entry; -extern core_ns_entry core_ns[58]; +extern core_ns_entry core_ns[61]; #endif diff --git a/rpython/core.py b/rpython/core.py index 5539a89963..5e7a12fb96 100644 --- a/rpython/core.py +++ b/rpython/core.py @@ -38,6 +38,9 @@ def symbol(args): def symbol_Q(args): return wrap_tf(types._symbol_Q(args[0])) def keyword(args): return types._keyword(args[0]) def keyword_Q(args): return wrap_tf(types._keyword_Q(args[0])) +def number_Q(args): return wrap_tf(types._int_Q(args[0])) +def function_Q(args): return wrap_tf(types._function_Q(args[0]) and not args[0].ismacro) +def macro_Q(args): return wrap_tf(types._function_Q(args[0]) and args[0].ismacro) # String functions @@ -375,6 +378,9 @@ def swap_BANG(args): 'symbol?': symbol_Q, 'keyword': keyword, 'keyword?': keyword_Q, + 'number?': number_Q, + 'fn?': function_Q, + 'macro?': macro_Q, 'pr-str': pr_str, 'str': do_str, diff --git a/vhdl/core.vhdl b/vhdl/core.vhdl index d95f6a2bda..00b18e0f1c 100644 --- a/vhdl/core.vhdl +++ b/vhdl/core.vhdl @@ -66,6 +66,21 @@ package body core is new_boolean(args.seq_val(0).val_type = mal_keyword, result); end procedure fn_keyword_q; + procedure fn_number_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_number, result); + end procedure fn_number_q; + + procedure fn_function_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean((args.seq_val(0).val_type = mal_fn and not args.seq_val(0).func_val.f_is_macro) or args.seq_val(0).val_type = mal_nativefn, result); + end procedure fn_function_q; + + procedure fn_macro_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_fn and args.seq_val(0).func_val.f_is_macro, result); + end procedure fn_macro_q; + procedure fn_pr_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is variable s: line; begin @@ -533,6 +548,9 @@ package body core is elsif f.all = "symbol?" then fn_symbol_q(args, result, err); elsif f.all = "keyword" then fn_keyword(args, result, err); elsif f.all = "keyword?" then fn_keyword_q(args, result, err); + elsif f.all = "number?" then fn_number_q(args, result, err); + elsif f.all = "fn?" then fn_function_q(args, result, err); + elsif f.all = "macro?" then fn_macro_q(args, result, err); elsif f.all = "pr-str" then fn_pr_str(args, result, err); elsif f.all = "str" then fn_str(args, result, err); elsif f.all = "prn" then fn_prn(args, result, err); @@ -609,6 +627,9 @@ package body core is define_core_function(e, "symbol?"); define_core_function(e, "keyword"); define_core_function(e, "keyword?"); + define_core_function(e, "number?"); + define_core_function(e, "fn?"); + define_core_function(e, "macro?"); define_core_function(e, "pr-str"); define_core_function(e, "str"); define_core_function(e, "prn"); From f5bb2941f6751213c2f7d4ea4da9d2fb6abe2b17 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 12 Oct 2017 18:14:38 -0400 Subject: [PATCH 0215/1998] coffee, clojure, cs: add number?, fn?, and macro? --- clojure/src/mal/core.cljc | 3 +++ coffee/core.coffee | 3 +++ coffee/types.coffee | 1 + cs/core.cs | 12 ++++++++++++ 4 files changed, 19 insertions(+) diff --git a/clojure/src/mal/core.cljc b/clojure/src/mal/core.cljc index 103348929d..283c9a3907 100644 --- a/clojure/src/mal/core.cljc +++ b/clojure/src/mal/core.cljc @@ -39,6 +39,9 @@ ['symbol? symbol?] ['keyword keyword] ['keyword? keyword?] + ['number? number?] + ['fn? (fn [o] (if (and (fn? o) (not (:ismacro (meta o)))) true false))] + ['macro? (fn [o] (if (and (fn? o) (:ismacro (meta o))) true false))] ['pr-str pr-str] ['str printer/_str] diff --git a/coffee/core.coffee b/coffee/core.coffee index bbe8c38c17..518a4c8259 100644 --- a/coffee/core.coffee +++ b/coffee/core.coffee @@ -47,6 +47,9 @@ exports.ns = { 'symbol?': types._symbol_Q, 'keyword': types._keyword, 'keyword?': types._keyword_Q, + 'number?': (a) -> typeof a == 'number', + 'fn?': (a) -> typeof a == 'function' and not types._macro_Q(a), + 'macro?': types._macro_Q, 'pr-str': (a...) -> a.map((exp) -> _pr_str(exp,true)).join(" "), 'str': (a...) -> a.map((exp) -> _pr_str(exp,false)).join(""), diff --git a/coffee/types.coffee b/coffee/types.coffee index 0f5666c7c0..5252281762 100644 --- a/coffee/types.coffee +++ b/coffee/types.coffee @@ -83,6 +83,7 @@ E._function = (evalfn, ast, env, params) -> fn.__ismacro__ = false fn E._function_Q = _function_Q = (o) -> !!o.__ast__ +E._macro_Q = _macro_Q = (o) -> _function_Q(o) and o.__ismacro__ # Lists E._list_Q = _list_Q = (o) -> Array.isArray(o) && !o.__isvector__ diff --git a/cs/core.cs b/cs/core.cs index 590a0de13b..9bb7a7ab87 100644 --- a/cs/core.cs +++ b/cs/core.cs @@ -65,6 +65,15 @@ public class core { } } ); + static MalFunc number_Q = new MalFunc( + a => a[0] is MalInt ? True : False); + + static MalFunc function_Q = new MalFunc( + a => a[0] is MalFunc && !((MalFunc)a[0]).isMacro() ? True : False); + + static MalFunc macro_Q = new MalFunc( + a => a[0] is MalFunc && ((MalFunc)a[0]).isMacro() ? True : False); + // Number functions static MalFunc time_ms = new MalFunc( @@ -325,6 +334,9 @@ public class core { {"string?", string_Q}, {"keyword", keyword}, {"keyword?", keyword_Q}, + {"number?", number_Q}, + {"fn?", function_Q}, + {"macro?", macro_Q}, {"pr-str", pr_str}, {"str", str}, From 365bc24cffd0d23432ac99caf15b90940cfe7e1f Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 12 Oct 2017 23:59:13 +0100 Subject: [PATCH 0216/1998] Work on tokenizer Not complete yet, but should recognise special characters and strings (mostly). String code not complete yet, since it won't handle long strings correctly (no chaining of Arrays). --- nasm/reader.asm | 223 ++++++++++++++++++++++++++++++++++++-- nasm/step1_read_print.asm | 4 +- 2 files changed, 219 insertions(+), 8 deletions(-) diff --git a/nasm/reader.asm b/nasm/reader.asm index e78226de02..818c680ca8 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -1,15 +1,224 @@ -section .bss - -;; State of Reader - section .text +;; Read a string into memory as a form (nested lists and atoms) +;; Note: In this implementation the tokenizer is not done separately +;; +;; Input: Address of string (char array) in RSI +;; read_str: - ; Convert the input string into a list of tokens - call tokenizer - ; RAX now contains address of list of tokens + + +;; Initialise the tokenizer +tokenizer_init: + ; Put start of data array into rax + mov rax, rsi + add rax, Array.data + ; Put end of data array into rbx + mov ebx, [rsi + Array.length] ; Length of array, zero-extended + add rbx, rax + + ret + +;; Move onto the next chunk of the array +;; This is needed because strings are not stored in one +;; contiguous block of memory, but may use multiple Array +;; objects in a linked list +;; +;; If no chunks are left, then RAX = RBX +tokenizer_next_chunk: + mov rax, [rsi + Array.next] + cmp rax, 0 + je .no_more + ; More chunks left + mov rsi, rax + call tokenizer_init + ret +.no_more: + ; No more chunks left. RAX is zero + mov rbx, rax + ret + +;; Moves the next char into CL +;; If no more, puts 0 into CL +tokenizer_next_char: + ; Check if we have reached the end of this chunk + cmp rax, rbx + jne .chars_remain + + ; Hit the end. See if there is another chunk + call tokenizer_next_chunk + cmp rax, rbx + jne .chars_remain ; Success, got another + + ; No more chunks + mov cl, 0 ; Null char signals end + ret + +.chars_remain: + mov cl, BYTE [rax] + inc rax ; point to next byte + ret + +;; Get the next token +;; Token code is in CL register. Could be: +;; - 0 : Nil, finished +;; - Characters ()[]()'`~^@ +;; - Pair '~@', represented by code 1 +;; - A string: " in CL, and address in R8 +tokenizer_next: + +.next_char: + ; Fetch the next char into CL + call tokenizer_next_char + + cmp cl, 0 + je .found ; End, no more tokens + + ; Here expect to have: + ; - The current character in CL + ; - Address of next data in rax + ; - Address of data end in rbx + + ; Skip whitespace or commas + cmp cl, ' ' ; Space + je .next_char + cmp cl, ',' ; Comma + je .next_char + cmp cl, 9 ; Tab + + ; Special characters. These are returned in CL as-is + cmp cl, '(' + je .found + cmp cl, ')' + je .found + cmp cl, '[' + je .found + cmp cl, ']' + je .found + cmp cl, '{' + je .found + cmp cl, '}' + je .found + cmp cl, 39 ; character ' + je .found + cmp cl, 96 ; character ` + je .found + cmp cl, '^' + je .found + cmp cl, '@' + je .found + cmp cl, '~' ; Could be followed by '@' + je .handle_tilde + + cmp cl, ';' ; Start of a comment + je .tokens_finished + + cmp cl, '"' ; Opening string quotes + jmp .handle_string + + ; Could be number or symbol + + + + + ret + +.handle_string: + ; Get an array to put the string into + + ; save state of tokenizer + push rsi + push rax + push rbx + + call alloc_array + mov r8, rax ; Address of array in r8 + mov [r8], BYTE maltype_string ; mark as a string + + ; restore state + pop rbx + pop rax + pop rsi + + ; Put start of data array into r9 + mov r9, r8 + add r9, Array.data + ; Put end of data array into r10 + mov r10d, [rsi + Array.length] ; Length of array, zero-extended + add r10, r9 + + ; Now read chars from input string and push into output +.string_loop: + call tokenizer_next_char + cmp cl, 0 ; End of characters + je .error + + cmp cl, '"' ; Finished + je .found ; Leave '"' in CL + + cmp cl, 92 ; Escape '\' + jne .end_string_escape + + ; Current character is a '\' + call tokenizer_next_char + cmp cl, 0 ; End of characters + je .error + + cmp cl, 'n' ; \n, newline + je .insert_newline + + ; Whatever is in cl is now put into string + ; including '"' + jmp .end_string_escape + +.insert_newline: + mov cl, 10 + jmp .end_string_escape + +.end_string_escape: + + ; Put CL onto result array + mov [r9], cl + inc r9 + + jmp .string_loop + + ret + +.tokens_finished: + mov cl, 0 ; End of tokens + ret + +.handle_tilde: + ; Could have '~' or '~@'. Need to peek at the next char + + ; Push current state of the tokenizer + push rsi + push rax + push rbx + call tokenizer_next_char ; Next char in CL + cmp cl, '@' + jne .tilde_no_amp ; Just '~', not '~@' + ; Got '~@' + mov cl, 1 ; Signals '~@' + + ; Discard old state by moving stack pointer + add esp, 24 ; 3 * 8 bytes + ret + +.tilde_no_amp: + ; Restore state of the tokenizer + pop rbx + pop rax + pop rsi + ; fall through to finished + +.found: + ret + +.error: ret ;; ----------------------------- diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 9855c53cbb..e1ddd067f1 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -81,7 +81,7 @@ STRUC Array .type: RESB 1 ; Type information (8 bits) .control: RESB 1 ; Control data (8 bits) .refcount: RESW 1 ; Number of references to this Array (16 bit) -.length: RESD 1 ; Number of elements in array (32 bit) +.length: RESD 1 ; Number of elements in this part of the array (32 bit) .next RESQ 1 ; Pointer to the next chunk (64 bit) .data: RESQ array_chunk_len ; Data storage .size: ; Total size of struc @@ -442,6 +442,8 @@ itostring: ; Get an Array object to put the string into call alloc_array ; Address in RAX + + mov [rax], BYTE maltype_string ; mark as a string ; put length into string mov [rax + Array.length], ecx From 69edbad782754fc59565c14d3afaae76bab4d173 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sat, 14 Oct 2017 12:18:10 +0000 Subject: [PATCH 0217/1998] tests: Use a real user-defined function when testing fn? and macro? --- tests/stepA_mal.mal | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/stepA_mal.mal b/tests/stepA_mal.mal index 5c458e1e3e..5adb0824fa 100644 --- a/tests/stepA_mal.mal +++ b/tests/stepA_mal.mal @@ -112,10 +112,12 @@ (number? "123") ;=>false +(def! add1 (fn* (x) (+ x 1))) + ;; Testing fn? function (fn? +) ;=>true -(fn? not) +(fn? add1) ;=>true (fn? cond) ;=>false @@ -129,7 +131,7 @@ ;=>true (macro? +) ;=>false -(macro? not) +(macro? add1) ;=>false (macro? "+") ;=>false From c91c8de968b9a10ee54e408bb1e0175d4a2eb113 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sat, 14 Oct 2017 12:14:03 +0000 Subject: [PATCH 0218/1998] forth, skew, tcl: Add number?, fn?, macro? --- forth/core.fs | 19 +++++++++++++++++++ skew/core.sk | 4 ++++ tcl/core.tcl | 20 ++++++++++++++++++++ tcl/types.tcl | 4 ++++ 4 files changed, 47 insertions(+) diff --git a/forth/core.fs b/forth/core.fs index 79fa6847fa..593229c93f 100644 --- a/forth/core.fs +++ b/forth/core.fs @@ -218,6 +218,25 @@ defcore atom? drop @ mal-type @ Atom = mal-bool ;; defcore true? drop @ mal-true = mal-bool ;; defcore false? drop @ mal-false = mal-bool ;; defcore nil? drop @ mal-nil = mal-bool ;; +defcore number? drop @ mal-type @ MalInt = mal-bool ;; +defcore fn? + drop @ + dup mal-type @ MalUserFn = if + MalUserFn/is-macro? @ if + mal-false + else + mal-true + endif + else + mal-type @ MalNativeFn = if + mal-true + else + mal-false + endif + endif ;; +defcore macro? drop @ dup mal-type @ MalUserFn = + swap MalUserFn/is-macro? @ + and mal-bool ;; defcore sequential? drop @ sequential? ;; diff --git a/skew/core.sk b/skew/core.sk index 3390d8e7d7..bd470a1e30 100644 --- a/skew/core.sk +++ b/skew/core.sk @@ -16,6 +16,10 @@ const ns StringMap) MalVal> = { "symbol?": (a List) => MalVal.fromBool(a[0] is MalSymbol), "keyword": (a List) => MalKeyword.new((a[0] as MalString).val), "keyword?": (a List) => MalVal.fromBool(a[0] is MalKeyword), + "number?": (a List) => MalVal.fromBool(a[0] is MalNumber), + "fn?": (a List) => MalVal.fromBool(a[0] is MalNativeFunc || + (a[0] is MalFunc && !(a[0] as MalFunc).isMacro)), + "macro?": (a List) => MalVal.fromBool(a[0] is MalFunc && (a[0] as MalFunc).isMacro), "pr-str": (a List) => MalString.new(" ".join(a.map(e => pr_str(e, true)))), "str": (a List) => MalString.new("".join(a.map(e => pr_str(e, false)))), diff --git a/tcl/core.tcl b/tcl/core.tcl index a7ab9ea160..b168afb1af 100644 --- a/tcl/core.tcl +++ b/tcl/core.tcl @@ -40,6 +40,23 @@ proc mal_keyword_q {a} { bool_new [keyword_q [lindex $a 0]] } +proc mal_number_q {a} { + bool_new [integer_q [lindex $a 0]] +} + +proc mal_fn_q {a} { + set f [lindex $a 0] + switch [obj_type $f] { + function { return [bool_new [expr {![macro_q $f]}]] } + nativefunction { return $::mal_true } + default { return $::mal_false } + } +} + +proc mal_macro_q {a} { + bool_new [macro_q [lindex $a 0]] +} + proc render_array {arr readable delim} { set res {} foreach e $arr { @@ -383,6 +400,9 @@ set core_ns [dict create \ "string?" [nativefunction_new mal_string_q] \ "keyword" [nativefunction_new mal_keyword] \ "keyword?" [nativefunction_new mal_keyword_q] \ + "number?" [nativefunction_new mal_number_q] \ + "fn?" [nativefunction_new mal_fn_q] \ + "macro?" [nativefunction_new mal_macro_q] \ \ "pr-str" [nativefunction_new mal_pr_str] \ "str" [nativefunction_new mal_str] \ diff --git a/tcl/types.tcl b/tcl/types.tcl index e1edfad3b9..8bf2c705d6 100644 --- a/tcl/types.tcl +++ b/tcl/types.tcl @@ -73,6 +73,10 @@ proc integer_new {num} { obj_new "integer" $num } +proc integer_q {obj} { + expr {[obj_type $obj] == "integer"} +} + proc symbol_new {name} { obj_new "symbol" $name } From d5e01edc36ba05ab9690ac00e6c691c6734f410d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 15 Oct 2017 00:26:09 +0100 Subject: [PATCH 0219/1998] Reader and printer read/write integers Some progress: Integers read, passed as Cons object through to pr_str, then as Array (string) to print_string. Memory management (reference counting works so far...) --- nasm/printer.asm | 81 +++++++++++++++ nasm/reader.asm | 211 +++++++++++++++++++++++++++++++++++--- nasm/step1_read_print.asm | 101 ++++++++++++++---- 3 files changed, 359 insertions(+), 34 deletions(-) create mode 100644 nasm/printer.asm diff --git a/nasm/printer.asm b/nasm/printer.asm new file mode 100644 index 0000000000..11dd2b4d10 --- /dev/null +++ b/nasm/printer.asm @@ -0,0 +1,81 @@ +;;; Turns forms (lists, values/atoms) into strings +;;; +;;; + +section .data +unknown_type_string: db "#" +.len: equ $ - unknown_type_string + +unknown_value_string: db "#" +.len: equ $ - unknown_value_string + +nil_value_string: db "nil" +.len: equ $ - nil_value_string + +section .text + +;; Input: Address of object in RSI +;; +;; Output: Address of string in RAX +;; +;; Modifies: RCX +;; Calls: raw_to_string, +pr_str: + + ; Get the type + mov cl, BYTE [rsi] + + ; Check if it's already a string + cmp cl, maltype_string + jne .not_string + mov rax, rsi + ret + +.not_string: + ; Now test the container type (value, list) + + mov ch, cl + + and ch, container_mask + jz .value + + cmp ch, 2 + je .list + + cmp ch, 4 + je .symbol + + ; Unknown + mov rsi, unknown_type_string + mov edx, unknown_type_string.len + call raw_to_string ; Puts a String in RAX + ret + +.value: + mov ch, cl + and ch, content_mask + jz .value_nil + + cmp ch, 48 + je .value_int + + mov rsi, unknown_value_string + mov edx, unknown_value_string.len + call raw_to_string ; Puts a String in RAX + ret + +.value_nil: + mov rsi, nil_value_string + mov edx, nil_value_string.len + call raw_to_string + ret + +.value_int: + mov rax, [rsi + Cons.car] + call itostring + ret +.list: + ret +.symbol: + ret + diff --git a/nasm/reader.asm b/nasm/reader.asm index 818c680ca8..8c448a9c3f 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -7,10 +7,139 @@ section .text ;; ;; Input: Address of string (char array) in RSI ;; +;; Output: Address of object in RAX +;; +;; Uses registers: +;; R13 Address of the current list (starts 0) +;; R14 Stack pointer at start. Used for unwinding on error +;; R15 Address of first list. Used for unwinding on error +;; read_str: + ; Initialise tokenizer + call tokenizer_init + + ; Get the next token + call tokenizer_next + + ; Set current list to zero + mov r13, 0 + + ; Save stack pointer for unwinding + mov r14, rsp + + ; check what type of token by testing CL + cmp cl, 0 + jne .got_token + + ; No tokens. Return 'nil' + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.read_loop: + + call tokenizer_next + cmp cl, 0 + jne .got_token + + ; Unexpected end of tokens + + mov rsp, r14 ; Restore stack + mov rsi, r13 ; Top Cons + call release_cons ; This should delete everything + + call alloc_cons + mov [rax], BYTE maltype_nil + + ret + +.got_token: + + cmp cl, '(' + je .list_start + + cmp cl, ')' + je .list_end + + cmp cl, 'i' + je .append_object ; Cons already in R8 + + ; Unknown + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + ; -------------------------------- +.list_start: + ; Push current list onto stack + push r13 + + ; Push current state of the tokenizer + push rsi + push rax + push rbx + + ; Start new list + call alloc_cons ; Address in rax + + cmp r13, 0 + jne .list_link_last + + ; This is the top-level list + mov r15, rax + +.list_link_last: + ; The new list is nested + mov [r13 + Cons.cdr], rax + mov [r13 + Cons.typecdr], BYTE content_pointer +.list_done: + mov r13, rax ; Switch to new list + + ; Restore state + pop rbx + pop rax + pop rsi + + jmp .read_loop + + ; -------------------------------- +.list_end: + + ; Put the current list into r8 + mov r8, r13 + + ; Pop the previous list + pop r13 + + jmp .append_object ; Add R8 to list in R13 + + ; -------------------------------- +.append_object: + ; Append Cons in R8 to list in R13 + ; If no list in R13 (address is zero) then returns + ; with R8 moved to RAX + + cmp r13, 0 + je .finished + ; Append to list + mov [r13 + Cons.cdr], r8 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r8 + Cons.typecdr], BYTE content_nil + + jmp .read_loop + ; -------------------------------- +.finished: + ; No list to add this object to, so finished + mov rax, r8 + ret ;; Initialise the tokenizer +;; +;; Input: Address of string in RSI +;; +;; NOTE: This uses RSI, RAX and RBX, and expects these to be preserved +;; between calls to tokenizer_next_char tokenizer_init: ; Put start of data array into rax mov rax, rsi @@ -67,6 +196,10 @@ tokenizer_next_char: ;; - Characters ()[]()'`~^@ ;; - Pair '~@', represented by code 1 ;; - A string: " in CL, and address in R8 +;; - An integer: 'i' in CL +;; +;; Address of object in R8 +;; tokenizer_next: .next_char: @@ -115,12 +248,71 @@ tokenizer_next: cmp cl, ';' ; Start of a comment je .tokens_finished - cmp cl, '"' ; Opening string quotes - jmp .handle_string + cmp cl, 34 ; Opening string quotes + je .handle_string ; Could be number or symbol + ; Check for a character 0-9 + cmp cl, '0' + jl .handle_symbol + cmp cl, '9' + jg .handle_symbol + +.handle_integer: + ; Start integer + ; accumulate in EDX + xor edx, edx + + ; Push current state of the tokenizer + push rsi + push rax + push rbx +.integer_loop: + ; Here have a char 0-9 in CL + sub cl, '0' ; Convert to number between 0 and 9 + movzx ebx, cl + add edx, ebx + + ; Peek at next character + push rdx + call tokenizer_next_char ; Next char in CL + pop rdx + + cmp cl, '0' + jl .integer_finished + cmp cl, '9' + jg .integer_finished + + imul edx, 10 + + jmp .integer_loop + +.integer_finished: + ; Next char not an int + + push rdx ; Save the integer + + ; Get a Cons object to put the result into + call alloc_cons + ; Address of Cons now in RAX + mov r8, rax + mov [r8], BYTE maltype_integer + + pop rdx + mov [r8 + Cons.car], rdx + + ; Restore state + pop rbx + pop rax + pop rsi + + mov cl, 'i' ; Mark as an integer + ret + +.handle_symbol: + ret @@ -155,7 +347,7 @@ tokenizer_next: cmp cl, 0 ; End of characters je .error - cmp cl, '"' ; Finished + cmp cl, 34 ; Finishing '"' je .found ; Leave '"' in CL cmp cl, 92 ; Escape '\' @@ -180,6 +372,7 @@ tokenizer_next: .end_string_escape: ; Put CL onto result array + ; NOTE: this doesn't handle long strings (multiple memory blocks) mov [r9], cl inc r9 @@ -205,7 +398,7 @@ tokenizer_next: mov cl, 1 ; Signals '~@' ; Discard old state by moving stack pointer - add esp, 24 ; 3 * 8 bytes + add rsp, 24 ; 3 * 8 bytes ret .tilde_no_amp: @@ -221,13 +414,3 @@ tokenizer_next: .error: ret -;; ----------------------------- -;; list(tokens) tokenizer (string) -;; -;; Input string address in RSI -;; Creates a list of tokens, returns address in RAX -tokenizer: - - ; Get a new - call alloc_array - ret diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index e1ddd067f1..3a60c56686 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -118,15 +118,22 @@ ENDSTRUC %define maltype_integer (block_cons + container_value + content_int) %define maltype_string (block_array + container_value + content_char) %define maltype_symbol (block_array + container_symbol + content_char) - +%define maltype_nil (block_cons + container_value + content_nil) %include "reader.asm" +%include "printer.asm" global _start section .data +test_string1: db 10, "test1", 10 +.len: equ $ - test_string1 + +test_string2: db 10, "test2", 10 +.len: equ $ - test_string2 + ;str: ISTRUC Array ;AT Array.type, db maltype_string ;AT Array.length, dd 6 @@ -158,12 +165,12 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 1 ; Number of cons objects which can be created +%define heap_cons_limit 10 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 1 ; Number of array objects which can be created +%define heap_array_limit 4 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 @@ -230,6 +237,15 @@ alloc_array: ;; onto the free list release_array: mov ax, WORD [rsi + Array.refcount] + + push rsi + push rdx + mov rsi, test_string1 + mov rdx, test_string1.len + call print_rawstring + pop rdx + pop rsi + dec ax mov WORD [rsi + Array.refcount], ax jz .free ; If the count reaches zero then put on free list @@ -358,6 +374,49 @@ release_object: .array: call release_array ret + +;; ------------------------------------------- +;; String type + +;; Create a new string, address in RAX +string_new: + call alloc_array + mov [rax], BYTE maltype_string + ret + +;; Convert a raw string to a String type +;; +;; Input: Address of raw string in RSI, length in EDX +;; Output: Address of string in RAX +;; +;; Modifies registers: R8,R9,RCX +raw_to_string: + push rsi + push rdx + call string_new ; String now in RAX + pop rdx + pop rsi + mov [rax + Array.length], DWORD edx + mov r8, rax + add r8, Array.data ; Address of string data + mov r9, rsi ; Address of raw data + mov ecx, edx ; Count +.copy_loop: + + mov bl, BYTE [r9] + mov [r8], BYTE bl + inc r8 + inc r9 + dec ecx + jnz .copy_loop + ret + + + +;; Appends a character to a string +;; Input: Address of string in RSI, character in CL +string_append_char: + ret ;; ------------------------------------------- ;; Prints a raw string to stdout @@ -468,17 +527,6 @@ itostring: pop rcx ret - -;; ---------------------------- -;; int stringtoi(String) -;; -;; Convert a string (char array) to an integer -;; -;; Address of input string is in RSI -;; Output integer in RAX -stringtoi: - - ret ;------------------------------------------ ; void exit() @@ -493,11 +541,6 @@ quit_error: mov rdi, 1 ; exit code 1 syscall - -;; Takes a string as input and processes it into a form -read: - mov rax, rsi ; Return the input - ret ;; Evaluates a form eval: @@ -511,7 +554,7 @@ print: ;; Read-Eval-Print in sequence rep_seq: - call read + call read_str mov rsi, rax ; Output of read into input of eval call eval mov rsi, rax ; Output of eval into input of print @@ -596,10 +639,28 @@ _start: je .mainLoopEnd push rax ; Save address of the string + + ; Put into read_str + mov rsi, rax + call read_str + push rax + + ; Put into pr_str + mov rsi, rax + call pr_str + push rax mov rsi, rax ; Put into input of print_string call print_string + ; Release string from pr_str + pop rsi + call release_array + + ; Release the Cons from read_str + pop rsi + call release_cons + ; Release the string pop rsi call release_array From d90be1a9b226fd95fdb46f0d818924d33bc705e9 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sun, 15 Oct 2017 06:04:09 +0000 Subject: [PATCH 0220/1998] awk, ocaml: Add number?, fn?, macro? --- awk/core.awk | 29 +++++++++++++++++++++++++++++ ocaml/core.ml | 15 +++++++++++++++ ocaml/step8_macros.ml | 6 ++---- ocaml/step9_try.ml | 6 ++---- ocaml/stepA_mal.ml | 6 ++---- 5 files changed, 50 insertions(+), 12 deletions(-) diff --git a/awk/core.awk b/awk/core.awk index f7c03de989..ee34f16596 100644 --- a/awk/core.awk +++ b/awk/core.awk @@ -127,6 +127,32 @@ function core_keywordp(idx) return types_heap[idx][1] ~ /^:/ ? "#true" : "#false" } +function core_numberp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'number?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^\+/ ? "#true" : "#false" +} + +function core_fnp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'fn?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + f = types_heap[idx][1] + return f ~ /^[$&%]/ && !types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false" +} + +function core_macrop(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'macro?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + f = types_heap[idx][1] + return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false" +} + function core_pr_str(idx, i, len, result) @@ -1028,6 +1054,9 @@ function core_init() core_ns["'symbol?"] = "&core_symbolp" core_ns["'keyword"] = "&core_keyword" core_ns["'keyword?"] = "&core_keywordp" + core_ns["'number?"] = "&core_numberp" + core_ns["'fn?"] = "&core_fnp" + core_ns["'macro?"] = "&core_macrop" core_ns["'pr-str"] = "&core_pr_str" core_ns["'str"] = "&core_str" diff --git a/ocaml/core.ml b/ocaml/core.ml index b1633406fc..5c6f19761f 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -1,6 +1,8 @@ module T = Types.Types let ns = Env.make None +let kw_macro = T.Keyword "macro" + let num_fun t f = Types.fn (function | [(T.Int a); (T.Int b)] -> t (f a b) @@ -146,6 +148,19 @@ let init env = begin (Types.fn (function [T.String x] -> T.Keyword x | _ -> T.Nil)); Env.set env (Types.symbol "keyword?") (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "number?") + (Types.fn (function [T.Int _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "fn?") + (Types.fn (function + | [T.Fn { T.meta = T.Map { T.value = meta } }] + -> mk_bool (not (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta))) + | [T.Fn _] -> T.Bool true + | _ -> T.Bool false)); + Env.set env (Types.symbol "macro?") + (Types.fn (function + | [T.Fn { T.meta = T.Map { T.value = meta } }] + -> mk_bool (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta)) + | _ -> T.Bool false)); Env.set env (Types.symbol "nil?") (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "true?") diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml index 93113e5ad5..92ee6308d5 100644 --- a/ocaml/step8_macros.ml +++ b/ocaml/step8_macros.ml @@ -14,14 +14,12 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let kw_macro = T.Keyword "macro" - let is_macro_call ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with | T.Fn { T.meta = T.Map { T.value = meta } } - -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) | _ -> false) | _ -> false @@ -61,7 +59,7 @@ and eval ast env = | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} in Env.set env key fn; fn | _ -> raise (Invalid_argument "defmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml index 1885359ffe..61cee2decc 100644 --- a/ocaml/step9_try.ml +++ b/ocaml/step9_try.ml @@ -14,14 +14,12 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let kw_macro = T.Keyword "macro" - let is_macro_call ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with | T.Fn { T.meta = T.Map { T.value = meta } } - -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) | _ -> false) | _ -> false @@ -61,7 +59,7 @@ and eval ast env = | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} in Env.set env key fn; fn | _ -> raise (Invalid_argument "devmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } diff --git a/ocaml/stepA_mal.ml b/ocaml/stepA_mal.ml index c36e6c87e3..a8cbd1c3a3 100644 --- a/ocaml/stepA_mal.ml +++ b/ocaml/stepA_mal.ml @@ -14,14 +14,12 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let kw_macro = T.Keyword "macro" - let is_macro_call ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with | T.Fn { T.meta = T.Map { T.value = meta } } - -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) | _ -> false) | _ -> false @@ -61,7 +59,7 @@ and eval ast env = | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} in Env.set env key fn; fn | _ -> raise (Invalid_argument "devmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } From 51796fd84f4c4a0193f4c5f7da53cd04d9eec26f Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sun, 15 Oct 2017 12:07:40 +0000 Subject: [PATCH 0221/1998] crystal, logo: Add number?, fn?, macro? --- crystal/core.cr | 17 +++++++++++++++++ logo/core.lg | 20 ++++++++++++++++++++ 2 files changed, 37 insertions(+) diff --git a/crystal/core.cr b/crystal/core.cr index b7a5c3c931..2694cf8542 100644 --- a/crystal/core.cr +++ b/crystal/core.cr @@ -188,6 +188,20 @@ def self.keyword?(args) head.is_a?(String) && !head.empty? && head[0] == '\u029e' end +def self.number?(args) + args.first.unwrap.is_a?(Int64) +end + +def self.fn?(args) + return false if args.first.macro? + head = args.first.unwrap + head.is_a?(Mal::Func) || head.is_a?(Mal::Closure) +end + +def self.macro?(args) + args.first.macro? +end + def self.vector(args) args.to_mal(Mal::Vector) end @@ -411,6 +425,9 @@ NS = { "string?" => func(:string?), "keyword" => func(:keyword), "keyword?" => func(:keyword?), + "number?" => func(:number?), + "fn?" => func(:fn?), + "macro?" => func(:macro?), "vector" => func(:vector), "vector?" => func(:vector?), "hash-map" => func(:hash_map), diff --git a/logo/core.lg b/logo/core.lg index 2d807fd662..6860cdd91e 100644 --- a/logo/core.lg +++ b/logo/core.lg @@ -49,6 +49,23 @@ to mal_keyword_q :a output bool_to_mal ((obj_type :a) = "keyword) end +to mal_number_q :a +output bool_to_mal ((obj_type :a) = "number) +end + +to mal_fn_q :a +case obj_type :a [ + [[nativefn] output true_new ] + [[fn] output bool_to_mal not fn_is_macro :a] + [else output false_new ] +] +end + +to mal_macro_q :a +if ((obj_type :a) = "fn) [ output bool_to_mal fn_is_macro :a ] +output false_new +end + to mal_pr_str [:args] output obj_new "string pr_seq :args "true " " :space_char end @@ -355,6 +372,9 @@ make "core_ns [ [[symbol symbol?] [nativefn mal_symbol_q]] [[symbol keyword] [nativefn mal_keyword]] [[symbol keyword?] [nativefn mal_keyword_q]] + [[symbol number?] [nativefn mal_number_q]] + [[symbol fn?] [nativefn mal_fn_q]] + [[symbol macro?] [nativefn mal_macro_q]] [[symbol pr-str] [nativefn mal_pr_str]] [[symbol str] [nativefn mal_str]] From f55aec105e9ae002d9db98c58bed8135c0237d93 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 16 Oct 2017 06:18:44 +0000 Subject: [PATCH 0222/1998] ps, rust: Add number?, fn?, macro? --- ps/core.ps | Bin 8131 -> 8534 bytes rust/src/core.rs | 3 +++ rust/src/types.rs | 27 +++++++++++++++++++++++++++ 3 files changed, 30 insertions(+) diff --git a/ps/core.ps b/ps/core.ps index f5b6e04989321319fb2d6570564408edb5461c0d..de77ab27d56cfbbed9b88874730d6ff13bf01a2f 100644 GIT binary patch delta 417 zcma)2J8r^25baXz2`FEKWGd59TFMD%qZHO+&yrQ_HSDKAmcT}V$(h*X&jtpMi8jsN1J3>)ONta24h;dK+|m}-S_ zk8wa+%fdDp*5u)BAkY@3@jW=cwY1+coV4MK+spEJJAUyA2`L#?zW? f|KTLMKBI*5okbd>W7N;?a25~RA)E7ka(jCK_y30) delta 16 YcmccSbl85v#LdSUqa-%hN!?%r07R?@QUCw| diff --git a/rust/src/core.rs b/rust/src/core.rs index 00e3532d67..a598f6cf17 100644 --- a/rust/src/core.rs +++ b/rust/src/core.rs @@ -499,6 +499,9 @@ pub fn ns() -> HashMap { ns.insert("symbol?".to_string(), func(types::symbol_q)); ns.insert("keyword".to_string(), func(types::_keyword)); ns.insert("keyword?".to_string(), func(types::keyword_q)); + ns.insert("number?".to_string(), func(types::int_q)); + ns.insert("fn?".to_string(), func(types::fn_q)); + ns.insert("macro?".to_string(), func(types::macro_q)); ns.insert("pr-str".to_string(), func(pr_str)); ns.insert("str".to_string(), func(str)); diff --git a/rust/src/types.rs b/rust/src/types.rs index b85affa338..0fdf8de21e 100644 --- a/rust/src/types.rs +++ b/rust/src/types.rs @@ -207,6 +207,15 @@ pub fn string_q(a:Vec) -> MalRet { } pub fn _int(i: isize) -> MalVal { Rc::new(Int(i)) } +pub fn int_q(a:Vec) -> MalRet { + if a.len() != 1 { + return err_str("Wrong arity to number? call"); + } + match *a[0] { + Int(_) => Ok(_true()), + _ => Ok(_false()), + } +} // Symbols @@ -371,6 +380,24 @@ pub fn malfunc(eval: fn(MalVal, Env) -> MalRet, pub fn malfuncd(mfd: MalFuncData, meta: MalVal) -> MalVal { Rc::new(MalFunc(mfd,meta)) } +pub fn fn_q(a:Vec) -> MalRet { + if a.len() != 1 { + return err_str("Wrong arity to fn? call"); + } + match *a[0] { + Func(..) | MalFunc(MalFuncData { is_macro: false, .. }, _) => Ok(_true()), + _ => Ok(_false()), + } +} +pub fn macro_q(a:Vec) -> MalRet { + if a.len() != 1 { + return err_str("Wrong arity to macro? call"); + } + match *a[0] { + MalFunc(MalFuncData { is_macro: true, .. }, _) => Ok(_true()), + _ => Ok(_false()), + } +} // Atoms From c1709fad0bbd6bd3b253ba2573898e7f1178cf76 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Mon, 16 Oct 2017 21:56:21 +0000 Subject: [PATCH 0223/1998] d, nim: Add number?, fn?, macro? --- d/mal_core.d | 21 +++++++++++++++++++++ nim/core.nim | 3 +++ nim/step8_macros.nim | 2 +- nim/step9_try.nim | 2 +- nim/stepA_mal.nim | 2 +- nim/types.nim | 11 ++++++++++- 6 files changed, 37 insertions(+), 4 deletions(-) diff --git a/d/mal_core.d b/d/mal_core.d index 561b4571b5..2d14fb5cf3 100644 --- a/d/mal_core.d +++ b/d/mal_core.d @@ -53,6 +53,24 @@ static MalType mal_keyword_q(MalType[] a ...) return bool_to_mal(s.is_keyword()); } +static MalType mal_fn_q(MalType[] a ...) +{ + verify_args_count(a, 1); + auto builtinfn = cast(MalBuiltinFunc) a[0]; + if (builtinfn !is null) return mal_true; + auto malfunc = cast(MalFunc) a[0]; + if (malfunc !is null) return bool_to_mal(!malfunc.is_macro); + return mal_false; +} + +static MalType mal_macro_q(MalType[] a ...) +{ + verify_args_count(a, 1); + auto malfunc = cast(MalFunc) a[0]; + if (malfunc !is null) return bool_to_mal(malfunc.is_macro); + return mal_false; +} + static MalType mal_pr_str(MalType[] a ...) { auto items_strs = a.map!(e => pr_str(e, true)); @@ -341,6 +359,9 @@ static this() "string?": &mal_string_q, "keyword": &mal_keyword, "keyword?": &mal_keyword_q, + "number?": (a ...) => mal_type_q!MalInteger(a), + "fn?": &mal_fn_q, + "macro?": &mal_macro_q, "pr-str": &mal_pr_str, "str": &mal_str, diff --git a/nim/core.nim b/nim/core.nim index 777e243e76..e9921898ef 100644 --- a/nim/core.nim +++ b/nim/core.nim @@ -224,6 +224,9 @@ let ns* = { "symbol?": fun symbol_q, "keyword": fun keyword, "keyword?": fun keyword_q, + "number?": fun number_q, + "fn?": fun fn_q, + "macro?": fun macro_q, "with-meta": fun with_meta, "meta": fun meta, diff --git a/nim/step8_macros.nim b/nim/step8_macros.nim index 0f2d0fb0a7..0cd6776778 100644 --- a/nim/step8_macros.nim +++ b/nim/step8_macros.nim @@ -18,7 +18,7 @@ proc quasiquote(ast: MalType): MalType = proc is_macro_call(ast: MalType, env: Env): bool = ast.kind == List and ast.list[0].kind == Symbol and - env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).macro_q + env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro proc macroexpand(ast: MalType, env: Env): MalType = result = ast diff --git a/nim/step9_try.nim b/nim/step9_try.nim index 763d67d685..97884ddc16 100644 --- a/nim/step9_try.nim +++ b/nim/step9_try.nim @@ -18,7 +18,7 @@ proc quasiquote(ast: MalType): MalType = proc is_macro_call(ast: MalType, env: Env): bool = ast.kind == List and ast.list[0].kind == Symbol and - env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).macro_q + env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro proc macroexpand(ast: MalType, env: Env): MalType = result = ast diff --git a/nim/stepA_mal.nim b/nim/stepA_mal.nim index 7f5f9b6eed..abc3fbc1f6 100644 --- a/nim/stepA_mal.nim +++ b/nim/stepA_mal.nim @@ -18,7 +18,7 @@ proc quasiquote(ast: MalType): MalType = proc is_macro_call(ast: MalType, env: Env): bool = ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and - env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).macro_q + env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro proc macroexpand(ast: MalType, env: Env): MalType = result = ast diff --git a/nim/types.nim b/nim/types.nim index aeae5ea320..48f442b621 100644 --- a/nim/types.nim +++ b/nim/types.nim @@ -64,7 +64,7 @@ proc hash_map*(xs: varargs[MalType]): MalType {.procvar.} = else: xs[i].str result.hash_map[s] = xs[i+1] -proc macro_q*(x: MalType): bool = +proc fun_is_macro*(x: MalType): bool = if x.kind == Fun: result = x.is_macro elif x.kind == MalFun: result = x.malfun.is_macro else: raise newException(ValueError, "no function") @@ -124,6 +124,15 @@ proc keyword*(xs: varargs[MalType]): MalType {.procvar.} = proc keyword_q*(xs: varargs[MalType]): MalType {.procvar.} = boolObj(xs[0].kind == String and xs[0].str[0] == '\xff') +proc number_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == Number + +proc fn_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj((xs[0].kind == MalFun or xs[0].kind == Fun) and not xs[0].fun_is_macro) + +proc macro_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj((xs[0].kind == MalFun or xs[0].kind == Fun) and xs[0].fun_is_macro) + proc atom*(xs: varargs[MalType]): MalType {.procvar.} = atom(xs[0]) From 85657c96323ab5da579a7a0fff7ac82a182e74fc Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 17 Oct 2017 01:29:08 +0200 Subject: [PATCH 0224/1998] common-lisp, es6, guile, java, mal: Add number?, fn?, macro? --- common-lisp/src/core.lisp | 12 ++++++++++++ common-lisp/src/step5_tco.lisp | 12 ++++++------ common-lisp/src/step6_file.lisp | 12 ++++++------ common-lisp/src/step7_quote.lisp | 12 ++++++------ common-lisp/src/step8_macros.lisp | 18 +++++++++--------- common-lisp/src/step9_try.lisp | 18 +++++++++--------- common-lisp/src/stepA_mal.lisp | 18 +++++++++--------- es6/core.mjs | 3 +++ guile/core.scm | 3 +++ guile/step6_file.scm | 2 +- guile/step7_quote.scm | 2 +- guile/step8_macros.scm | 4 ++-- guile/step9_try.scm | 4 ++-- guile/stepA_mal.scm | 4 ++-- guile/types.scm | 8 +++++--- java/src/main/java/mal/core.java | 20 ++++++++++++++++++++ mal/core.mal | 17 +++++++++++++++++ 17 files changed, 113 insertions(+), 56 deletions(-) diff --git a/common-lisp/src/core.lisp b/common-lisp/src/core.lisp index 06c7a03596..74eeb77210 100644 --- a/common-lisp/src/core.lisp +++ b/common-lisp/src/core.lisp @@ -174,6 +174,9 @@ (defmal false? (value) (wrap-boolean (and (mal-boolean-p value) (not (mal-data-value value))))) +(defmal number? (value) + (wrap-boolean (mal-number-p value))) + (defmal symbol (string) (make-mal-symbol (mal-data-value string))) @@ -194,6 +197,15 @@ (defmal vector? (value) (wrap-boolean (mal-vector-p value))) +(defmal fn? (value) + (wrap-boolean (or (mal-builtin-fn-p value) + (and (mal-fn-p value) + (not (cdr (assoc :is-macro (mal-data-attrs value)))))))) + +(defmal macro? (value) + (wrap-boolean (and (mal-fn-p value) + (cdr (assoc :is-macro (mal-data-attrs value)))))) + (defmal hash-map (&rest elements) (let ((hash-map (make-mal-value-hash-table))) (loop for (key value) on elements diff --git a/common-lisp/src/step5_tco.lisp b/common-lisp/src/step5_tco.lisp index b0d9ece2d5..be68074299 100644 --- a/common-lisp/src/step5_tco.lisp +++ b/common-lisp/src/step5_tco.lisp @@ -102,9 +102,9 @@ (mal-eval body (env:create-mal-env :parent env :binds (listify (mal-data-value arglist)) :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env)))))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) @@ -113,11 +113,11 @@ (return (apply (mal-data-value function) (cdr evaluated-list))) (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc 'ast attrs)) - env (env:create-mal-env :parent (cdr (assoc 'env attrs)) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) :binds (map 'list #'identity - (mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc :params attrs)))) :exprs (cdr evaluated-list))))))))))))) (defun mal-print (expression) diff --git a/common-lisp/src/step6_file.lisp b/common-lisp/src/step6_file.lisp index 361305ccdd..75b3621a0e 100644 --- a/common-lisp/src/step6_file.lisp +++ b/common-lisp/src/step6_file.lisp @@ -102,9 +102,9 @@ (mal-eval body (env:create-mal-env :parent env :binds (listify (mal-data-value arglist)) :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env)))))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) @@ -113,11 +113,11 @@ (return (apply (mal-data-value function) (cdr evaluated-list))) (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc 'ast attrs)) - env (env:create-mal-env :parent (cdr (assoc 'env attrs)) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) :binds (map 'list #'identity - (mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc :params attrs)))) :exprs (cdr evaluated-list))))))))))))) (defun mal-print (expression) diff --git a/common-lisp/src/step7_quote.lisp b/common-lisp/src/step7_quote.lisp index ea7d53d28e..cf92fc50df 100644 --- a/common-lisp/src/step7_quote.lisp +++ b/common-lisp/src/step7_quote.lisp @@ -138,9 +138,9 @@ (mal-eval body (env:create-mal-env :parent env :binds (listify (mal-data-value arglist)) :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env)))))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) @@ -149,11 +149,11 @@ (return (apply (mal-data-value function) (cdr evaluated-list))) (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc 'ast attrs)) - env (env:create-mal-env :parent (cdr (assoc 'env attrs)) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) :binds (map 'list #'identity - (mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc :params attrs)))) :exprs (cdr evaluated-list))))))))))))) (defun mal-print (expression) diff --git a/common-lisp/src/step8_macros.lisp b/common-lisp/src/step8_macros.lisp index cbf47eb78b..e27ac6cca8 100644 --- a/common-lisp/src/step8_macros.lisp +++ b/common-lisp/src/step8_macros.lisp @@ -103,7 +103,7 @@ (env:find-env env func-symbol)))) (and func (mal-fn-p func) - (cdr (assoc 'is-macro (mal-data-attrs func))))))) + (cdr (assoc :is-macro (mal-data-attrs func))))))) (defun mal-macroexpand (ast env) (loop @@ -144,7 +144,7 @@ (env:set-env env (second forms) (progn - (setf (cdr (assoc 'is-macro (mal-data-attrs value))) t) + (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) value)) (error 'invalid-function :form value @@ -186,21 +186,21 @@ (mal-eval body (env:create-mal-env :parent env :binds (listify (mal-data-value arglist)) :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env) - (cons 'is-macro nil)))))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env) + (cons :is-macro nil)))))) (t (let* ((evaluated-list (eval-ast ast env)) (function (car evaluated-list))) ;; If first element is a mal function unwrap it (cond ((mal-fn-p function) (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc 'ast attrs)) - env (env:create-mal-env :parent (cdr (assoc 'env attrs)) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) :binds (map 'list #'identity - (mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc :params attrs)))) :exprs (cdr evaluated-list))))) ((mal-builtin-fn-p function) (return (apply (mal-data-value function) diff --git a/common-lisp/src/step9_try.lisp b/common-lisp/src/step9_try.lisp index 268e50dab6..e6257a3900 100644 --- a/common-lisp/src/step9_try.lisp +++ b/common-lisp/src/step9_try.lisp @@ -106,7 +106,7 @@ (env:find-env env func-symbol)))) (and func (mal-fn-p func) - (cdr (assoc 'is-macro (mal-data-attrs func))))))) + (cdr (assoc :is-macro (mal-data-attrs func))))))) (defun mal-macroexpand (ast env) (loop @@ -147,7 +147,7 @@ (env:set-env env (second forms) (progn - (setf (cdr (assoc 'is-macro (mal-data-attrs value))) t) + (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) value)) (error 'invalid-function :form value @@ -189,10 +189,10 @@ (mal-eval body (env:create-mal-env :parent env :binds (listify (mal-data-value arglist)) :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env) - (cons 'is-macro nil)))))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env) + (cons :is-macro nil)))))) ((mal-data-value= mal-try* (first forms)) (handler-case @@ -214,11 +214,11 @@ ;; If first element is a mal function unwrap it (cond ((mal-fn-p function) (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc 'ast attrs)) - env (env:create-mal-env :parent (cdr (assoc 'env attrs)) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) :binds (map 'list #'identity - (mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc :params attrs)))) :exprs (cdr evaluated-list))))) ((mal-builtin-fn-p function) (return (apply (mal-data-value function) diff --git a/common-lisp/src/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp index ec189dd30a..73dc67cbef 100644 --- a/common-lisp/src/stepA_mal.lisp +++ b/common-lisp/src/stepA_mal.lisp @@ -105,7 +105,7 @@ (env:find-env env func-symbol)))) (and func (mal-fn-p func) - (cdr (assoc 'is-macro (mal-data-attrs func))))))) + (cdr (assoc :is-macro (mal-data-attrs func))))))) (defun mal-macroexpand (ast env) (loop @@ -146,7 +146,7 @@ (env:set-env env (second forms) (progn - (setf (cdr (assoc 'is-macro (mal-data-attrs value))) t) + (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) value)) (error 'invalid-function :form value @@ -188,10 +188,10 @@ (mal-eval body (env:create-mal-env :parent env :binds (listify (mal-data-value arglist)) :exprs args))) - :attrs (list (cons 'params arglist) - (cons 'ast body) - (cons 'env env) - (cons 'is-macro nil)))))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env) + (cons :is-macro nil)))))) ((mal-data-value= mal-try* (first forms)) (handler-case @@ -213,11 +213,11 @@ ;; If first element is a mal function unwrap it (cond ((mal-fn-p function) (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc 'ast attrs)) - env (env:create-mal-env :parent (cdr (assoc 'env attrs)) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) :binds (map 'list #'identity - (mal-data-value (cdr (assoc 'params attrs)))) + (mal-data-value (cdr (assoc :params attrs)))) :exprs (cdr evaluated-list))))) ((mal-builtin-fn-p function) (return (apply (mal-data-value function) diff --git a/es6/core.mjs b/es6/core.mjs index 7b9e1f5219..64a7436aa4 100644 --- a/es6/core.mjs +++ b/es6/core.mjs @@ -44,11 +44,14 @@ export const core_ns = new Map([ ['nil?', a => a === null], ['true?', a => a === true], ['false?', a => a === false], + ['number?', a => typeof a === 'number'], ['string?', a => typeof a === "string" && !_keyword_Q(a)], ['symbol', a => Symbol.for(a)], ['symbol?', a => typeof a === 'symbol'], ['keyword', _keyword], ['keyword?', _keyword_Q], + ['fn?', a => typeof a === 'function' && !a.ismacro ], + ['macro?', a => typeof a === 'function' && !!a.ismacro ], ['pr-str', (...a) => a.map(e => pr_str(e,1)).join(' ')], ['str', (...a) => a.map(e => pr_str(e,0)).join('')], diff --git a/guile/core.scm b/guile/core.scm index f5b485eb13..1ba7c7048e 100644 --- a/guile/core.scm +++ b/guile/core.scm @@ -235,6 +235,7 @@ (nil? ,_nil?) (true? ,_true?) (false? ,_false?) + (number? ,number?) (symbol? ,symbol?) (symbol ,->symbol) (string? ,_string?) @@ -251,6 +252,8 @@ (vals ,_vals) (contains? ,_contains?) (sequential? ,_sequential?) + (fn? ,is-func?) + (macro? ,is-macro?) (readline ,__readline) (meta ,_meta) (with-meta ,_with-meta) diff --git a/guile/step6_file.scm b/guile/step6_file.scm index 3fb7b651be..ccb4a0adb3 100644 --- a/guile/step6_file.scm +++ b/guile/step6_file.scm @@ -37,7 +37,7 @@ (define (eval_func ast env) (define (_eval o) (EVAL o env)) - (define (func? x) (and=> ((env 'get) x) is-func?)) + (define (func? x) (and=> ((env 'get) x) is-func)) (cond ((func? (car ast)) => (lambda (c) diff --git a/guile/step7_quote.scm b/guile/step7_quote.scm index 2cebf4493c..bffd8de22c 100644 --- a/guile/step7_quote.scm +++ b/guile/step7_quote.scm @@ -37,7 +37,7 @@ (define (eval_func ast env) (define (_eval o) (EVAL o env)) - (define (func? x) (and=> ((env 'get) x) is-func?)) + (define (func? x) (and=> ((env 'get) x) is-func)) (cond ((func? (car ast)) => (lambda (c) diff --git a/guile/step8_macros.scm b/guile/step8_macros.scm index af36411f49..aa098c412c 100644 --- a/guile/step8_macros.scm +++ b/guile/step8_macros.scm @@ -37,7 +37,7 @@ (define (eval_func ast env) (define (_eval o) (EVAL o env)) - (define (func? x) (and=> ((env 'get) x) is-func?)) + (define (func? x) (and=> ((env 'get) x) is-func)) (cond ((func? (car ast)) => (lambda (c) @@ -55,7 +55,7 @@ (define (is_macro_call ast env) (and (list? ast) (> (length ast) 0) - (and=> (env-check (car ast) env) is-macro?))) + (and=> (env-check (car ast) env) is-macro))) (define (_macroexpand ast env) (cond diff --git a/guile/step9_try.scm b/guile/step9_try.scm index 01ab6deaa9..33de5622c3 100644 --- a/guile/step9_try.scm +++ b/guile/step9_try.scm @@ -37,7 +37,7 @@ (define (eval_func ast env) (define (_eval o) (EVAL o env)) - (define (func? x) (and=> (env-check x env) is-func?)) + (define (func? x) (and=> (env-check x env) is-func)) ;;(format #t "AAA: ~a~%" (func? (car ast))) (cond ((func? (car ast)) @@ -56,7 +56,7 @@ (define (is_macro_call ast env) (and (list? ast) (> (length ast) 0) - (and=> (env-check (car ast) env) is-macro?))) + (and=> (env-check (car ast) env) is-macro))) (define (_macroexpand ast env) (cond diff --git a/guile/stepA_mal.scm b/guile/stepA_mal.scm index 98127ae252..1f9bf0e3bc 100644 --- a/guile/stepA_mal.scm +++ b/guile/stepA_mal.scm @@ -52,7 +52,7 @@ x))) (if (callable? f) f - (and=> (env-check f env) is-func?)))) + (and=> (env-check f env) is-func)))) (cond ((func? (car ast)) => (lambda (c) @@ -70,7 +70,7 @@ (define (is_macro_call ast env) (and (list? ast) (> (length ast) 0) - (and=> (env-check (car ast) env) is-macro?))) + (and=> (env-check (car ast) env) is-macro))) (define (_macroexpand ast env) (cond diff --git a/guile/types.scm b/guile/types.scm index 90ab01c41c..7329cd5ce4 100644 --- a/guile/types.scm +++ b/guile/types.scm @@ -21,7 +21,7 @@ make-atom atom? atom-val atom-val-set! make-callable callable? callable-is_macro callable-is_macro-set! callable-closure - is-func? is-macro? make-func callable-apply + is-func is-func? is-macro is-macro? make-func callable-apply callable-unbox-set! callable-unbox callable-meta-info hash-table-clone box? box unbox) @@ -77,8 +77,10 @@ (eq? (callable-is_macro c) b) c)) -(define (is-func? c) (callable-check c #f)) -(define (is-macro? c) (callable-check c #t)) +(define (is-func c) (callable-check c #f)) +(define (is-func? c) (and (is-func c) #t)) +(define (is-macro c) (callable-check c #t)) +(define (is-macro? c) (and (is-macro c) #t)) (define (hash-table-clone ht) (list->hash-map (hash-fold (lambda (k v p) (cons k (cons v p))) '() ht))) diff --git a/java/src/main/java/mal/core.java b/java/src/main/java/mal/core.java index 3ac6cce292..23843b8a6e 100644 --- a/java/src/main/java/mal/core.java +++ b/java/src/main/java/mal/core.java @@ -49,6 +49,11 @@ public MalVal apply(MalList args) throws MalThrowable { return args.nth(0) == False ? True : False; } }; + static MalFunction number_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0) instanceof MalInteger ? True : False; + } + }; static MalFunction string_Q = new MalFunction() { public MalVal apply(MalList args) throws MalThrowable { if (!(args.nth(0) instanceof MalString)) { return False; } @@ -87,6 +92,18 @@ public MalVal apply(MalList args) throws MalThrowable { return True; } }; + static MalFunction fn_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (!(args.nth(0) instanceof MalFunction)) { return False; } + return ((MalFunction)args.nth(0)).isMacro() ? False : True; + } + }; + static MalFunction macro_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (!(args.nth(0) instanceof MalFunction)) { return False; } + return ((MalFunction)args.nth(0)).isMacro() ? True : False; + } + }; // String functions @@ -545,11 +562,14 @@ public MalVal apply(MalList a) throws MalThrowable { .put("nil?", nil_Q) .put("true?", true_Q) .put("false?", false_Q) + .put("number?", number_Q) .put("string?", string_Q) .put("symbol", symbol) .put("symbol?", symbol_Q) .put("keyword", keyword) .put("keyword?", keyword_Q) + .put("fn?", fn_Q) + .put("macro?", macro_Q) .put("pr-str", pr_str) .put("str", str) diff --git a/mal/core.mal b/mal/core.mal index a766b80125..15bcac3ec0 100644 --- a/mal/core.mal +++ b/mal/core.mal @@ -1,14 +1,31 @@ +(def! _fn? (fn* [x] + (if (fn? x) + (if (get (meta x) "ismacro") + false + true) + false))) + +(def! macro? (fn* [x] + (if (fn? x) + (if (get (meta x) "ismacro") + true + false) + false))) + (def! core_ns [["=" =] ["throw" throw] ["nil?" nil?] ["true?" true?] ["false?" false?] + ["number?" number?] ["string?" string?] ["symbol" symbol] ["symbol?" symbol?] ["keyword" keyword] ["keyword?" keyword?] + ["fn?" _fn?] + ["macro?" macro?] ["pr-str" pr-str] ["str" str] From f18417417c17e1023bc7e70d18bf85e5206d3097 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Tue, 17 Oct 2017 05:54:16 +0000 Subject: [PATCH 0225/1998] io, swift3, vb: Add number?, fn?, macro? --- io/MalCore.io | 4 ++++ swift3/Sources/core.swift | 19 +++++++++++++++++++ vb/core.vb | 27 +++++++++++++++++++++++++++ 3 files changed, 50 insertions(+) diff --git a/io/MalCore.io b/io/MalCore.io index 2a99470981..9841996e69 100644 --- a/io/MalCore.io +++ b/io/MalCore.io @@ -83,6 +83,10 @@ MalCore := Object clone do( "symbol?", block(a, a at(0) type == "MalSymbol"), "keyword", block(a, MalKeyword with(a at(0))), "keyword?", block(a, a at(0) type == "MalKeyword"), + "number?", block(a, a at(0) type == "Number"), + "fn?", block(a, (a at(0) type == "Block") or + ((a at(0) type == "MalFunc") and (a at(0) isMacro not))), + "macro?", block(a, (a at(0) type == "MalFunc") and (a at(0) isMacro)), "pr-str", block(a, a map(s, s malPrint(true)) join(" ")), "str", block(a, a map(s, s malPrint(false)) join("")), diff --git a/swift3/Sources/core.swift b/swift3/Sources/core.swift index fc4235b74c..dcf5e300dc 100644 --- a/swift3/Sources/core.swift +++ b/swift3/Sources/core.swift @@ -85,6 +85,25 @@ let core_ns: Dictionary) throws -> MalVal> = [ default: return MV.MalFalse } }, + "number?": { + switch $0[0] { + case MV.MalInt(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "fn?": { + switch $0[0] { + case MalVal.MalFunc(_, nil, _, _, _, _), + MalVal.MalFunc(_, _, _, _, false, _): return MV.MalTrue + default: return MV.MalFalse + } + }, + "macro?": { + switch $0[0] { + case MalVal.MalFunc(_, _, _, _, true, _): return MV.MalTrue + default: return MV.MalFalse + } + }, "pr-str": { // TODO: if the following two statements are combined into one, we get diff --git a/vb/core.vb b/vb/core.vb index 27c6974c9d..6534de5a69 100644 --- a/vb/core.vb +++ b/vb/core.vb @@ -104,6 +104,30 @@ Namespace Mal End If End Function + Shared Function number_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalInt Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function fn_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalFunc AndAlso Not DirectCast(a(0),MalFunc).isMacro() Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function macro_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalFunc AndAlso DirectCast(a(0),MalFunc).isMacro() Then + return MalTrue + Else + return MalFalse + End If + End Function + ' Number functions Shared Function lt(a As MalList) As MalVal @@ -454,6 +478,9 @@ Namespace Mal ns.Add("string?", New MalFunc(AddressOf string_Q)) ns.Add("keyword", new MalFunc(AddressOf keyword)) ns.Add("keyword?", New MalFunc(AddressOf keyword_Q)) + ns.Add("number?", New MalFunc(AddressOf number_Q)) + ns.Add("fn?", New MalFunc(AddressOf fn_Q)) + ns.Add("macro?", New MalFunc(AddressOf macro_Q)) ns.Add("pr-str",New MalFunc(AddressOf pr_str)) ns.Add("str", New MalFunc(AddressOf str)) From 684d814dd870b524638947d0767ac5018c91cfd3 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 18 Oct 2017 00:14:31 +0100 Subject: [PATCH 0226/1998] String concatenation working Progress on printer, not yet working. string_append_string now appends one string to the end of another, handling long strings with multiple Array blocks. --- nasm/printer.asm | 42 ++++++++++++ nasm/reader.asm | 16 +++++ nasm/step1_read_print.asm | 139 +++++++++++++++++++++++++++++++++++++- 3 files changed, 194 insertions(+), 3 deletions(-) diff --git a/nasm/printer.asm b/nasm/printer.asm index 11dd2b4d10..15e91fb500 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -75,6 +75,48 @@ pr_str: call itostring ret .list: + mov r12, rsi ; Input list + + call string_new ; String in rax + ; Put '(' onto string + mov rsi, rax + mov cl, '(' + call string_append_char + + ; loop through list + push rsi ; Save output string + + ; Extract values and print + ; mov bl, BYTE [r12] + ; xor bl, container_list ; Change from list to value + ; mov BYTE [r12], bl + ; mov rsi, r12 + + mov rsi, r12 + mov BYTE [rsi], maltype_integer + call pr_str ; String in rax + + ; mov bl, BYTE [r12] + ; xor bl, container_list ; Change from value to list + ; mov BYTE [r12], bl + + pop rsi ; Restore output string + ; concatenate strings in rax and rsi + mov rdx, rax ; String to be copied + + push rax + push rbx + push rcx + call string_append_string + pop rcx + pop rbx + pop rax + + ; put ')' at the end of the string + mov cl, ')' + call string_append_char + + mov rax, rsi ret .symbol: ret diff --git a/nasm/reader.asm b/nasm/reader.asm index 8c448a9c3f..bd59de351a 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -82,11 +82,15 @@ read_str: ; Start new list call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_nil) + + cmp r13, 0 jne .list_link_last ; This is the top-level list mov r15, rax + jmp .list_done .list_link_last: ; The new list is nested @@ -104,6 +108,17 @@ read_str: ; -------------------------------- .list_end: + + ; Check if there is a list + cmp r13, 0 + jne .list_end_ok + + call alloc_cons + mov [rax], BYTE maltype_nil + + ret + +.list_end_ok: ; Put the current list into r8 mov r8, r13 @@ -113,6 +128,7 @@ read_str: jmp .append_object ; Add R8 to list in R13 + ; -------------------------------- .append_object: ; Append Cons in R8 to list in R13 diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 3a60c56686..6a8915a908 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -190,6 +190,8 @@ section .text ;; Array alloc_array() ;; ;; Returns the address of an Array object in RAX +;; +;; Working registers: rbx alloc_array: ; Get the address of a free array @@ -382,6 +384,7 @@ release_object: string_new: call alloc_array mov [rax], BYTE maltype_string + mov QWORD [rax + Array.next], 0 ret ;; Convert a raw string to a String type @@ -416,6 +419,125 @@ raw_to_string: ;; Appends a character to a string ;; Input: Address of string in RSI, character in CL string_append_char: + mov eax, DWORD [rsi + Array.length] + inc eax + mov DWORD [rsi + Array.length], eax + dec eax + add rax, rsi + add rax, Array.data ; End of data + mov [rax], BYTE cl + ret + +;; Appends a string to the end of a string +;; +;; Input: String to be modified in RSI +;; String to be copied in RDX +;; +;; Output: Modified string in RSI +;; +;; Working registers: +;; rax Array chunk for output (copied to) +;; rbx Array chunk for input (copied from) +;; cl Character being copied +;; r8 Address of destination +;; r9 Destination end address +;; r10 Address of source +;; r11 Source end address +string_append_string: + ; copy source Array address to rbx + mov rbx, rdx + + ; source data address in r10 + mov r10, rbx + add r10, Array.data ; Start of the data + + ; source data end address in r11 + mov r11, r10 + mov r8d, DWORD [rbx + Array.length] + add r11, r8 + + ; Find the end of the string in RSI + ; and put the address of the Array object into rax + mov rax, rsi +.find_string_end: + mov r8, QWORD [rax + Array.next] + cmp r8, 0 ; Next chunk is null + je .got_dest_end ; so reached end + + mov rax, r8 ; Go to next chunk + jmp .find_string_end +.got_dest_end: + + ; destination data address into r8 + mov r8, rax + add r8, Array.data + add r8d, DWORD [rax + Array.length] + + ; destination data end into r9 + mov r9, rax + add r9, Array.size + +.copy_loop: + ; Copy one byte from source to destination + mov cl, BYTE [r10] + mov BYTE [r8], cl + + ; move source to next byte + inc r10 + ; Check if we've reached the end of this Array + cmp r10, r11 + jne .source_ok + + ; have reached the end of the source Array + mov rbx, QWORD [rbx + Array.next] ; Get the next Array address + cmp rbx, 0 ; Test if it's null + je .finished ; No more, so we're done + ; Move on to next Array object + + ; Get source address into r10 + mov r10, rbx + add r10, Array.data ; Start of the data + + ; Source end address + mov r11, rbx + add r11, Array.size + +.source_ok: + + ; Move destination to next byte + inc r8 + ; Check if we've reached end of the Array + cmp r8, r9 + jne .copy_loop ; Next byte + + ; Reached the end of the destination + ; Need to allocate another Array + push rax + push rbx + call alloc_array ; New Array in rax + mov r8, rax ; copy to r8 + pop rbx + pop rax + + ; Previous Array in rax. + ; Add a reference to the new array and set length + mov QWORD [rax + Array.next], r8 + mov DWORD [rax + Array.length], (Array.size - Array.data) + mov rax, r8 ; new array + add r8, Array.data ; Start of data + + mov r9, rax + add r9, Array.size + +.finished: + ; Compare r8 (destination) with data start + ; to get length of string + sub r8, rax + sub r8, Array.data + inc r8 + ; r8 now contains length + mov DWORD [rax + Array.length], r8d + ret ;; ------------------------------------------- @@ -500,9 +622,7 @@ itostring: jnz .divideLoop ; jump if not zero to the label divideLoop ; Get an Array object to put the string into - call alloc_array ; Address in RAX - - mov [rax], BYTE maltype_string ; mark as a string + call string_new ; Address in RAX ; put length into string mov [rax + Array.length], ecx @@ -622,6 +742,19 @@ read_line: _start: + + ; mov rsi, test_string1 + ; mov edx, test_string1.len + ; call raw_to_string ; address in rax + ; push rax + ; mov rsi, test_string2 + ; mov edx, test_string2.len + ; call raw_to_string + ; pop rsi + ; mov rdx, rax + ; call string_append_string + ; call print_string + ; ----------------------------- ; Main loop From 9968eecb8ee92bf6b0409dd5dadc21051e571365 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 19 Oct 2017 10:06:40 +0000 Subject: [PATCH 0227/1998] fsharp, livescript, ts: Add number?, fn?, macro? --- fsharp/core.fs | 3 +++ fsharp/env.fs | 3 +++ livescript/core.ls | 4 ++++ ts/core.ts | 9 +++++++++ 4 files changed, 19 insertions(+) diff --git a/fsharp/core.fs b/fsharp/core.fs index cbd08206f2..2ab21a745a 100644 --- a/fsharp/core.fs +++ b/fsharp/core.fs @@ -149,6 +149,9 @@ module Core let isSymbol = isPattern (function Symbol(_) -> true | _ -> false) let isKeyword = isPattern (function Keyword(_) -> true | _ -> false) let isString = isPattern (function String(_) -> true | _ -> false) + let isNumber = isPattern (function Number(_) -> true | _ -> false) + let isFn = isPattern (function BuiltInFunc(_, _, _) | Func(_, _, _, _, _, _) -> true | _ -> false) + let isMacro = isPattern (function Macro(_, _, _, _, _, _) -> true | _ -> false) let isSequential = isPattern (function Node.Seq(_) -> true | _ -> false) let isVector = isPattern (function Vector(_, _) -> true | _ -> false) let isMap = isPattern (function Map(_, _) -> true | _ -> false) diff --git a/fsharp/env.fs b/fsharp/env.fs index 73f95afdc5..e82ad92415 100644 --- a/fsharp/env.fs +++ b/fsharp/env.fs @@ -79,6 +79,9 @@ module Env wrap "string?" Core.isString wrap "keyword?" Core.isKeyword wrap "keyword" Core.keyword + wrap "number?" Core.isNumber + wrap "fn?" Core.isFn + wrap "macro?" Core.isMacro wrap "sequential?" Core.isSequential wrap "vector?" Core.isVector wrap "vector" Core.vector diff --git a/livescript/core.ls b/livescript/core.ls index c1bc034838..524d131942 100644 --- a/livescript/core.ls +++ b/livescript/core.ls @@ -229,6 +229,10 @@ export ns = do 'keyword?': fn (ast) -> const-bool ast.type == \keyword + 'number?': fn (ast) -> const-bool ast.type == \int + 'fn?': fn (ast) -> const-bool (ast.type == \function and not ast.is_macro) + 'macro?': fn (ast) -> const-bool (ast.type == \function and ast.is_macro) + 'vector': fn (...params) -> {type: \vector, value: params} 'vector?': fn (ast) -> const-bool ast.type == \vector diff --git a/ts/core.ts b/ts/core.ts index c004e0bc6a..ddf5fcb632 100644 --- a/ts/core.ts +++ b/ts/core.ts @@ -45,6 +45,15 @@ export const ns: Map = (() => { "keyword?"(v: MalType) { return new MalBoolean(v.type === Node.Keyword); }, + "number?"(v: MalType) { + return new MalBoolean(v.type === Node.Number); + }, + "fn?"(v: MalType) { + return new MalBoolean(v.type === Node.Function && !v.isMacro); + }, + "macro?"(v: MalType) { + return new MalBoolean(v.type === Node.Function && v.isMacro); + }, "pr-str"(...args: MalType[]): MalString { return new MalString(args.map(v => prStr(v, true)).join(" ")); From e69ec598954224d97e0cd8a6a0df3f297db631bf Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 19 Oct 2017 23:01:33 +0100 Subject: [PATCH 0228/1998] pr_str prints simple lists, reader improving Can now print (int int) from a list of two Cons objects. Reader code should now read lists, but not yet working. --- nasm/printer.asm | 83 +++++++--- nasm/reader.asm | 338 +++++++++++++++++++++----------------- nasm/step1_read_print.asm | 27 ++- 3 files changed, 268 insertions(+), 180 deletions(-) diff --git a/nasm/printer.asm b/nasm/printer.asm index 15e91fb500..79304ea302 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -18,15 +18,21 @@ section .text ;; ;; Output: Address of string in RAX ;; -;; Modifies: RCX -;; Calls: raw_to_string, +;; Modifies: +;; RCX +;; R12 +;; R13 +;; Calls: raw_to_string, +;; +;; pr_str: ; Get the type mov cl, BYTE [rsi] - + ; Check if it's already a string cmp cl, maltype_string + jne .not_string mov rax, rsi ret @@ -75,45 +81,80 @@ pr_str: call itostring ret .list: + mov r12, rsi ; Input list call string_new ; String in rax + mov r13, rax ; Output string in r13 + ; Put '(' onto string mov rsi, rax mov cl, '(' call string_append_char ; loop through list - push rsi ; Save output string +.list_loop: ; Extract values and print - ; mov bl, BYTE [r12] - ; xor bl, container_list ; Change from list to value - ; mov BYTE [r12], bl - ; mov rsi, r12 - + mov rsi, r12 - mov BYTE [rsi], maltype_integer + mov cl, BYTE [rsi] ; Get type + + ; Check if it's a pointer (address) + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + je .list_loop_pointer + + ; A value (nil, int etc. or function) + xor cl, container_list ; Remove list type -> value + mov BYTE [rsi], cl + + push r13 + push r12 call pr_str ; String in rax + pop r12 + pop r13 - ; mov bl, BYTE [r12] - ; xor bl, container_list ; Change from value to list - ; mov BYTE [r12], bl + mov cl, BYTE [r12] + or cl, container_list ; Restore list type + mov BYTE [r12], cl + jmp .list_loop_got_str +.list_loop_pointer: + mov rsi, [rsi + Cons.car] ; Address of object + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 - pop rsi ; Restore output string +.list_loop_got_str: ; concatenate strings in rax and rsi + mov rsi, r13 ; Output string mov rdx, rax ; String to be copied - - push rax - push rbx - push rcx + call string_append_string - pop rcx - pop rbx - pop rax + + ; Check if this is the end of the list + mov cl, BYTE [r12 + Cons.typecdr] + cmp cl, content_nil + je .list_finished + + ; More left in the list + + ; Add space between values + mov cl, ' ' + mov rsi, r13 + call string_append_char + + ; Get next Cons + mov r12, [r12 + Cons.cdr] + jmp .list_loop +.list_finished: ; put ')' at the end of the string mov cl, ')' + mov rsi, r13 call string_append_char mov rax, rsi diff --git a/nasm/reader.asm b/nasm/reader.asm index bd59de351a..5507bac7a3 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -10,32 +10,34 @@ section .text ;; Output: Address of object in RAX ;; ;; Uses registers: -;; R13 Address of the current list (starts 0) +;; R12 Address of the start of the current list (starts 0) +;; R13 Address of the current list tail ;; R14 Stack pointer at start. Used for unwinding on error ;; R15 Address of first list. Used for unwinding on error ;; +;; In addition, the tokenizer uses +;; +;; RAX (object return) +;; RBX +;; RCX (character return in CL) +;; RDX +;; R8 ** State must be preserved +;; R9 ** +;; R10 ** +;; read_str: ; Initialise tokenizer call tokenizer_init - ; Get the next token - call tokenizer_next - ; Set current list to zero - mov r13, 0 + mov r12, 0 + + ; Set first list to zero + mov r15, 0 ; Save stack pointer for unwinding mov r14, rsp - ; check what type of token by testing CL - cmp cl, 0 - jne .got_token - - ; No tokens. Return 'nil' - call alloc_cons - mov [rax], BYTE maltype_nil - ret - .read_loop: call tokenizer_next @@ -43,126 +45,170 @@ read_str: jne .got_token ; Unexpected end of tokens - - mov rsp, r14 ; Restore stack - mov rsi, r13 ; Top Cons - call release_cons ; This should delete everything - - call alloc_cons - mov [rax], BYTE maltype_nil - - ret + jmp .unwind .got_token: + + cmp cl, 'i' + je .finished cmp cl, '(' je .list_start cmp cl, ')' - je .list_end - - cmp cl, 'i' - je .append_object ; Cons already in R8 - + je .return_nil ; Note: if reading a list, cl will be tested in the list reader + ; Unknown - call alloc_cons - mov [rax], BYTE maltype_nil - ret + jmp .return_nil ; -------------------------------- + .list_start: ; Push current list onto stack + push r12 push r13 - ; Push current state of the tokenizer - push rsi - push rax - push rbx + ; Get the first value + ; Note that we call rather than jmp because the first + ; value needs to be treated differently. There's nothing + ; to append to yet... + call .read_loop + + ; rax now contains the first object + cmp cl, ')' ; Check if it was end of list + je .list_has_contents + mov cl, 0 ; so ')' doesn't propagate to nested lists + pop r13 + pop r12 + ret ; Returns 'nil' given "()" +.list_has_contents: + ; If this is a Cons then use it + ; If not, then need to allocate a Cons + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .list_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object ; Start new list + push rax call alloc_cons ; Address in rax - - mov [rax], BYTE (block_cons + container_list + content_nil) - - - cmp r13, 0 - jne .list_link_last + pop rbx + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car - ; This is the top-level list - mov r15, rax - jmp .list_done +.list_is_value: + ; Cons in RAX + ; Make sure it's marked as a list + mov cl, BYTE [rax] + or cl, container_list + mov [rax], BYTE cl -.list_link_last: - ; The new list is nested - mov [r13 + Cons.cdr], rax - mov [r13 + Cons.typecdr], BYTE content_pointer -.list_done: - mov r13, rax ; Switch to new list + mov r13, rax ; Set current list + cmp r15, 0 ; Test if first list + jne .list_read_loop + mov r15, rax ; Save the first, for unwinding - ; Restore state - pop rbx - pop rax - pop rsi +.list_read_loop: + ; Repeatedly get the next value in the list + ; (which may be other lists) + ; until we get a ')' token - jmp .read_loop + call .read_loop ; object in rax - ; -------------------------------- -.list_end: + cmp cl, ')' ; Check if it was end of list + je .list_done - ; Check if there is a list - cmp r13, 0 - jne .list_end_ok + ; Test if this is a Cons value + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .list_loop_is_value - call alloc_cons - mov [rax], BYTE maltype_nil + ; If here then not a simple value, so need to allocate + ; a Cons object - ret - -.list_end_ok: + ; Start new list + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car - ; Put the current list into r8 - mov r8, r13 +.list_loop_is_value: + ; Cons in RAX - ; Pop the previous list - pop r13 + ; Make sure it's marked as a list + mov cl, BYTE [rax] + or cl, container_list + mov [rax], BYTE cl - jmp .append_object ; Add R8 to list in R13 - + ; Append to r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax ; Set current list - ; -------------------------------- -.append_object: - ; Append Cons in R8 to list in R13 - ; If no list in R13 (address is zero) then returns - ; with R8 moved to RAX - - cmp r13, 0 - je .finished + jmp .list_read_loop + +.list_done: + ; Terminate the list + mov [r13 + Cons.typecdr], BYTE content_nil + mov QWORD [r13 + Cons.cdr], QWORD 0 + mov rax, r12 ; Start of current list - ; Append to list - mov [r13 + Cons.cdr], r8 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r8 + Cons.typecdr], BYTE content_nil + mov [rax], BYTE (container_list + content_int) + + ; Pop previous list (if any) + pop r13 + pop r12 + ret - jmp .read_loop ; -------------------------------- .finished: - ; No list to add this object to, so finished - mov rax, r8 ret +.unwind: + ; Jump to here cleans up + + mov rsp, r14 ; Rewind stack pointer + cmp r15, 0 ; Check if there is a list + jne .return_nil + mov rsi, r15 + call release_cons ; releases everything recursively + ; fall through to return_nil +.return_nil: + ; Allocates a new Cons object with nil and returns + ; Cleanup should happen before jumping here + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + + ;; Initialise the tokenizer ;; ;; Input: Address of string in RSI ;; ;; NOTE: This uses RSI, RAX and RBX, and expects these to be preserved ;; between calls to tokenizer_next_char +;; +;; R9 Address of string +;; R10 Position in data array +;; R11 End of data array +;; tokenizer_init: - ; Put start of data array into rax - mov rax, rsi - add rax, Array.data - ; Put end of data array into rbx - mov ebx, [rsi + Array.length] ; Length of array, zero-extended - add rbx, rax + ; Save string to r9 + mov r9, rsi + ; Put start of data array into r10 + mov r10, rsi + add r10, Array.data + ; Put end of data array into r11 + mov r11d, [rsi + Array.length] ; Length of array, zero-extended + add r11, r10 ret @@ -171,30 +217,30 @@ tokenizer_init: ;; contiguous block of memory, but may use multiple Array ;; objects in a linked list ;; -;; If no chunks are left, then RAX = RBX +;; If no chunks are left, then R10 = R11 tokenizer_next_chunk: - mov rax, [rsi + Array.next] - cmp rax, 0 + mov r10, [r9 + Array.next] + cmp r10, 0 je .no_more ; More chunks left - mov rsi, rax + mov rsi, r10 call tokenizer_init ret .no_more: - ; No more chunks left. RAX is zero - mov rbx, rax + ; No more chunks left. R10 is zero + mov r11, r10 ret ;; Moves the next char into CL ;; If no more, puts 0 into CL tokenizer_next_char: ; Check if we have reached the end of this chunk - cmp rax, rbx + cmp r10, r11 jne .chars_remain ; Hit the end. See if there is another chunk call tokenizer_next_chunk - cmp rax, rbx + cmp r10, r11 jne .chars_remain ; Success, got another ; No more chunks @@ -202,8 +248,8 @@ tokenizer_next_char: ret .chars_remain: - mov cl, BYTE [rax] - inc rax ; point to next byte + mov cl, BYTE [r10] + inc r10 ; point to next byte ret ;; Get the next token @@ -211,11 +257,16 @@ tokenizer_next_char: ;; - 0 : Nil, finished ;; - Characters ()[]()'`~^@ ;; - Pair '~@', represented by code 1 -;; - A string: " in CL, and address in R8 +;; - A string: " in CL, and address in RAX ;; - An integer: 'i' in CL ;; -;; Address of object in R8 -;; +;; Address of object in RAX +;; +;; May use registers: +;; RBX +;; RCX +;; RDX +;; tokenizer_next: .next_char: @@ -227,8 +278,8 @@ tokenizer_next: ; Here expect to have: ; - The current character in CL - ; - Address of next data in rax - ; - Address of data end in rbx + ; - Address of next data in r10 + ; - Address of data end in r11 ; Skip whitespace or commas cmp cl, ' ' ; Space @@ -279,11 +330,6 @@ tokenizer_next: ; Start integer ; accumulate in EDX xor edx, edx - - ; Push current state of the tokenizer - push rsi - push rax - push rbx .integer_loop: ; Here have a char 0-9 in CL @@ -292,9 +338,7 @@ tokenizer_next: add edx, ebx ; Peek at next character - push rdx call tokenizer_next_char ; Next char in CL - pop rdx cmp cl, '0' jl .integer_finished @@ -308,22 +352,18 @@ tokenizer_next: .integer_finished: ; Next char not an int - push rdx ; Save the integer + push rdx ; Save the integer ; Get a Cons object to put the result into call alloc_cons + + pop rdx ; Restore integer + ; Address of Cons now in RAX - mov r8, rax - mov [r8], BYTE maltype_integer + mov [rax], BYTE maltype_integer - pop rdx - mov [r8 + Cons.car], rdx + mov [rax + Cons.car], rdx - ; Restore state - pop rbx - pop rax - pop rsi - mov cl, 'i' ; Mark as an integer ret @@ -335,36 +375,25 @@ tokenizer_next: .handle_string: ; Get an array to put the string into - - ; save state of tokenizer - push rsi - push rax - push rbx - - call alloc_array - mov r8, rax ; Address of array in r8 - mov [r8], BYTE maltype_string ; mark as a string - ; restore state - pop rbx - pop rax - pop rsi + call string_new ; Array in RAX - ; Put start of data array into r9 - mov r9, r8 - add r9, Array.data - ; Put end of data array into r10 - mov r10d, [rsi + Array.length] ; Length of array, zero-extended - add r10, r9 + ; Put start of data array into rbx + mov rbx, rax + add rbx, Array.data + ; Put end of data array into rdx + mov edx, DWORD [rax + Array.length] ; Length of array, zero-extended + add rdx, rbx ; Now read chars from input string and push into output .string_loop: + call tokenizer_next_char cmp cl, 0 ; End of characters je .error cmp cl, 34 ; Finishing '"' - je .found ; Leave '"' in CL + je .string_done ; Leave '"' in CL cmp cl, 92 ; Escape '\' jne .end_string_escape @@ -389,13 +418,20 @@ tokenizer_next: ; Put CL onto result array ; NOTE: this doesn't handle long strings (multiple memory blocks) - mov [r9], cl - inc r9 + mov [rbx], cl + inc rbx jmp .string_loop - + +.string_done: + ; Calculate the length from rbx + sub rbx, Array.data + sub rbx, rax + mov [rax+Array.length], DWORD ebx ret + ; --------------------------------- + .tokens_finished: mov cl, 0 ; End of tokens ret @@ -404,9 +440,9 @@ tokenizer_next: ; Could have '~' or '~@'. Need to peek at the next char ; Push current state of the tokenizer - push rsi - push rax - push rbx + push r9 + push r10 + push r11 call tokenizer_next_char ; Next char in CL cmp cl, '@' jne .tilde_no_amp ; Just '~', not '~@' @@ -422,7 +458,7 @@ tokenizer_next: pop rbx pop rax pop rsi - ; fall through to finished + ; fall through to found .found: ret diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 6a8915a908..644c9cd7ee 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -139,6 +139,19 @@ test_string2: db 10, "test2", 10 ;AT Array.length, dd 6 ;AT Array.data, db 'hello',10 ;IEND + +test_cons: ISTRUC Cons +AT Cons.typecar, db ( maltype_integer + 2 ) +AT Cons.typecdr, db 0 +AT Cons.car, dq 123 +IEND + +test_cons2: ISTRUC Cons +AT Cons.typecar, db ( maltype_integer + 2 ) +AT Cons.typecdr, db content_pointer +AT Cons.car, dq 456 +AT Cons.cdr, dq test_cons +IEND ;; ------------------------------------------ ;; Fixed strings for printing @@ -239,14 +252,6 @@ alloc_array: ;; onto the free list release_array: mov ax, WORD [rsi + Array.refcount] - - push rsi - push rdx - mov rsi, test_string1 - mov rdx, test_string1.len - call print_rawstring - pop rdx - pop rsi dec ax mov WORD [rsi + Array.refcount], ax @@ -755,6 +760,12 @@ _start: ; call string_append_string ; call print_string + + ; Test printing short list of integers + ; mov rsi, test_cons2 + ; call pr_str + ; mov rsi, rax + ; call print_string ; ----------------------------- ; Main loop From 49badea29ff778a36c926c49542dbd88919eefe1 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 19 Oct 2017 23:08:35 +0100 Subject: [PATCH 0229/1998] Small bug-fixes to reader Not yet working, returns nil given (10) --- nasm/reader.asm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/nasm/reader.asm b/nasm/reader.asm index 5507bac7a3..f0e075954f 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -76,7 +76,7 @@ read_str: ; rax now contains the first object cmp cl, ')' ; Check if it was end of list - je .list_has_contents + jne .list_has_contents mov cl, 0 ; so ')' doesn't propagate to nested lists pop r13 pop r12 @@ -106,7 +106,8 @@ read_str: mov cl, BYTE [rax] or cl, container_list mov [rax], BYTE cl - + + mov r12, rax ; Start of current list mov r13, rax ; Set current list cmp r15, 0 ; Test if first list jne .list_read_loop From f2abb9c15f8642804c02f05d77a1c574d07a6932 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 20 Oct 2017 07:27:03 +0100 Subject: [PATCH 0230/1998] Integer list reading and writing working * Integer tokenizer was not putting the last non-integer character back, so end of tokens was returned rather than ')' * Some typos, jne <-> je --- nasm/reader.asm | 50 +++++++++++++++++++++++++-------------- nasm/step1_read_print.asm | 2 +- 2 files changed, 33 insertions(+), 19 deletions(-) diff --git a/nasm/reader.asm b/nasm/reader.asm index f0e075954f..d8db831069 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -24,6 +24,10 @@ section .text ;; R8 ** State must be preserved ;; R9 ** ;; R10 ** +;; R12 +;; R13 +;; R14 Original stack pointer on call +;; R15 Top-level list, so all can be released on error ;; read_str: ; Initialise tokenizer @@ -64,22 +68,17 @@ read_str: ; -------------------------------- .list_start: - ; Push current list onto stack - push r12 - push r13 - + ; Get the first value ; Note that we call rather than jmp because the first ; value needs to be treated differently. There's nothing ; to append to yet... call .read_loop - + ; rax now contains the first object cmp cl, ')' ; Check if it was end of list jne .list_has_contents mov cl, 0 ; so ')' doesn't propagate to nested lists - pop r13 - pop r12 ret ; Returns 'nil' given "()" .list_has_contents: ; If this is a Cons then use it @@ -118,8 +117,12 @@ read_str: ; (which may be other lists) ; until we get a ')' token + push r12 + push r13 call .read_loop ; object in rax - + pop r13 + pop r12 + cmp cl, ')' ; Check if it was end of list je .list_done @@ -163,9 +166,6 @@ read_str: mov [rax], BYTE (container_list + content_int) - ; Pop previous list (if any) - pop r13 - pop r12 ret ; -------------------------------- @@ -177,14 +177,16 @@ read_str: mov rsp, r14 ; Rewind stack pointer cmp r15, 0 ; Check if there is a list - jne .return_nil + je .return_nil mov rsi, r15 call release_cons ; releases everything recursively ; fall through to return_nil .return_nil: ; Allocates a new Cons object with nil and returns ; Cleanup should happen before jumping here + push rcx call alloc_cons + pop rcx mov [rax], BYTE maltype_nil ret @@ -337,7 +339,12 @@ tokenizer_next: sub cl, '0' ; Convert to number between 0 and 9 movzx ebx, cl add edx, ebx - + + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + ; Peek at next character call tokenizer_next_char ; Next char in CL @@ -345,6 +352,9 @@ tokenizer_next: jl .integer_finished cmp cl, '9' jg .integer_finished + + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes imul edx, 10 @@ -352,8 +362,12 @@ tokenizer_next: .integer_finished: ; Next char not an int - - + + ; Restore state of the tokenizer + pop r11 + pop r10 + pop r9 + push rdx ; Save the integer ; Get a Cons object to put the result into call alloc_cons @@ -456,9 +470,9 @@ tokenizer_next: .tilde_no_amp: ; Restore state of the tokenizer - pop rbx - pop rax - pop rsi + pop r11 + pop r10 + pop r9 ; fall through to found .found: diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 644c9cd7ee..4bb9b5bb4b 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -183,7 +183,7 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 4 ; Number of array objects which can be created +%define heap_array_limit 10 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 From 955b354b00d6f5d42078a28b27252053a0b9a6ea Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 21 Oct 2017 08:21:56 +0100 Subject: [PATCH 0231/1998] Handles symbols, quoting and unquoting Test suite passes required and deferrable tests except: 1. () is apparently different from nil, so empty list needs to be handled differently 2. String printing currently just prints the string without quotes or escapes. --- nasm/Makefile | 6 +- nasm/printer.asm | 34 ++++++- nasm/reader.asm | 189 +++++++++++++++++++++++++++++++++++++- nasm/step1_read_print.asm | 4 +- 4 files changed, 226 insertions(+), 7 deletions(-) diff --git a/nasm/Makefile b/nasm/Makefile index 511d7c665e..1e7ea2fc65 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -1,3 +1,7 @@ -step0_repl: +step0_repl: step0_repl.asm nasm -felf64 step0_repl.asm ld -o $@ step0_repl.o + +step1_read_print: step1_read_print.asm + nasm -felf64 step1_read_print.asm + ld -o $@ step1_read_print.o diff --git a/nasm/printer.asm b/nasm/printer.asm index 79304ea302..b16e589eaf 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -132,9 +132,17 @@ pr_str: ; concatenate strings in rax and rsi mov rsi, r13 ; Output string mov rdx, rax ; String to be copied - + + push rsi ; Save output string + push rax ; save temporary string call string_append_string + ; Release the string + pop rsi ; Was in rax, temporary string + call release_array + + pop rsi ; restore output string + ; Check if this is the end of the list mov cl, BYTE [r12 + Cons.typecdr] cmp cl, content_nil @@ -160,5 +168,29 @@ pr_str: mov rax, rsi ret .symbol: + ; Make a copy of the string + call string_new ; in rax + mov ebx, DWORD [rsi + Array.length] + mov [rax + Array.length], ebx + mov rcx, rsi + add rcx, Array.data ; Start of input data + mov rdx, rsi + add rdx, Array.size ; End of input data + mov r12, rax + add r12, Array.data ; Start of output data +.symbol_copy_loop: + ; Copy [rax] -> [r12] + mov rbx, [rcx] + mov [r12], rbx + add rcx, 8 ; Next 64 bits of input + cmp rcx, rdx + je .symbol_finished + + add r12, 8 ; Next 64 bits of output + jmp .symbol_copy_loop +.symbol_finished: + + + ret diff --git a/nasm/reader.asm b/nasm/reader.asm index d8db831069..f10c9d9dd2 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -1,4 +1,16 @@ +section .data +quote_symbol_string: db "quote" +.len: equ $ - quote_symbol_string + +quasiquote_symbol_string: db "quasiquote" +.len: equ $ - quasiquote_symbol_string + +unquote_symbol_string: db "unquote" +.len: equ $ - unquote_symbol_string + +splice_unquote_symbol_string: db "splice-unquote" +.len: equ $ - splice_unquote_symbol_string section .text @@ -53,7 +65,11 @@ read_str: .got_token: - cmp cl, 'i' + cmp cl, 'i' ; An integer. Cons object in RAX + je .finished + cmp cl, '"' ; A string. Array object in RAX + je .finished + cmp cl, 's' je .finished cmp cl, '(' @@ -61,6 +77,15 @@ read_str: cmp cl, ')' je .return_nil ; Note: if reading a list, cl will be tested in the list reader + + cmp cl, 39 ; quote ' + je .handle_quote + cmp cl, '`' + je .handle_quasiquote + cmp cl, '~' + je .handle_unquote + cmp cl, 1 + je .handle_splice_unquote ; Unknown jmp .return_nil @@ -124,7 +149,7 @@ read_str: pop r12 cmp cl, ')' ; Check if it was end of list - je .list_done + je .list_done ; Have nil object in rax ; Test if this is a Cons value mov cl, BYTE [rax] @@ -159,15 +184,104 @@ read_str: jmp .list_read_loop .list_done: + ; Release nil object in rax + mov rsi, rax + call release_cons + ; Terminate the list mov [r13 + Cons.typecdr], BYTE content_nil mov QWORD [r13 + Cons.cdr], QWORD 0 mov rax, r12 ; Start of current list + + ret + + ; -------------------------------- +.handle_quote: + ; Turn 'a into (quote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "quote" + push r8 + push r9 + mov rsi, quote_symbol_string + mov edx, quote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + +.wrap_next_object: + mov [rax], BYTE maltype_symbol + mov [r12], BYTE (block_cons + container_list + content_pointer) + mov [r12 + Cons.car], rax + + ; Get the next object + push r12 + call .read_loop ; object in rax + pop r12 + + mov r13, rax ; Put object to be quoted in r13 - mov [rax], BYTE (container_list + content_int) + call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r13 + mov [rax + Cons.typecdr], BYTE content_nil + ; Cons object in rax. Append to object in r12 + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + + mov rax, r12 ret + ; -------------------------------- +.handle_quasiquote: + ; Turn `a into (quasiquote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "quasiquote" + push r8 + push r9 + mov rsi, quasiquote_symbol_string + mov edx, quasiquote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- +.handle_unquote: + ; Turn ~a into (unquote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "unquote" + push r8 + push r9 + mov rsi, unquote_symbol_string + mov edx, unquote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- +.handle_splice_unquote: + ; Turn ~@a into (unquote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "unquote" + push r8 + push r9 + mov rsi, splice_unquote_symbol_string + mov edx, splice_unquote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + ; -------------------------------- .finished: ret @@ -188,6 +302,7 @@ read_str: call alloc_cons pop rcx mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil ret @@ -262,6 +377,7 @@ tokenizer_next_char: ;; - Pair '~@', represented by code 1 ;; - A string: " in CL, and address in RAX ;; - An integer: 'i' in CL +;; - A symbol: 's' in CL, address in RAX ;; ;; Address of object in RAX ;; @@ -382,12 +498,78 @@ tokenizer_next: mov cl, 'i' ; Mark as an integer ret + ; ------------------------------------------- .handle_symbol: + ; Read characters until reaching whitespace, special character or end + call string_new + mov rsi, rax ; Output string in rsi + +.symbol_loop: + ; Put the current character into the array + call string_append_char + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + call tokenizer_next_char + cmp cl, 0 ; End of characters + je .symbol_finished + + cmp cl, ' ' ; Space + je .symbol_finished + cmp cl, ',' ; Comma + je .symbol_finished + cmp cl, 9 ; Tab + + cmp cl, '(' + je .symbol_finished + cmp cl, ')' + je .symbol_finished + cmp cl, '[' + je .symbol_finished + cmp cl, ']' + je .symbol_finished + cmp cl, '{' + je .symbol_finished + cmp cl, '}' + je .symbol_finished + cmp cl, 39 ; character ' + je .symbol_finished + cmp cl, 96 ; character ` + je .symbol_finished + cmp cl, '^' + je .symbol_finished + cmp cl, '@' + je .symbol_finished + cmp cl, '~' + je .symbol_finished + cmp cl, ';' ; Start of a comment + je .symbol_finished + cmp cl, 34 ; Opening string quotes + je .symbol_finished + + ; Keeping current character + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes + + jmp .symbol_loop ; Append to array + +.symbol_finished: + ; Not keeping current character + ; Restore state of the tokenizer + pop r11 + pop r10 + pop r9 + + mov rax, rsi + mov [rax], BYTE maltype_symbol ; Mark as a symbol + mov cl, 's' ; used by read_str ret + ; -------------------------------------------- .handle_string: ; Get an array to put the string into @@ -469,6 +651,7 @@ tokenizer_next: ret .tilde_no_amp: + mov cl, '~' ; Restore state of the tokenizer pop r11 pop r10 diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 4bb9b5bb4b..637ddce95c 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -801,9 +801,9 @@ _start: pop rsi call release_array - ; Release the Cons from read_str + ; Release the object from read_str pop rsi - call release_cons + call release_object ; Could be Cons or Array ; Release the string pop rsi From 1eb4f83354506319cac8a3070b99d83381a7ed4e Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 22 Oct 2017 00:05:33 +0100 Subject: [PATCH 0232/1998] String printing and negative numbers * Prints strings, escaping " and \n * Handles negative integers, reading and printing. Difference between "- 10" (symbol, number) and "-10" (number) All essential and deferrable tests pass --- nasm/printer.asm | 68 +++++++++++++++++++++++++++++++++++++-- nasm/reader.asm | 52 +++++++++++++++++++++++++++++- nasm/step1_read_print.asm | 42 ++++++++++++++++++++---- 3 files changed, 151 insertions(+), 11 deletions(-) diff --git a/nasm/printer.asm b/nasm/printer.asm index b16e589eaf..584491d9a2 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -34,9 +34,68 @@ pr_str: cmp cl, maltype_string jne .not_string - mov rax, rsi - ret + + ; --------------------------- + ; Handle string + + call string_new ; Output string in rax + + mov r12, rax + add r12, Array.data ; Output data + mov r13, rsi + add r13, Array.data ; Input data + mov r14d, DWORD [rsi + Array.length] + add r14, Array.data + add r14, rsi ; End of input data + + ; Put " at start of output string + mov [r12], BYTE '"' + inc r12 + + ; Loop through the input string, escaping characters + +.string_loop: + cmp r13, r14 + je .string_finished + + mov cl, BYTE [r13] ; Get next character + inc r13 + + cmp cl, '"' ; + je .string_escape_char + + cmp cl, 10 ; Newline + je .string_newline + + ; No special case, just copy the byte + mov [r12], BYTE cl + inc r12 + jmp .string_loop + +.string_newline: + mov cl, 'n' + ;jmp .string_escape_char +.string_escape_char: ; Add a '\' before char in cl + mov [r12], BYTE 92 ; Escape '\' + inc r12 + mov [r12], BYTE cl + inc r12 + jmp .string_loop + +.string_finished: + + mov [r12], BYTE '"' ; At the end + inc r12 + ; Calculate length of string + sub r12, rax + sub r12, Array.data + + mov [rax + Array.length], DWORD r12d + + ret + + ; ---------------------------- .not_string: ; Now test the container type (value, list) @@ -105,6 +164,9 @@ pr_str: and ch, content_mask cmp ch, content_pointer je .list_loop_pointer + + cmp ch, content_empty + je .list_check_end ; A value (nil, int etc. or function) xor cl, container_list ; Remove list type -> value @@ -142,7 +204,7 @@ pr_str: call release_array pop rsi ; restore output string - +.list_check_end: ; Check if this is the end of the list mov cl, BYTE [r12 + Cons.typecdr] cmp cl, content_nil diff --git a/nasm/reader.asm b/nasm/reader.asm index f10c9d9dd2..4048453427 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -104,6 +104,8 @@ read_str: cmp cl, ')' ; Check if it was end of list jne .list_has_contents mov cl, 0 ; so ')' doesn't propagate to nested lists + ; Set list to empty + mov [rax], BYTE maltype_empty_list ret ; Returns 'nil' given "()" .list_has_contents: ; If this is a Cons then use it @@ -439,12 +441,54 @@ tokenizer_next: ; Could be number or symbol + cmp cl, '-' ; Minus sign + je .handle_minus + mov ch, 0 + ; Check for a character 0-9 cmp cl, '0' jl .handle_symbol cmp cl, '9' jg .handle_symbol + ; Here an integer + jmp .handle_integer + +.handle_minus: + + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + + ; Get the next character + call tokenizer_next_char + + ; Check if it is a number + cmp cl, '0' + jl .minus_not_number + cmp cl, '9' + jg .minus_not_number + + ; Here is a number + mov ch, '-' ; Put '-' in ch for later + + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes + + jmp .handle_integer + +.minus_not_number: + + ; Restore state + pop r11 + pop r10 + pop r9 + + mov cl, '-' ; Put back + + jmp .handle_symbol + .handle_integer: ; Start integer ; accumulate in EDX @@ -489,7 +533,13 @@ tokenizer_next: call alloc_cons pop rdx ; Restore integer - + + ; Check if the number should be negative + cmp ch, '-' + jne .integer_store + neg rdx + +.integer_store: ; Address of Cons now in RAX mov [rax], BYTE maltype_integer diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 637ddce95c..a9ef12b1f2 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -38,12 +38,14 @@ ;; 10 5 - Function ;; ;; Content type [4 bits]: -;; 0 0 - Nil -;; 16 1 - Bool -;; 32 2 - Char -;; 48 3 - Int -;; 64 4 - Float -;; 80 5 - Pointer (memory address) +;; 0 0 - Nil +;; 16 1 - Bool +;; 32 2 - Char +;; 48 3 - Int +;; 64 4 - Float +;; 80 5 - Pointer (memory address) +;; 96 6 - Function (instruction address) +;; 112 7 - Empty (distinct from Nil) ;; ;; These represent MAL data types as follows: ;; @@ -113,12 +115,14 @@ ENDSTRUC %define content_float 64 %define content_pointer 80 ; Memory pointer (to Cons or Array) %define content_function 96 ; Function pointer - +%define content_empty 112 + ;; Common combinations for MAL types %define maltype_integer (block_cons + container_value + content_int) %define maltype_string (block_array + container_value + content_char) %define maltype_symbol (block_array + container_symbol + content_char) %define maltype_nil (block_cons + container_value + content_nil) +%define maltype_empty_list (block_cons + container_list + content_empty) %include "reader.asm" %include "printer.asm" @@ -606,12 +610,25 @@ print_string: ;; Return string address in RAX itostring: ; Save registers to restore afterwards + push rbx push rcx push rdx push rsi push rdi mov rcx, 0 ; counter of how many bytes we need to print in the end + + mov rbx, rax ; Original input + + ; Check if the number is negative + cmp rax, 0 + jge .divideLoop + + ; a negative number. To get the '-' sign + ; at the front the test is done again at the end + ; using the value stored in rbx + + neg rax ; Make it positive .divideLoop: inc rcx ; count each byte to print - number of characters @@ -626,6 +643,16 @@ itostring: cmp rax, 0 ; can the integer be divided anymore? jnz .divideLoop ; jump if not zero to the label divideLoop + ; Check if the value was negative (in rbx) + cmp rbx, 0 + jge .create_string + + ; a negative number + dec rsp + mov BYTE [rsp], '-' + inc rcx + +.create_string: ; Get an Array object to put the string into call string_new ; Address in RAX @@ -650,6 +677,7 @@ itostring: pop rsi pop rdx pop rcx + pop rbx ret From f0662456bacf394258fbce1d0f451b80e6ee840d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 22 Oct 2017 00:24:53 +0100 Subject: [PATCH 0233/1998] Move types and system calls into separate files * Memory management, Cons, Arrays and String types in types.asm * Functions containing syscall in system.asm * Added more useful error message in reader, on unexpected end of input --- nasm/reader.asm | 10 + nasm/step1_read_print.asm | 749 +------------------------------------- nasm/system.asm | 93 +++++ nasm/types.asm | 629 ++++++++++++++++++++++++++++++++ 4 files changed, 739 insertions(+), 742 deletions(-) create mode 100644 nasm/system.asm create mode 100644 nasm/types.asm diff --git a/nasm/reader.asm b/nasm/reader.asm index 4048453427..f23bb5df8d 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -11,6 +11,9 @@ unquote_symbol_string: db "unquote" splice_unquote_symbol_string: db "splice-unquote" .len: equ $ - splice_unquote_symbol_string + +error_string_unexpected_end: db "Error: Unexpected end of input. Could be a missing )", 10 +.len: equ $ - error_string_unexpected_end section .text @@ -61,6 +64,13 @@ read_str: jne .got_token ; Unexpected end of tokens + push r14 + push r15 + mov rdx, error_string_unexpected_end.len + mov rsi, error_string_unexpected_end + call print_rawstring + pop r15 + pop r14 jmp .unwind .got_token: diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index a9ef12b1f2..a651e86b2d 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -5,131 +5,13 @@ ;; Address of return value is in RAX ;; -;; Data structures -;; =============== -;; -;; Memory management is done by having two fixed-size datatypes, -;; Cons and Array. -;; -;; Both Cons and Array have the following in common: -;; a type field at the start, a reference count, followed by data -;; [ type (8) | (8) | refs (16) | data ] -;; -;; -;; Type bit fields -;; --------------- -;; -;; The 8-bit type fields describe the Block, Container and Content type. -;; -;; The Block type is used for memory management, to determine the kind of memory block -;; The Container type indicates the data structure that the Cons or Array block is being used to represent -;; The Content type indicates the raw type of the data in the content -;; -;; Block type [1 bit]: -;; 0 0 - Cons memory block -;; 1 1 - Array memory block -;; -;; Container type [3 bits]: -;; 0 0 - Value (single boxed value for Cons blocks, vector for Array blocks). -;; 2 1 - List (value followed by pointer). Only for Cons blocks -;; 4 2 - Symbol (special char array). Only for Array blocks -;; 6 3 - Keyword -;; 8 4 - Map -;; 10 5 - Function -;; -;; Content type [4 bits]: -;; 0 0 - Nil -;; 16 1 - Bool -;; 32 2 - Char -;; 48 3 - Int -;; 64 4 - Float -;; 80 5 - Pointer (memory address) -;; 96 6 - Function (instruction address) -;; 112 7 - Empty (distinct from Nil) -;; -;; These represent MAL data types as follows: -;; -;; MAL type Block Container Content -;; --------- | -------- | ---------- | --------- -;; integer Cons Value Int -;; symbol Array Symbol Char -;; list Cons List Any -;; nil Cons Value Nil -;; true Cons Value Bool (1) -;; false Cons Value Bool (0) -;; string Array Value Char -;; keyword Array Keyword Char -;; vector Array Value Int/Float -;; hash-map Array Map Pointer (?TBD) -;; atom Cons Value Pointer -;; +global _start -;; Cons type. -;; Used to store either a single value with type information -;; or a pair of (value, Pointer or Nil) to represent a list -STRUC Cons -.typecar: RESB 1 ; Type information for car (8 bit) -.typecdr: RESB 1 ; Type information for cdr (8 bits) -.refcount: RESW 1 ; Number of references to this Cons (16 bit) -.car: RESQ 1 ; First value (64 bit) -.cdr: RESQ 1 ; Second value (64 bit) -.size: ; Total size of struc -ENDSTRUC - - -%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk - -STRUC Array -.type: RESB 1 ; Type information (8 bits) -.control: RESB 1 ; Control data (8 bits) -.refcount: RESW 1 ; Number of references to this Array (16 bit) -.length: RESD 1 ; Number of elements in this part of the array (32 bit) -.next RESQ 1 ; Pointer to the next chunk (64 bit) -.data: RESQ array_chunk_len ; Data storage -.size: ; Total size of struc -ENDSTRUC - -;; Type information - -%define block_mask 1 ; LSB for block type -%define container_mask 2 + 4 + 8 ; Next three bits for container type -%define content_mask 16 + 32 + 64 + 128 ; Four bits for content type - -;; Block types -%define block_cons 0 -%define block_array 1 - -;; Container types -%define container_value 0 -%define container_list 2 -%define container_symbol 4 -%define container_keyword 6 -%define container_map 8 -%define container_function 10 - -;; Content type -%define content_nil 0 -%define content_bool 16 -%define content_char 32 -%define content_int 48 -%define content_float 64 -%define content_pointer 80 ; Memory pointer (to Cons or Array) -%define content_function 96 ; Function pointer -%define content_empty 112 - -;; Common combinations for MAL types -%define maltype_integer (block_cons + container_value + content_int) -%define maltype_string (block_array + container_value + content_char) -%define maltype_symbol (block_array + container_symbol + content_char) -%define maltype_nil (block_cons + container_value + content_nil) -%define maltype_empty_list (block_cons + container_list + content_empty) +%include "types.asm" ; Data types, memory +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "printer.asm" ; Data structures -> String -%include "reader.asm" -%include "printer.asm" - - - global _start - section .data test_string1: db 10, "test1", 10 @@ -162,538 +44,8 @@ IEND prompt_string: db 10,"user> " ; The string to print at the prompt .len: equ $ - prompt_string - -error_msg_print_string: db "Error in print string",10 -.len: equ $ - error_msg_print_string - -error_array_memory_limit: db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 -.len: equ $ - error_array_memory_limit - -error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 -.len: equ $ - error_cons_memory_limit - -;; ------------------------------------------ -;; Memory management -;; -;; For each object (Cons or Array), there is a block of memory (in BSS). -;; When an object is requested it is first taken from the free list -;; If the free list is empty (address 0) then the next object in the block -;; is used, and the heap_x_number counter is incremented. When an object -;; is free'd it is pushed onto the heap_x_free list. - - -%define heap_cons_limit 10 ; Number of cons objects which can be created - -heap_cons_next: dd heap_cons_store ; Address of next cons in memory -heap_cons_free: dq 0 ; Address of start of free list - -%define heap_array_limit 10 ; Number of array objects which can be created - -heap_array_next: dd heap_array_store -heap_array_free: dq 0 - -section .bss - -;; Reserve space to store Cons and Array objects -heap_cons_store: resb heap_cons_limit * Cons.size -.end: ; Address of end of the store - -heap_array_store: resb heap_array_limit * Array.size -.end: - -section .text - -;; ------------------------------------------ -;; Array alloc_array() -;; -;; Returns the address of an Array object in RAX -;; -;; Working registers: rbx -alloc_array: - - ; Get the address of a free array - mov rax, [heap_array_free] ; Address of the array - - ; Check if it's null - cmp rax, 0 - je .create_array - - mov rbx, [rax + Array.next] ; Get the address of the next array in the linked list - mov [heap_array_free], rbx ; Put this address at the front of the list - jmp .initialise_array - -.create_array: - - ; Get the address of the next Array - mov rax, [heap_array_next] - ; Check if we've reached the end - cmp rax, heap_array_store.end - je .out_of_memory - - mov rbx, rax - add rbx, Array.size ; Address of the next array - mov [heap_array_next], rbx ; for next time - -.initialise_array: - ; Address of Array now in rax - mov BYTE [rax + Array.type], block_array - mov WORD [rax + Array.refcount], 1 ; Only one reference - mov DWORD [rax + Array.length], 0 - mov QWORD [rax + Array.next], 0 ; null next address - - ret - -.out_of_memory: - mov rsi, error_array_memory_limit - mov rdx, error_array_memory_limit.len - call print_rawstring - jmp quit_error - - -;; ------------------------------------------- -;; Decrements the reference count of the array in RSI -;; If the count reaches zero then push the array -;; onto the free list -release_array: - mov ax, WORD [rsi + Array.refcount] - - dec ax - mov WORD [rsi + Array.refcount], ax - jz .free ; If the count reaches zero then put on free list - ret - -.free: - ; Get the next field - mov rbx, [rsi + Array.next] - - mov rax, [heap_array_free] ; Get the current head - mov [rsi + Array.next], rax ; Put current head into the "next" field - mov [heap_array_free], rsi ; Push Array onto free list - - cmp rbx, 0 - jne .release_next ; If there is another array, then need to release it - - ret - -.release_next: - ; release the next array - mov rsi, rbx - call release_array - ret - -;; ------------------------------------------ -;; Cons alloc_cons() -;; -;; Returns the address of a Cons object in RAX -alloc_cons: - - ; Get the address of a free cons - mov rax, [heap_cons_free] ; Address of the cons - - ; Check if it's null - cmp rax, 0 - je .create_cons - - mov rbx, [rax + Cons.cdr] ; Get the address of the next cons in the linked list - mov [heap_cons_free], rbx ; Put this address at the front of the list - jmp .initialise_cons - -.create_cons: - - ; Get the address of the next Cons - mov rax, [heap_cons_next] - ; Check if we've reached the end - cmp rax, heap_cons_store.end - je .out_of_memory - - mov rbx, rax - add rbx, Cons.size ; Address of the next cons - mov [heap_cons_next], rbx ; for next time - -.initialise_cons: - ; Address of Cons now in rax - mov BYTE [rax + Cons.typecar], 0 - mov BYTE [rax + Cons.typecdr], 0 - mov WORD [rax + Cons.refcount], 1 ; Only one reference - mov QWORD [rax + Cons.car], 0 - mov QWORD [rax + Cons.cdr], 0 - ret - -.out_of_memory: - mov rsi, error_cons_memory_limit - mov rdx, error_cons_memory_limit.len - call print_rawstring - jmp quit_error - - -;; ------------------------------------------- -;; Decrements the reference count of the cons in RSI -;; If the count reaches zero then push the cons -;; onto the free list -release_cons: - mov ax, WORD [rsi + Cons.refcount] - dec ax - mov WORD [rsi + Cons.refcount], ax - jz .free ; If the count reaches zero then put on free list - ret - -.free: - ; Get and push cdr onto stack - mov rcx, [rsi + Cons.cdr] - push rcx ; Content of CDR - push rsi ; Original Cons object being released - - mov rax, [heap_cons_free] ; Get the current head - mov [rsi + Cons.cdr], rax ; Put current head into the "cdr" field - mov [heap_cons_free], rsi ; Push Cons onto free list - - ; Check if the CAR needs to be released - - mov al, BYTE [rsi+Cons.typecar] - and al, content_mask ; Test content type - cmp al, content_pointer - jne .free_cdr ; Jump if CAR not pointer - - ; CAR is a pointer to either a Cons or Array - ; Get the address stored in CAR - mov rsi, [rsi + Cons.car] - call release_object -.free_cdr: - pop rcx ; This was rsi, the original Cons - pop rsi ; This was rcx, the original Cons.cdr - - ; Get the type from the original Cons - mov al, BYTE [rcx+Cons.typecdr] - and al, content_mask ; Test content type - cmp al, content_pointer - jne .done - - call release_object -.done: - ret - - -;; Releases either a Cons or Array -;; Address of object in RSI -release_object: - mov al, BYTE [rsi] ; Get first byte - and al, block_mask ; Test block type - cmp al, block_array ; Test if it's an array - je .array - call release_cons - ret -.array: - call release_array - ret - -;; ------------------------------------------- -;; String type - -;; Create a new string, address in RAX -string_new: - call alloc_array - mov [rax], BYTE maltype_string - mov QWORD [rax + Array.next], 0 - ret - -;; Convert a raw string to a String type -;; -;; Input: Address of raw string in RSI, length in EDX -;; Output: Address of string in RAX -;; -;; Modifies registers: R8,R9,RCX -raw_to_string: - push rsi - push rdx - call string_new ; String now in RAX - pop rdx - pop rsi - mov [rax + Array.length], DWORD edx - mov r8, rax - add r8, Array.data ; Address of string data - mov r9, rsi ; Address of raw data - mov ecx, edx ; Count -.copy_loop: - - mov bl, BYTE [r9] - mov [r8], BYTE bl - inc r8 - inc r9 - dec ecx - jnz .copy_loop - ret - - - -;; Appends a character to a string -;; Input: Address of string in RSI, character in CL -string_append_char: - mov eax, DWORD [rsi + Array.length] - inc eax - mov DWORD [rsi + Array.length], eax - dec eax - add rax, rsi - add rax, Array.data ; End of data - mov [rax], BYTE cl - ret - -;; Appends a string to the end of a string -;; -;; Input: String to be modified in RSI -;; String to be copied in RDX -;; -;; Output: Modified string in RSI -;; -;; Working registers: -;; rax Array chunk for output (copied to) -;; rbx Array chunk for input (copied from) -;; cl Character being copied -;; r8 Address of destination -;; r9 Destination end address -;; r10 Address of source -;; r11 Source end address -string_append_string: - ; copy source Array address to rbx - mov rbx, rdx - - ; source data address in r10 - mov r10, rbx - add r10, Array.data ; Start of the data - - ; source data end address in r11 - mov r11, r10 - mov r8d, DWORD [rbx + Array.length] - add r11, r8 - - ; Find the end of the string in RSI - ; and put the address of the Array object into rax - mov rax, rsi -.find_string_end: - mov r8, QWORD [rax + Array.next] - cmp r8, 0 ; Next chunk is null - je .got_dest_end ; so reached end - - mov rax, r8 ; Go to next chunk - jmp .find_string_end -.got_dest_end: - - ; destination data address into r8 - mov r8, rax - add r8, Array.data - add r8d, DWORD [rax + Array.length] - - ; destination data end into r9 - mov r9, rax - add r9, Array.size - -.copy_loop: - ; Copy one byte from source to destination - mov cl, BYTE [r10] - mov BYTE [r8], cl - - ; move source to next byte - inc r10 - ; Check if we've reached the end of this Array - cmp r10, r11 - jne .source_ok - - ; have reached the end of the source Array - mov rbx, QWORD [rbx + Array.next] ; Get the next Array address - cmp rbx, 0 ; Test if it's null - je .finished ; No more, so we're done - ; Move on to next Array object - - ; Get source address into r10 - mov r10, rbx - add r10, Array.data ; Start of the data - - ; Source end address - mov r11, rbx - add r11, Array.size - -.source_ok: - - ; Move destination to next byte - inc r8 - ; Check if we've reached end of the Array - cmp r8, r9 - jne .copy_loop ; Next byte - - ; Reached the end of the destination - ; Need to allocate another Array - push rax - push rbx - call alloc_array ; New Array in rax - mov r8, rax ; copy to r8 - pop rbx - pop rax - - ; Previous Array in rax. - ; Add a reference to the new array and set length - mov QWORD [rax + Array.next], r8 - mov DWORD [rax + Array.length], (Array.size - Array.data) - mov rax, r8 ; new array - add r8, Array.data ; Start of data - - mov r9, rax - add r9, Array.size - -.finished: - ; Compare r8 (destination) with data start - ; to get length of string - sub r8, rax - sub r8, Array.data - inc r8 - ; r8 now contains length - mov DWORD [rax + Array.length], r8d - - ret - -;; ------------------------------------------- -;; Prints a raw string to stdout -;; String address in rsi, string length in rdx -print_rawstring: - push rax - push rdi - - ; write(1, string, length) - mov rax, 1 ; system call 1 is write - mov rdi, 1 ; file handle 1 is stdout - syscall - - pop rdi - pop rax - - ret - -;; ------------------------------------------ -;; void print_string(char array) -;; Address of the char Array should be in RSI -print_string: - ; Push registers we're going to use - push rax - push rdi - push rdx - push rsi - - ; Check that we have a char array - mov al, [rsi] - cmp al, maltype_string - jne .error - - ; write(1, string, length) - mov edx, [rsi + Array.length] ; number of bytes - add rsi, Array.data ; address of raw string to output - call print_rawstring - - ; Restore registers - pop rsi - pop rdx - pop rdi - pop rax - - ret -.error: - ; An error occurred - mov rdx, error_msg_print_string.len ; number of bytes - mov rsi, error_msg_print_string ; address of raw string to output - call print_rawstring - ; exit - jmp quit_error - -;; ------------------------------------------ -;; String itostring(Integer number) -;; -;; Converts an integer to a string (array of chars) -;; -;; Input in RAX -;; Return string address in RAX -itostring: - ; Save registers to restore afterwards - push rbx - push rcx - push rdx - push rsi - push rdi - - mov rcx, 0 ; counter of how many bytes we need to print in the end - - mov rbx, rax ; Original input - - ; Check if the number is negative - cmp rax, 0 - jge .divideLoop - - ; a negative number. To get the '-' sign - ; at the front the test is done again at the end - ; using the value stored in rbx - - neg rax ; Make it positive - -.divideLoop: - inc rcx ; count each byte to print - number of characters - xor rdx, rdx - mov rsi, 10 - idiv rsi ; divide rax by rsi - add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction - ; Character is now in DL - dec rsp - mov BYTE [rsp], dl ; Put onto stack - - cmp rax, 0 ; can the integer be divided anymore? - jnz .divideLoop ; jump if not zero to the label divideLoop - - ; Check if the value was negative (in rbx) - cmp rbx, 0 - jge .create_string - - ; a negative number - dec rsp - mov BYTE [rsp], '-' - inc rcx - -.create_string: - ; Get an Array object to put the string into - call string_new ; Address in RAX - - ; put length into string - mov [rax + Array.length], ecx - - ; copy data from stack into string - ; Note: Currently this does not handle long strings - mov rdi, rax - add rdi, Array.data ; Address where raw string will go -.copyLoop: - mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient - mov [rdi], BYTE dl - inc rsp - inc rdi - dec rcx - cmp rcx, 0 - jnz .copyLoop - - ; Restore registers - pop rdi - pop rsi - pop rdx - pop rcx - pop rbx - - ret - -;------------------------------------------ -; void exit() -; Exit program and restore resources -quit: - mov eax, 60 ; system call 60 is exit - xor rdi, rdi ; exit code 0 - syscall ; invoke operating system to exit - -quit_error: - mov eax, 60 ; system call 60 is exit - mov rdi, 1 ; exit code 1 - syscall - + +section .text ;; Evaluates a form eval: @@ -715,85 +67,8 @@ rep_seq: mov rsi, rax ; Return value ret -;; Read a line from stdin -;; Gets a new string array, fills it until a newline or EOF is reached -;; Returns pointer to string in RAX -read_line: - ; Get an array to put the string into - ; Address in rax - call alloc_array - ; Mark it as a character array (string) - mov BYTE [rax + Array.type], maltype_string - - push rax ; Save pointer to string - - ; Read character by character until either newline or end of input - mov ebx, 0 ; Count how many characters read - mov rsi, rax - add rsi, Array.data ; Point to the data -.readLoop: - mov rax, 0 ; sys_read - mov rdi, 0 ; stdin - mov rdx, 1 ; count - syscall - - ; Characters read in RAX - cmp rax, 0 ; end loop if read <= 0 - jle .readLoopEnd - - mov cl, BYTE [rsi] - - cmp cl, 10 ; End if we read a newline - je .readLoopEnd - - cmp cl, 8 ; Backspace? - je .handleBackspace - - cmp cl, 31 ; Below space - jle .readLoop ; Ignore, keep going - cmp cl, 127 ; DEL or above - jge .readLoop ; Ignore, keep going - - inc ebx - inc rsi ; Move to next point in the array - jmp .readLoop ; Get another character - -.handleBackspace: - ; Check if we've read any characters - cmp ebx, 0 - je .readLoop ; If not, carry on the loop - ; Characters have been read. Remove one - dec ebx - dec rsi - jmp .readLoop -.readLoopEnd: - pop rax ; Restore pointer to string - mov DWORD [rax + Array.length], ebx ; Set string length - ret - - - _start: - - ; mov rsi, test_string1 - ; mov edx, test_string1.len - ; call raw_to_string ; address in rax - ; push rax - ; mov rsi, test_string2 - ; mov edx, test_string2.len - ; call raw_to_string - ; pop rsi - ; mov rdx, rax - ; call string_append_string - ; call print_string - - - ; Test printing short list of integers - ; mov rsi, test_cons2 - ; call pr_str - ; mov rsi, rax - ; call print_string ; ----------------------------- ; Main loop @@ -840,15 +115,5 @@ _start: jmp .mainLoop .mainLoopEnd: - ;mov rdx, 1 - ;mov rsi, - ;call print_rawstring - ;inc rsp - - ;mov rax, 1223 - ;call itostring - ;mov rsi, rax - ;call print_string - jmp quit diff --git a/nasm/system.asm b/nasm/system.asm new file mode 100644 index 0000000000..6389b2a64f --- /dev/null +++ b/nasm/system.asm @@ -0,0 +1,93 @@ +;;; System call functions +;;; +;;; This file contains system-specific functions, +;;; which use calls to the operating system (Linux) + + +;; ------------------------------------------- +;; Prints a raw string to stdout +;; String address in rsi, string length in rdx +print_rawstring: + push rax + push rdi + + ; write(1, string, length) + mov rax, 1 ; system call 1 is write + mov rdi, 1 ; file handle 1 is stdout + syscall + + pop rdi + pop rax + + ret + +;------------------------------------------ +; void exit() +; Exit program and restore resources +quit: + mov eax, 60 ; system call 60 is exit + xor rdi, rdi ; exit code 0 + syscall ; invoke operating system to exit + +quit_error: + mov eax, 60 ; system call 60 is exit + mov rdi, 1 ; exit code 1 + syscall + + +;; Read a line from stdin +;; Gets a new string array, fills it until a newline or EOF is reached +;; Returns pointer to string in RAX +read_line: + ; Get an array to put the string into + ; Address in rax + call alloc_array + ; Mark it as a character array (string) + mov BYTE [rax + Array.type], maltype_string + + push rax ; Save pointer to string + + ; Read character by character until either newline or end of input + mov ebx, 0 ; Count how many characters read + mov rsi, rax + add rsi, Array.data ; Point to the data +.readLoop: + mov rax, 0 ; sys_read + mov rdi, 0 ; stdin + mov rdx, 1 ; count + syscall + + ; Characters read in RAX + cmp rax, 0 ; end loop if read <= 0 + jle .readLoopEnd + + mov cl, BYTE [rsi] + + cmp cl, 10 ; End if we read a newline + je .readLoopEnd + + cmp cl, 8 ; Backspace? + je .handleBackspace + + cmp cl, 31 ; Below space + jle .readLoop ; Ignore, keep going + + cmp cl, 127 ; DEL or above + jge .readLoop ; Ignore, keep going + + inc ebx + inc rsi ; Move to next point in the array + jmp .readLoop ; Get another character + +.handleBackspace: + ; Check if we've read any characters + cmp ebx, 0 + je .readLoop ; If not, carry on the loop + ; Characters have been read. Remove one + dec ebx + dec rsi + jmp .readLoop +.readLoopEnd: + pop rax ; Restore pointer to string + mov DWORD [rax + Array.length], ebx ; Set string length + ret diff --git a/nasm/types.asm b/nasm/types.asm new file mode 100644 index 0000000000..55bd3b0bb6 --- /dev/null +++ b/nasm/types.asm @@ -0,0 +1,629 @@ +;; Data structures +;; =============== +;; +;; Memory management is done by having two fixed-size datatypes, +;; Cons and Array. +;; +;; Both Cons and Array have the following in common: +;; a type field at the start, a reference count, followed by data +;; [ type (8) | (8) | refs (16) | data ] +;; +;; +;; Type bit fields +;; --------------- +;; +;; The 8-bit type fields describe the Block, Container and Content type. +;; +;; The Block type is used for memory management, to determine the kind of memory block +;; The Container type indicates the data structure that the Cons or Array block is being used to represent +;; The Content type indicates the raw type of the data in the content +;; +;; Block type [1 bit]: +;; 0 0 - Cons memory block +;; 1 1 - Array memory block +;; +;; Container type [3 bits]: +;; 0 0 - Value (single boxed value for Cons blocks, vector for Array blocks). +;; 2 1 - List (value followed by pointer). Only for Cons blocks +;; 4 2 - Symbol (special char array). Only for Array blocks +;; 6 3 - Keyword +;; 8 4 - Map +;; 10 5 - Function +;; +;; Content type [4 bits]: +;; 0 0 - Nil +;; 16 1 - Bool +;; 32 2 - Char +;; 48 3 - Int +;; 64 4 - Float +;; 80 5 - Pointer (memory address) +;; 96 6 - Function (instruction address) +;; 112 7 - Empty (distinct from Nil) +;; +;; These represent MAL data types as follows: +;; +;; MAL type Block Container Content +;; --------- | -------- | ---------- | --------- +;; integer Cons Value Int +;; symbol Array Symbol Char +;; list Cons List Any +;; nil Cons Value Nil +;; true Cons Value Bool (1) +;; false Cons Value Bool (0) +;; string Array Value Char +;; keyword Array Keyword Char +;; vector Array Value Int/Float +;; hash-map Array Map Pointer (?TBD) +;; atom Cons Value Pointer +;; + +;; Cons type. +;; Used to store either a single value with type information +;; or a pair of (value, Pointer or Nil) to represent a list +STRUC Cons +.typecar: RESB 1 ; Type information for car (8 bit) +.typecdr: RESB 1 ; Type information for cdr (8 bits) +.refcount: RESW 1 ; Number of references to this Cons (16 bit) +.car: RESQ 1 ; First value (64 bit) +.cdr: RESQ 1 ; Second value (64 bit) +.size: ; Total size of struc +ENDSTRUC + + +%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk + +STRUC Array +.type: RESB 1 ; Type information (8 bits) +.control: RESB 1 ; Control data (8 bits) +.refcount: RESW 1 ; Number of references to this Array (16 bit) +.length: RESD 1 ; Number of elements in this part of the array (32 bit) +.next RESQ 1 ; Pointer to the next chunk (64 bit) +.data: RESQ array_chunk_len ; Data storage +.size: ; Total size of struc +ENDSTRUC + +;; Type information + +%define block_mask 1 ; LSB for block type +%define container_mask 2 + 4 + 8 ; Next three bits for container type +%define content_mask 16 + 32 + 64 + 128 ; Four bits for content type + +;; Block types +%define block_cons 0 +%define block_array 1 + +;; Container types +%define container_value 0 +%define container_list 2 +%define container_symbol 4 +%define container_keyword 6 +%define container_map 8 +%define container_function 10 + +;; Content type +%define content_nil 0 +%define content_bool 16 +%define content_char 32 +%define content_int 48 +%define content_float 64 +%define content_pointer 80 ; Memory pointer (to Cons or Array) +%define content_function 96 ; Function pointer +%define content_empty 112 + +;; Common combinations for MAL types +%define maltype_integer (block_cons + container_value + content_int) +%define maltype_string (block_array + container_value + content_char) +%define maltype_symbol (block_array + container_symbol + content_char) +%define maltype_nil (block_cons + container_value + content_nil) +%define maltype_empty_list (block_cons + container_list + content_empty) + + +;; ------------------------------------------ + +section .data + +;; Fixed strings for printing + + +error_msg_print_string: db "Error in print string",10 +.len: equ $ - error_msg_print_string + +error_array_memory_limit: db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 +.len: equ $ - error_array_memory_limit + +error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 +.len: equ $ - error_cons_memory_limit + +;; ------------------------------------------ +;; Memory management +;; +;; For each object (Cons or Array), there is a block of memory (in BSS). +;; When an object is requested it is first taken from the free list +;; If the free list is empty (address 0) then the next object in the block +;; is used, and the heap_x_number counter is incremented. When an object +;; is free'd it is pushed onto the heap_x_free list. + + +%define heap_cons_limit 10 ; Number of cons objects which can be created + +heap_cons_next: dd heap_cons_store ; Address of next cons in memory +heap_cons_free: dq 0 ; Address of start of free list + +%define heap_array_limit 10 ; Number of array objects which can be created + +heap_array_next: dd heap_array_store +heap_array_free: dq 0 + +section .bss + +;; Reserve space to store Cons and Array objects +heap_cons_store: resb heap_cons_limit * Cons.size +.end: ; Address of end of the store + +heap_array_store: resb heap_array_limit * Array.size +.end: + +section .text + +;; ------------------------------------------ +;; Array alloc_array() +;; +;; Returns the address of an Array object in RAX +;; +;; Working registers: rbx +alloc_array: + + ; Get the address of a free array + mov rax, [heap_array_free] ; Address of the array + + ; Check if it's null + cmp rax, 0 + je .create_array + + mov rbx, [rax + Array.next] ; Get the address of the next array in the linked list + mov [heap_array_free], rbx ; Put this address at the front of the list + jmp .initialise_array + +.create_array: + + ; Get the address of the next Array + mov rax, [heap_array_next] + ; Check if we've reached the end + cmp rax, heap_array_store.end + je .out_of_memory + + mov rbx, rax + add rbx, Array.size ; Address of the next array + mov [heap_array_next], rbx ; for next time + +.initialise_array: + ; Address of Array now in rax + mov BYTE [rax + Array.type], block_array + mov WORD [rax + Array.refcount], 1 ; Only one reference + mov DWORD [rax + Array.length], 0 + mov QWORD [rax + Array.next], 0 ; null next address + + ret + +.out_of_memory: + mov rsi, error_array_memory_limit + mov rdx, error_array_memory_limit.len + call print_rawstring + jmp quit_error + + +;; ------------------------------------------- +;; Decrements the reference count of the array in RSI +;; If the count reaches zero then push the array +;; onto the free list +release_array: + mov ax, WORD [rsi + Array.refcount] + + dec ax + mov WORD [rsi + Array.refcount], ax + jz .free ; If the count reaches zero then put on free list + ret + +.free: + ; Get the next field + mov rbx, [rsi + Array.next] + + mov rax, [heap_array_free] ; Get the current head + mov [rsi + Array.next], rax ; Put current head into the "next" field + mov [heap_array_free], rsi ; Push Array onto free list + + cmp rbx, 0 + jne .release_next ; If there is another array, then need to release it + + ret + +.release_next: + ; release the next array + mov rsi, rbx + call release_array + ret + +;; ------------------------------------------ +;; Cons alloc_cons() +;; +;; Returns the address of a Cons object in RAX +alloc_cons: + + ; Get the address of a free cons + mov rax, [heap_cons_free] ; Address of the cons + + ; Check if it's null + cmp rax, 0 + je .create_cons + + mov rbx, [rax + Cons.cdr] ; Get the address of the next cons in the linked list + mov [heap_cons_free], rbx ; Put this address at the front of the list + jmp .initialise_cons + +.create_cons: + + ; Get the address of the next Cons + mov rax, [heap_cons_next] + ; Check if we've reached the end + cmp rax, heap_cons_store.end + je .out_of_memory + + mov rbx, rax + add rbx, Cons.size ; Address of the next cons + mov [heap_cons_next], rbx ; for next time + +.initialise_cons: + ; Address of Cons now in rax + mov BYTE [rax + Cons.typecar], 0 + mov BYTE [rax + Cons.typecdr], 0 + mov WORD [rax + Cons.refcount], 1 ; Only one reference + mov QWORD [rax + Cons.car], 0 + mov QWORD [rax + Cons.cdr], 0 + ret + +.out_of_memory: + mov rsi, error_cons_memory_limit + mov rdx, error_cons_memory_limit.len + call print_rawstring + jmp quit_error + + +;; ------------------------------------------- +;; Decrements the reference count of the cons in RSI +;; If the count reaches zero then push the cons +;; onto the free list +release_cons: + mov ax, WORD [rsi + Cons.refcount] + dec ax + mov WORD [rsi + Cons.refcount], ax + jz .free ; If the count reaches zero then put on free list + ret + +.free: + ; Get and push cdr onto stack + mov rcx, [rsi + Cons.cdr] + push rcx ; Content of CDR + push rsi ; Original Cons object being released + + mov rax, [heap_cons_free] ; Get the current head + mov [rsi + Cons.cdr], rax ; Put current head into the "cdr" field + mov [heap_cons_free], rsi ; Push Cons onto free list + + ; Check if the CAR needs to be released + + mov al, BYTE [rsi+Cons.typecar] + and al, content_mask ; Test content type + cmp al, content_pointer + jne .free_cdr ; Jump if CAR not pointer + + ; CAR is a pointer to either a Cons or Array + ; Get the address stored in CAR + mov rsi, [rsi + Cons.car] + call release_object +.free_cdr: + pop rcx ; This was rsi, the original Cons + pop rsi ; This was rcx, the original Cons.cdr + + ; Get the type from the original Cons + mov al, BYTE [rcx+Cons.typecdr] + and al, content_mask ; Test content type + cmp al, content_pointer + jne .done + + call release_object +.done: + ret + + +;; Releases either a Cons or Array +;; Address of object in RSI +release_object: + mov al, BYTE [rsi] ; Get first byte + and al, block_mask ; Test block type + cmp al, block_array ; Test if it's an array + je .array + call release_cons + ret +.array: + call release_array + ret + +;; ------------------------------------------- +;; String type + +;; Create a new string, address in RAX +string_new: + call alloc_array + mov [rax], BYTE maltype_string + mov QWORD [rax + Array.next], 0 + ret + +;; Convert a raw string to a String type +;; +;; Input: Address of raw string in RSI, length in EDX +;; Output: Address of string in RAX +;; +;; Modifies registers: R8,R9,RCX +raw_to_string: + push rsi + push rdx + call string_new ; String now in RAX + pop rdx + pop rsi + mov [rax + Array.length], DWORD edx + mov r8, rax + add r8, Array.data ; Address of string data + mov r9, rsi ; Address of raw data + mov ecx, edx ; Count +.copy_loop: + + mov bl, BYTE [r9] + mov [r8], BYTE bl + inc r8 + inc r9 + dec ecx + jnz .copy_loop + ret + + + +;; Appends a character to a string +;; Input: Address of string in RSI, character in CL +string_append_char: + mov eax, DWORD [rsi + Array.length] + inc eax + mov DWORD [rsi + Array.length], eax + dec eax + add rax, rsi + add rax, Array.data ; End of data + mov [rax], BYTE cl + ret + +;; Appends a string to the end of a string +;; +;; Input: String to be modified in RSI +;; String to be copied in RDX +;; +;; Output: Modified string in RSI +;; +;; Working registers: +;; rax Array chunk for output (copied to) +;; rbx Array chunk for input (copied from) +;; cl Character being copied +;; r8 Address of destination +;; r9 Destination end address +;; r10 Address of source +;; r11 Source end address +string_append_string: + ; copy source Array address to rbx + mov rbx, rdx + + ; source data address in r10 + mov r10, rbx + add r10, Array.data ; Start of the data + + ; source data end address in r11 + mov r11, r10 + mov r8d, DWORD [rbx + Array.length] + add r11, r8 + + ; Find the end of the string in RSI + ; and put the address of the Array object into rax + mov rax, rsi +.find_string_end: + mov r8, QWORD [rax + Array.next] + cmp r8, 0 ; Next chunk is null + je .got_dest_end ; so reached end + + mov rax, r8 ; Go to next chunk + jmp .find_string_end +.got_dest_end: + + ; destination data address into r8 + mov r8, rax + add r8, Array.data + add r8d, DWORD [rax + Array.length] + + ; destination data end into r9 + mov r9, rax + add r9, Array.size + +.copy_loop: + ; Copy one byte from source to destination + mov cl, BYTE [r10] + mov BYTE [r8], cl + + ; move source to next byte + inc r10 + ; Check if we've reached the end of this Array + cmp r10, r11 + jne .source_ok + + ; have reached the end of the source Array + mov rbx, QWORD [rbx + Array.next] ; Get the next Array address + cmp rbx, 0 ; Test if it's null + je .finished ; No more, so we're done + ; Move on to next Array object + + ; Get source address into r10 + mov r10, rbx + add r10, Array.data ; Start of the data + + ; Source end address + mov r11, rbx + add r11, Array.size + +.source_ok: + + ; Move destination to next byte + inc r8 + ; Check if we've reached end of the Array + cmp r8, r9 + jne .copy_loop ; Next byte + + ; Reached the end of the destination + ; Need to allocate another Array + push rax + push rbx + call alloc_array ; New Array in rax + mov r8, rax ; copy to r8 + pop rbx + pop rax + + ; Previous Array in rax. + ; Add a reference to the new array and set length + mov QWORD [rax + Array.next], r8 + mov DWORD [rax + Array.length], (Array.size - Array.data) + mov rax, r8 ; new array + add r8, Array.data ; Start of data + + mov r9, rax + add r9, Array.size + +.finished: + ; Compare r8 (destination) with data start + ; to get length of string + sub r8, rax + sub r8, Array.data + inc r8 + ; r8 now contains length + mov DWORD [rax + Array.length], r8d + + ret + +;; ------------------------------------------ +;; void print_string(char array) +;; Address of the char Array should be in RSI +print_string: + ; Push registers we're going to use + push rax + push rdi + push rdx + push rsi + + ; Check that we have a char array + mov al, [rsi] + cmp al, maltype_string + jne .error + + ; write(1, string, length) + mov edx, [rsi + Array.length] ; number of bytes + add rsi, Array.data ; address of raw string to output + call print_rawstring + + ; Restore registers + pop rsi + pop rdx + pop rdi + pop rax + + ret +.error: + ; An error occurred + mov rdx, error_msg_print_string.len ; number of bytes + mov rsi, error_msg_print_string ; address of raw string to output + call print_rawstring + ; exit + jmp quit_error + +;; ------------------------------------------ +;; String itostring(Integer number) +;; +;; Converts an integer to a string (array of chars) +;; +;; Input in RAX +;; Return string address in RAX +itostring: + ; Save registers to restore afterwards + push rbx + push rcx + push rdx + push rsi + push rdi + + mov rcx, 0 ; counter of how many bytes we need to print in the end + + mov rbx, rax ; Original input + + ; Check if the number is negative + cmp rax, 0 + jge .divideLoop + + ; a negative number. To get the '-' sign + ; at the front the test is done again at the end + ; using the value stored in rbx + + neg rax ; Make it positive + +.divideLoop: + inc rcx ; count each byte to print - number of characters + xor rdx, rdx + mov rsi, 10 + idiv rsi ; divide rax by rsi + add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction + ; Character is now in DL + dec rsp + mov BYTE [rsp], dl ; Put onto stack + + cmp rax, 0 ; can the integer be divided anymore? + jnz .divideLoop ; jump if not zero to the label divideLoop + + ; Check if the value was negative (in rbx) + cmp rbx, 0 + jge .create_string + + ; a negative number + dec rsp + mov BYTE [rsp], '-' + inc rcx + +.create_string: + ; Get an Array object to put the string into + call string_new ; Address in RAX + + ; put length into string + mov [rax + Array.length], ecx + + ; copy data from stack into string + ; Note: Currently this does not handle long strings + mov rdi, rax + add rdi, Array.data ; Address where raw string will go +.copyLoop: + mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient + mov [rdi], BYTE dl + inc rsp + inc rdi + dec rcx + cmp rcx, 0 + jnz .copyLoop + + ; Restore registers + pop rdi + pop rsi + pop rdx + pop rcx + pop rbx + + ret + + From c1cd93d09795331b64c1ef8081e6deb177af0163 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 22 Oct 2017 15:09:13 +0100 Subject: [PATCH 0234/1998] Added arithmetic functions to core.asm Starting step 2. * core_add, core_sub, core_mul and core_div are defined in core.asm. These take a list of integers and return an integer. Currently step2_eval.asm is hard-wired to call core_add, so (1 2 3) -> 6 --- nasm/Makefile | 8 ++- nasm/core.asm | 86 ++++++++++++++++++++++++++++++ nasm/step2_eval.asm | 124 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 217 insertions(+), 1 deletion(-) create mode 100644 nasm/core.asm create mode 100644 nasm/step2_eval.asm diff --git a/nasm/Makefile b/nasm/Makefile index 1e7ea2fc65..9dfc396bac 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -2,6 +2,12 @@ step0_repl: step0_repl.asm nasm -felf64 step0_repl.asm ld -o $@ step0_repl.o -step1_read_print: step1_read_print.asm +COMPONENTS=core.asm reader.asm printer.asm types.asm system.asm + +step1_read_print: step1_read_print.asm $(COMPONENTS) nasm -felf64 step1_read_print.asm ld -o $@ step1_read_print.o + +step2_eval: step2_eval.asm $(COMPONENTS) + nasm -felf64 step2_eval.asm + ld -o $@ step2_eval.o diff --git a/nasm/core.asm b/nasm/core.asm new file mode 100644 index 0000000000..79d88cda7d --- /dev/null +++ b/nasm/core.asm @@ -0,0 +1,86 @@ +;; Core functions +;; +;; + +section .text + +;; Adds a list of numbers, address in RSI +;; Returns the sum as a number object with address in RAX +;; Since most of the code is common to all operators, +;; RBX is used to jump to the required instruction +core_add: + mov rbx, core_arithmetic.do_addition + jmp core_arithmetic +core_sub: + mov rbx, core_arithmetic.do_subtraction + jmp core_arithmetic +core_mul: + mov rbx, core_arithmetic.do_multiply + jmp core_arithmetic +core_div: + mov rbx, core_arithmetic.do_division + ; Fall through to core_arithmetic +core_arithmetic: + ; Check that the first object is a number + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + cmp ch, block_cons + jne .error + mov ch, cl + and ch, content_mask + cmp ch, content_int + jne .error + + ; Put the starting value in rax + mov rax, [rsi + Cons.car] + +.add_loop: + ; Fetch the next value + mov cl, [rsi + Cons.typecdr] + cmp cl, content_nil + je .finished ; Nothing let + cmp cl, content_pointer + jne .error + + mov rsi, [rsi + Cons.cdr] ; Get next cons + + ; Check that it is an integer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_int + jne .error + + ; Jump to the required operation, address in RBX + jmp rbx + +.do_addition: + add rax, [rsi + Cons.car] + jmp .add_loop +.do_subtraction: + sub rax, [rsi + Cons.car] + jmp .add_loop +.do_multiply: + imul rax, [rsi + Cons.car] + jmp .add_loop +.do_division: + xor rdx, rdx ; Zero high bits + mov rcx, [rsi + Cons.car] + idiv rcx + jmp .add_loop + +.finished: + ; Value in rbx + push rax + ; Get a Cons object to put the result into + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret +.error: + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm new file mode 100644 index 0000000000..eed5fe19b8 --- /dev/null +++ b/nasm/step2_eval.asm @@ -0,0 +1,124 @@ +;; +;; nasm -felf64 step1_read_print.asm && ld step1_read_print.o && ./a.out + +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .data + +test_string1: db 10, "test1", 10 +.len: equ $ - test_string1 + +test_string2: db 10, "test2", 10 +.len: equ $ - test_string2 + +;str: ISTRUC Array +;AT Array.type, db maltype_string +;AT Array.length, dd 6 +;AT Array.data, db 'hello',10 +;IEND + +test_cons: ISTRUC Cons +AT Cons.typecar, db ( maltype_integer + 2 ) +AT Cons.typecdr, db 0 +AT Cons.car, dq 123 +IEND + +test_cons2: ISTRUC Cons +AT Cons.typecar, db ( maltype_integer + 2 ) +AT Cons.typecdr, db content_pointer +AT Cons.car, dq 456 +AT Cons.cdr, dq test_cons +IEND + +;; ------------------------------------------ +;; Fixed strings for printing + +prompt_string: db 10,"user> " ; The string to print at the prompt +.len: equ $ - prompt_string + +section .text + +;; Evaluates a form +eval: + mov rax, rsi ; Return the input + ret + +;; Prints the result +print: + mov rax, rsi ; Return the input + ret + +;; Read-Eval-Print in sequence +rep_seq: + call read_str + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call print + mov rsi, rax ; Return value + ret + + +_start: + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + mov rdx, prompt_string.len ; number of bytes + mov rsi, prompt_string ; address of raw string to output + call print_rawstring + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + ; Put into read_str + mov rsi, rax + call read_str + push rax + + ; Add together + mov rsi, rax + call core_add + + ; Put into pr_str + mov rsi, rax + call pr_str + push rax + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array + + ; Release the string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + From 5c2377fd079a0c73b3d01f88418d06b5de4556dc Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 22 Oct 2017 23:47:18 +0100 Subject: [PATCH 0235/1998] Started adding Map type An associative type, for now being implemented as a list with an even number of elements: key,value,key,value,... Later may replace with something more efficient. Needed for environment, to allow lookup of functions from symbols. --- nasm/types.asm | 134 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 133 insertions(+), 1 deletion(-) diff --git a/nasm/types.asm b/nasm/types.asm index 55bd3b0bb6..0bb89556a9 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -53,7 +53,7 @@ ;; string Array Value Char ;; keyword Array Keyword Char ;; vector Array Value Int/Float -;; hash-map Array Map Pointer (?TBD) +;; hash-map Cons Map Alternate key, values ;; atom Cons Value Pointer ;; @@ -247,6 +247,9 @@ release_array: ;; Cons alloc_cons() ;; ;; Returns the address of a Cons object in RAX +;; +;; Modifies: +;; RBX alloc_cons: ; Get the address of a free cons @@ -348,6 +351,21 @@ release_object: call release_array ret +;; Increment reference count of Cons or Array +;; Address of object in RSI +;; +;; This code makes use of the fact that the reference +;; count is in the same place in Cons and Array types +;; +;; Modifies +;; RAX +incref_object: + mov ax, WORD [rsi + Cons.refcount] ; Same for Array + inc ax + ; Check for overflow? + mov [rsi + Cons.refcount], WORD ax + ret + ;; ------------------------------------------- ;; String type @@ -626,4 +644,118 @@ itostring: ret +;; ------------------------------------------------------------ +;; Map type + +map_new: + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_empty) + mov [rax + Cons.typecdr], BYTE content_nil + ret + + +;; Add to map. Input is a list with an even number of values +;; as (key, value, key, value, ...) +;; +;; Inputs: +;; RSI - Map to append to. This is not modified +;; RDI - List to add to the map +;; Outputs: +;; RAX - New map +;; +;; Modifies: +;; RCX +map_add: + ; Check type of input + mov cl, BYTE [rsi] + mov cl, ch + and ch, block_mask + container_mask + cmp ch, block_cons + container_map + jne .error + + mov cl, BYTE [rdi] + and cl, block_mask + container_mask + cmp cl, block_cons + container_list + jne .error + + xor r8, r8 ; Zero r8 + +.copy_input: + ; Copy input list, changing container type + call alloc_cons + + mov cl, BYTE [rdi] + and cl, content_mask ; Keep the content + add cl, block_cons + container_map + mov [rax], BYTE cl ; Set type + mov rcx, [rdi+Cons.car] ; Copy data + mov [rax+Cons.car], rcx + + cmp cl, (block_cons + container_map + content_pointer) + jne .copy_not_pointer + + ; Copying a pointer to data + ; so need to increase the reference count + mov bx, WORD [rcx + Cons.refcount] ; Same offset for Array + inc bx + mov [rcx + Cons.refcount], WORD bx + +.copy_not_pointer: + + ; Check if this is the first object + cmp r8, 0 + jnz .copy_not_first + mov r8, rax ; Save start of map to R8 + mov r9, rax ; Last cons in R9 + jmp .copy_next +.copy_not_first: + ; Append to R9 + mov [r9+Cons.cdr], rax + mov [r9+Cons.typecdr], BYTE content_pointer + + ; Put new Cons in R9 as the latest in the list + mov r9, rax + +.copy_next: + ; Check if we've reached the end + mov cl, BYTE [rdi + Cons.typecdr] + cmp cl, content_nil + je .copy_finished + + ; Not yet. Get next Cons and keep going + mov rdi, [rdi + Cons.cdr] + jmp .copy_input + +.copy_finished: + ; Start of map in r8, end in r9 + + ; Check if the original map is empty + mov cl, [rsi] + and cl, content_mask + cmp cl, content_empty + je .return + + ; Put old map on the end of the new map + ; For now this avoids the need to overwrite + ; values in the map, since a search will find + ; the new values first. + + mov [r9 + Cons.cdr], rsi + mov [r9 + Cons.typecdr], BYTE content_pointer + + ; Increment reference count + mov bx, WORD [rsi + Cons.refcount] + inc bx + mov [rsi + Cons.refcount], WORD bx + +.return: + mov rax, r8 + ret + +.error: + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret From a58f416a0d3875e971291ada75333d468aed013b Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 23 Oct 2017 09:06:26 +0200 Subject: [PATCH 0236/1998] hy, php, powershell, scala: Add number?, fn?, macro? --- hy/core.hy | 4 ++++ php/core.php | 3 +++ php/types.php | 2 ++ powershell/core.psm1 | 4 ++++ powershell/types.psm1 | 4 ++++ scala/core.scala | 22 ++++++++++++++++++++++ 6 files changed, 39 insertions(+) diff --git a/hy/core.hy b/hy/core.hy index d4984a7e3d..37ce46659c 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -27,11 +27,15 @@ "nil?" none? "true?" (fn [a] (and (instance? bool a) (= a True))) "false?" (fn [a] (and (instance? bool a) (= a False))) + "number?" (fn [a] (instance? int a)) "string?" (fn [a] (and (string? a) (not (keyword? a)))) "symbol" (fn [a] (Sym a)) "symbol?" (fn [a] (instance? Sym a)) "keyword" (fn [a] (Keyword (if (keyword? a) a (+ ":" a)))) "keyword?" (fn [a] (keyword? a)) + "fn?" (fn [a] (and (callable a) (or (not (hasattr a "macro")) + (not a.macro)))) + "macro?" (fn [a] (and (callable a) (and (hasattr a "macro") a.macro))) "pr-str" (fn [&rest a] (Str (.join " " (map (fn [e] (pr-str e True)) a)))) "str" (fn [&rest a] (Str (.join "" (map (fn [e] (pr-str e False)) a)))) diff --git a/php/core.php b/php/core.php index 49c63246fa..245b938ecd 100644 --- a/php/core.php +++ b/php/core.php @@ -209,12 +209,15 @@ function swap_BANG($atm, $f) { 'nil?'=> function ($a) { return _nil_Q($a); }, 'true?'=> function ($a) { return _true_Q($a); }, 'false?'=> function ($a) { return _false_Q($a); }, + 'number?'=> function ($a) { return _number_Q($a); }, 'symbol'=> function () { return call_user_func_array('_symbol', func_get_args()); }, 'symbol?'=> function ($a) { return _symbol_Q($a); }, 'keyword'=> function () { return call_user_func_array('_keyword', func_get_args()); }, 'keyword?'=> function ($a) { return _keyword_Q($a); }, 'string?'=> function ($a) { return _string_Q($a); }, + 'fn?'=> function($a) { return _fn_Q($a) || (_function_Q($a) && !$a->ismacro ); }, + 'macro?'=> function($a) { return _function_Q($a) && $a->ismacro; }, 'pr-str'=> function () { return call_user_func_array('pr_str', func_get_args()); }, 'str'=> function () { return call_user_func_array('str', func_get_args()); }, 'prn'=> function () { return call_user_func_array('prn', func_get_args()); }, diff --git a/php/types.php b/php/types.php index 1279f88f8e..57157b314a 100644 --- a/php/types.php +++ b/php/types.php @@ -50,6 +50,7 @@ function _false_Q($obj) { return $obj === false; } function _string_Q($obj) { return is_string($obj) && strpos($obj, chr(0x7f)) !== 0; } +function _number_Q($obj) { return is_int($obj); } // Symbols @@ -114,6 +115,7 @@ function _function($func, $type='platform', return new FunctionClass($func, $type, $ast, $env, $params, $ismacro); } function _function_Q($obj) { return $obj instanceof FunctionClass; } +function _fn_Q($obj) { return $obj instanceof Closure; } // Parent class of list, vector, hash-map diff --git a/powershell/core.psm1 b/powershell/core.psm1 index f95464cffa..b2e592dee3 100644 --- a/powershell/core.psm1 +++ b/powershell/core.psm1 @@ -103,11 +103,15 @@ $core_ns = @{ "nil?" = { param($a); $a -eq $null }; "true?" = { param($a); $a -eq $true }; "false?" = { param($a); $a -eq $false }; + "number?" = { param($a); $a -is [int32] }; "string?" = { param($a); string? $a }; "symbol" = Get-Command new-symbol; "symbol?" = { param($a); symbol? $a }; "keyword" = Get-Command new-keyword; "keyword?" = { param($a); keyword? $a }; + "fn?" = { param($a); (fn? $a) -or ((malfunc? $a) -and + (-not $a.macro)) }; + "macro?" = { param($a); (malfunc? $a) -and $a.macro }; "pr-str" = { pr_seq $args $true " " }; "str" = { pr_seq $args $false "" }; diff --git a/powershell/types.psm1 b/powershell/types.psm1 index e2fb735ec2..7eeaa37fc1 100644 --- a/powershell/types.psm1 +++ b/powershell/types.psm1 @@ -271,6 +271,10 @@ function new-malfunc($ast, $params, $env, $fn, $macro, $meta) { function malfunc?($obj) { $obj -is [MalFunc] } + +function fn?($obj) { + $obj -is [System.Management.Automation.ScriptBlock] +} # # General functions # diff --git a/scala/core.scala b/scala/core.scala index f92e660da8..c56851beff 100644 --- a/scala/core.scala +++ b/scala/core.scala @@ -31,6 +31,21 @@ object core { } } + def fn_Q(a: List[Any]) = { + a(0) match { + case s: Func => true + case s: MalFunction => !s.asInstanceOf[MalFunction].ismacro + case _ => false + } + } + + def macro_Q(a: List[Any]) = { + a(0) match { + case s: MalFunction => s.asInstanceOf[MalFunction].ismacro + case _ => false + } + } + // number functions def _bool_op(a: List[Any], op: (Long, Long) => Boolean) = { op(a(0).asInstanceOf[Long],a(1).asInstanceOf[Long]) @@ -40,6 +55,10 @@ object core { op(a(0).asInstanceOf[Long],a(1).asInstanceOf[Long]) } + def number_Q(a: List[Any]) = { + a(0).isInstanceOf[Long] || a(0).isInstanceOf[Double] + } + // string functions def read_string(a: List[Any]) = { @@ -232,11 +251,14 @@ object core { "nil?" -> ((a: List[Any]) => a(0) == null), "true?" -> ((a: List[Any]) => a(0) == true), "false?" -> ((a: List[Any]) => a(0) == false), + "number?" -> number_Q _, "string?" -> string_Q _, "symbol" -> ((a: List[Any]) => Symbol(a(0).asInstanceOf[String])), "symbol?" -> ((a: List[Any]) => a(0).isInstanceOf[Symbol]), "keyword" -> keyword _, "keyword?" -> keyword_Q _, + "fn?" -> fn_Q, + "macro?" -> macro_Q, "pr-str" -> ((a: List[Any]) => _pr_list(a, true, " ")), "str" -> ((a: List[Any]) => _pr_list(a, false, "")), From 2ff47a342fa3deb66b324bea227b8a8e81743429 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 23 Oct 2017 17:15:42 +0200 Subject: [PATCH 0237/1998] Fix typo --- tests/stepA_mal.mal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/stepA_mal.mal b/tests/stepA_mal.mal index 5adb0824fa..7ba1c30372 100644 --- a/tests/stepA_mal.mal +++ b/tests/stepA_mal.mal @@ -100,7 +100,7 @@ ;; TODO move these to optional functionality after adding them to all ;; implementations ;; -;; Testing string? function +;; Testing number? function (number? 123) ;=>true (number? -1) From 27a793e1d5d17b410d15c02c689b56fc22b338dc Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 23 Oct 2017 17:15:49 +0200 Subject: [PATCH 0238/1998] hy: Add missing cond macro --- hy/stepA_mal.hy | 1 + 1 file changed, 1 insertion(+) diff --git a/hy/stepA_mal.hy b/hy/stepA_mal.hy index 67c9943417..0981895fd9 100755 --- a/hy/stepA_mal.hy +++ b/hy/stepA_mal.hy @@ -174,6 +174,7 @@ (REP "(def! *gensym-counter* (atom 0))") (REP "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))") (REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))") +(REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") (defmain [&rest args] (if (>= (len args) 2) From f996de18bb6f3f8e0265c144001e00a855e744f3 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 23 Oct 2017 17:16:00 +0200 Subject: [PATCH 0239/1998] hy: Fix number? --- hy/core.hy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hy/core.hy b/hy/core.hy index 37ce46659c..b78dfd8c96 100644 --- a/hy/core.hy +++ b/hy/core.hy @@ -27,7 +27,7 @@ "nil?" none? "true?" (fn [a] (and (instance? bool a) (= a True))) "false?" (fn [a] (and (instance? bool a) (= a False))) - "number?" (fn [a] (instance? int a)) + "number?" (fn [a] (and (not (instance? bool a)) (instance? int a))) "string?" (fn [a] (and (string? a) (not (keyword? a)))) "symbol" (fn [a] (Sym a)) "symbol?" (fn [a] (instance? Sym a)) From 1a318c5ed8b71f9531e0cc0795db2f14981e6ebe Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 23 Oct 2017 23:14:57 +0100 Subject: [PATCH 0240/1998] Work on object comparison Compare integers and char characters. Needed for associative (map) type on symbols. --- nasm/core.asm | 33 ++++++++++ nasm/step2_eval.asm | 4 +- nasm/types.asm | 157 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 192 insertions(+), 2 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 79d88cda7d..13b9436387 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -84,3 +84,36 @@ core_arithmetic: mov [rax], BYTE maltype_nil mov [rax + Cons.typecdr], BYTE content_nil ret + +;; Test objects for equality +core_equal_p: + ; Check that rsi contains a list + mov cl, BYTE [rsi] + and cl, block_mask + container_mask + cmp cl, block_cons + container_list + jne .error + + ; Check that the list has a second pointer + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .error + + ; move second pointer into rdi + mov rdi, [rsi + Cons.cdr] + + ; Compare rsi and rdi objects + call compare_objects ; result in rax + + ; for now put result into Cons + mov rdi, rax + call alloc_cons + mov [rax], BYTE maltype_integer + mov [rax + Cons.typecdr], BYTE content_nil + mov [rax + Cons.car], rdi + ret +.error: + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index eed5fe19b8..1bd9524d76 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -93,9 +93,9 @@ _start: call read_str push rax - ; Add together + ; Compare objects mov rsi, rax - call core_add + call core_equal_p ; Put into pr_str mov rsi, rax diff --git a/nasm/types.asm b/nasm/types.asm index 0bb89556a9..e40443d687 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -644,6 +644,163 @@ itostring: ret + +;; ------------------------------------------------------------ +;; Object comparison +;; +;; These comparison functions take two objects +;; in RSI and RDI +;; and return a code (not an object) in RAX +;; +;; RAX = 0 Objects are equal +;; 1 RSI object is greater than RDI +;; 2 RSI object is less than RDI +;; -1 Different object types, or no ordering +;; +;; Note that the ordering of objects depends on the type +;; strings - Alphabetical +;; +;; +;; + +;; Given an object in RSI, follows pointers +;; to return the value object in RAX +;; +;; Modifies registers: +;; RCX +compare_get_value: + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + jnz .nop ; Got an Array + + ; Here got Cons + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + jne .nop ; Not a pointer + + ; Got a pointer, so follow and return + mov rax, [rsi + Cons.car] + ret +.nop: + mov rax, rsi + ret + +;; Compare two objects. Note that this does not compare lists +;; but will just compare the first element +;; +;; Modifies registers +;; RCX +;; RBX +compare_objects: + ; Get the value that RSI points to + call compare_get_value + mov rbx, rax ; Save in RBX + ; Get the value that RDI points to + mov rsi, rdi + call compare_get_value + mov rdi, rax + mov rsi, rbx + + ; now get types + mov cl, BYTE [rsi] ; Type of RSI + mov bl, BYTE [rdi] ; Type of RDI + + ; Don't care about container type + and cl, block_mask + content_mask + and bl, block_mask + content_mask + + cmp bl, cl ; compare block and content + jne .different_types + + ; Here the same block, content type + ; May be different container (value/list, string/symbol) + cmp bl, block_cons + content_nil + je .objects_equal ; nil + + cmp bl, block_array + content_char + je compare_char_array ; strings, symbols + + cmp bl, block_cons + content_int + je .integers + + ; Unknown + jmp .different_types + +.integers: + ; two Cons objects, both containing integers + mov rbx, [rsi + Cons.car] + cmp rbx, [rdi + Cons.car] + je .objects_equal + jl .rdi_greater + jmp .rsi_greater + +.objects_equal: + mov rax, 0 + ret + +.rsi_greater: ; rsi > rdi + mov rax, 1 + ret + +.rdi_greater: ; rdi > rsi + mov rax, 2 + ret + +.different_types: + mov rax, -1 + ret + + +;; Char array objects (strings, symbols, keywords) in RSI and RDI +;; Return code in RAX +;; +;; Modifies registers: +;; RBX +;; RCX +;; RDX +compare_char_array: + ; Check length + mov eax, DWORD [rsi + Array.length] + mov ebx, DWORD [rdi + Array.length] + cmp eax, ebx + jne .different + + ; same length + mov rbx, rsi + add rbx, Array.data + mov rcx, rdi + add rcx, Array.data +.compare_loop: + ; get next character + mov dl, BYTE [rbx] + cmp dl, BYTE [rcx] + jl .rdi_greater + jg .rsi_greater + + ; equal + inc rbx + inc rcx + dec eax + jnz .compare_loop + + ; equal + mov rax, 0 + ret + +.rsi_greater: ; rsi > rdi + mov rax, 1 + ret + +.rdi_greater: ; rdi > rsi + mov rax, 2 + ret + +.different: + mov rax, -1 + ret + ;; ------------------------------------------------------------ ;; Map type From 677cfe0c18dabad86c897d1c03f76a23df02bd3c Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Tue, 24 Oct 2017 13:09:47 +0000 Subject: [PATCH 0241/1998] objc, perl6, r: Add number?, fn?, macro? --- objc/core.m | 10 ++++++++++ perl6/core.pm | 3 +++ r/core.r | 3 +++ r/types.r | 5 +++++ 4 files changed, 21 insertions(+) diff --git a/objc/core.m b/objc/core.m index 1397019791..2acceeec8b 100644 --- a/objc/core.m +++ b/objc/core.m @@ -48,6 +48,16 @@ + (NSDictionary *)ns { ![args[0] isKindOfClass:[MalSymbol class]] && !string_Q(args[0])); }, + @"number?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[NSNumber class]]); + }, + @"fn?": ^(NSArray *args){ + return wrap_tf(block_Q(args[0]) || + ([args[0] isKindOfClass:[MalFunc class]] && ![(MalFunc *)args[0] isMacro])); + }, + @"macro?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[MalFunc class]] && [(MalFunc *)args[0] isMacro]); + }, @"pr-str": ^(NSArray *args){ NSMutableArray * res = [NSMutableArray array]; diff --git a/perl6/core.pm b/perl6/core.pm index a3f20253bd..50baa455bc 100644 --- a/perl6/core.pm +++ b/perl6/core.pm @@ -79,6 +79,9 @@ our %ns = ( symbol => MalCode({ MalSymbol($^a.val) }), keyword => MalCode({ $^a.val ~~ /^\x29E/ ?? $^a !! MalString("\x29E" ~ $^a.val) }), 'keyword?' => MalCode({ $^a.val ~~ /^\x29E/ ?? $TRUE !! $FALSE }), + 'number?' => MalCode({ $^a ~~ MalNumber ?? $TRUE !! $FALSE }), + 'fn?' => MalCode({ ($^a ~~ MalCallable && !$^a.?is_macro) ?? $TRUE !! $FALSE }), + 'macro?' => MalCode({ $^a.?is_macro ?? $TRUE !! $FALSE }), vector => MalCode({ MalVector(@_) }), 'vector?' => MalCode({ $^a ~~ MalVector ?? $TRUE !! $FALSE }), hash-map => MalCode({ MalHashMap(@_.map({ $^a.val => $^b }).Hash) }), diff --git a/r/core.r b/r/core.r index 2a658e4cc1..a14c0740b1 100644 --- a/r/core.r +++ b/r/core.r @@ -145,6 +145,9 @@ core_ns <- list( "symbol?"=.symbol_q, "keyword"=new.keyword, "keyword?"=.keyword_q, + "number?"=.number_q, + "fn?"=.fn_q, + "macro?"=.macro_q, "pr-str"=pr_str, "str"=str, diff --git a/r/types.r b/r/types.r index b9ecfe4225..bfadaa1f7f 100644 --- a/r/types.r +++ b/r/types.r @@ -104,6 +104,8 @@ new.keyword <- function(name) concat("\u029e", name) "" == substring(obj,1,8)) } +.number_q <- function(obj) "numeric" == class(obj) || "integer" == class(obj) + # Functions malfunc <- function(eval, ast, env, params) { @@ -128,6 +130,9 @@ fapply <- function(mf, args) { } } +.fn_q <- function(obj) "function" == class(obj) || (.malfunc_q(obj) && !obj$ismacro) +.macro_q <- function(obj) .malfunc_q(obj) && obj$ismacro + # Lists new.list <- function(...) new.listl(list(...)) new.listl <- function(lst) { class(lst) <- "List"; lst } From 14a5c0d8bc0f676dea73940330f4cb212968a610 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 24 Oct 2017 09:29:51 -0500 Subject: [PATCH 0242/1998] make: move macro attr to fn rather than in env. --- make/step8_macros.mk | 4 ++-- make/step9_try.mk | 4 ++-- make/stepA_mal.mk | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/make/step8_macros.mk b/make/step8_macros.mk index 7ea351edec..7ee0a94404 100644 --- a/make/step8_macros.mk +++ b/make/step8_macros.mk @@ -32,7 +32,7 @@ $(strip \ endef define IS_MACRO_CALL -$(if $(call _list?,$(1)),$(call ENV_FIND,$(2),_macro_$($(call _nth,$(1),0)_value)),) +$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) endef define MACROEXPAND @@ -96,7 +96,7 @@ $(if $(__ERROR),,\ $(foreach a1,$(call _nth,$(1),1),\ $(foreach a2,$(call _nth,$(1),2),\ $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(call ENV_SET,$(2),_macro_$($(a1)_value),true),,)\ + $(eval _macro_$(res) = true)\ $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ $(if $(call _EQ,macroexpand,$($(a0)_value)),\ $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ diff --git a/make/step9_try.mk b/make/step9_try.mk index 47d1fd72f2..2066795625 100644 --- a/make/step9_try.mk +++ b/make/step9_try.mk @@ -32,7 +32,7 @@ $(strip \ endef define IS_MACRO_CALL -$(if $(call _list?,$(1)),$(call ENV_FIND,$(2),_macro_$($(call _nth,$(1),0)_value)),) +$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) endef define MACROEXPAND @@ -96,7 +96,7 @@ $(if $(__ERROR),,\ $(foreach a1,$(call _nth,$(1),1),\ $(foreach a2,$(call _nth,$(1),2),\ $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(call ENV_SET,$(2),_macro_$($(a1)_value),true),,)\ + $(eval _macro_$(res) = true)\ $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ $(if $(call _EQ,macroexpand,$($(a0)_value)),\ $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ diff --git a/make/stepA_mal.mk b/make/stepA_mal.mk index 5e3642076f..475009d598 100644 --- a/make/stepA_mal.mk +++ b/make/stepA_mal.mk @@ -32,7 +32,7 @@ $(strip \ endef define IS_MACRO_CALL -$(if $(call _list?,$(1)),$(call ENV_FIND,$(2),_macro_$($(call _nth,$(1),0)_value)),) +$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) endef define MACROEXPAND @@ -96,7 +96,7 @@ $(if $(__ERROR),,\ $(foreach a1,$(call _nth,$(1),1),\ $(foreach a2,$(call _nth,$(1),2),\ $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(call ENV_SET,$(2),_macro_$($(a1)_value),true),,)\ + $(eval _macro_$(res) = true)\ $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ $(if $(call _EQ,macroexpand,$($(a0)_value)),\ $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ From b156d1f1459870b64d1d7f84913010591e3364ff Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 24 Oct 2017 09:31:16 -0500 Subject: [PATCH 0243/1998] make, miniMAL: add number?, fn? and macro? --- make/core.mk | 8 +++++--- miniMAL/core.json | 8 ++++++++ miniMAL/miniMAL-core.json | 4 ++++ 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/make/core.mk b/make/core.mk index 1497527ec3..4e6da5b0a5 100644 --- a/make/core.mk +++ b/make/core.mk @@ -76,7 +76,8 @@ subs = $(strip \ # Function functions -function? = $(if $(call _function?,$(1)),$(__true),$(__false)) +fn? = $(if $(call _function?,$(1)),$(if $(_macro_$(1)),$(__false),$(__true)),$(__false)) +macro? = $(if $(_macro_$(1)),$(__true),$(__false)) # List functions @@ -239,7 +240,9 @@ core_ns = type obj_type \ symbol? symbol? \ keyword keyword \ keyword? keyword? \ - function? function? \ + number? number? \ + fn? fn? \ + macro? macro? \ \ pr-str pr_str \ str str \ @@ -249,7 +252,6 @@ core_ns = type obj_type \ read-string read_str \ slurp slurp \ subs subs \ - number? number? \ < number_lt \ <= number_lte \ > number_gt \ diff --git a/miniMAL/core.json b/miniMAL/core.json index 53d599c724..edc39aa7e0 100644 --- a/miniMAL/core.json +++ b/miniMAL/core.json @@ -121,6 +121,14 @@ ["`", "symbol?"], "symbol?", ["`", "keyword"], "keyword", ["`", "keyword?"], "keyword?", + ["`", "number?"], "number?", + ["`", "fn?"], ["fn", ["a"], + ["or", ["function?", "a"], + ["and", ["malfunc?", "a"], + ["not", ["get", "a", ["`", "macro?"]]]]]], + ["`", "macro?"], ["fn", ["a"], + ["and", ["malfunc?", "a"], + ["get", "a", ["`", "macro?"]]]], ["`", "pr-str"], ["fn", ["&", "a"], ["pr-list", "a", true, ["`", " "]]], ["`", "str"], ["fn", ["&", "a"], ["pr-list", "a", false, ["`", ""]]], diff --git a/miniMAL/miniMAL-core.json b/miniMAL/miniMAL-core.json index 632cd2629d..cc3379f0e7 100644 --- a/miniMAL/miniMAL-core.json +++ b/miniMAL/miniMAL-core.json @@ -31,6 +31,10 @@ ["=", ["`", "String"], [".-", [".-", "a", ["`", "constructor"]], ["`", "name"]]]]]], +["def", "number?", ["fn", ["a"], + ["=", ["`", "[object Number]"], ["classOf", "a"]]]], +["def", "function?", ["fn", ["a"], + ["isa", "a", "Function"]]], ["def", "pr-list*", ["fn", ["a", "b", "c"], [".", ["map", ["fn", ["x"], From 69e561c0e02f6098c6317e4fb5e3fe6fd9da8a7d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 24 Oct 2017 23:01:45 +0100 Subject: [PATCH 0244/1998] Hash map read & print working Implementation is as a list, not a hash. The code is therefore essentially the same as the list read/print routines. --- nasm/printer.asm | 105 +++++++++++++++++++++++++++++- nasm/reader.asm | 163 +++++++++++++++++++++++++++++++++++++++++++++-- nasm/types.asm | 2 +- 3 files changed, 259 insertions(+), 11 deletions(-) diff --git a/nasm/printer.asm b/nasm/printer.asm index 584491d9a2..839284322c 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -104,18 +104,22 @@ pr_str: and ch, container_mask jz .value - cmp ch, 2 + cmp ch, container_list je .list - cmp ch, 4 + cmp ch, container_symbol je .symbol + cmp ch, container_map + je .map + ; Unknown mov rsi, unknown_type_string mov edx, unknown_type_string.len call raw_to_string ; Puts a String in RAX ret + ; -------------------------------- .value: mov ch, cl and ch, content_mask @@ -129,16 +133,20 @@ pr_str: call raw_to_string ; Puts a String in RAX ret + ; -------------------------------- .value_nil: mov rsi, nil_value_string mov edx, nil_value_string.len call raw_to_string ret + ; -------------------------------- .value_int: mov rax, [rsi + Cons.car] call itostring ret + + ; -------------------------------- .list: mov r12, rsi ; Input list @@ -229,6 +237,8 @@ pr_str: mov rax, rsi ret + + ; -------------------------------- .symbol: ; Make a copy of the string call string_new ; in rax @@ -251,8 +261,97 @@ pr_str: add r12, 8 ; Next 64 bits of output jmp .symbol_copy_loop .symbol_finished: + ret + + ; -------------------------------- +.map: + mov r12, rsi ; Input map + call string_new ; String in rax + mov r13, rax ; Output string in r13 - ret + ; Put '{' onto string + mov rsi, rax + mov cl, '{' + call string_append_char + + ; loop through map +.map_loop: + + ; Extract values and print + + mov rsi, r12 + mov cl, BYTE [rsi] ; Get type + + ; Check if it's a pointer (address) + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + je .map_loop_pointer + + cmp ch, content_empty + je .map_check_end + + ; A value (nil, int etc. or function) + xor cl, container_map ; Remove map type -> value + mov BYTE [rsi], cl + + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + + mov cl, BYTE [r12] + or cl, container_map ; Restore map type + mov BYTE [r12], cl + jmp .map_loop_got_str +.map_loop_pointer: + mov rsi, [rsi + Cons.car] ; Address of object + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + +.map_loop_got_str: + ; concatenate strings in rax and rsi + mov rsi, r13 ; Output string + mov rdx, rax ; String to be copied + + push rsi ; Save output string + push rax ; save temporary string + call string_append_string + + ; Release the string + pop rsi ; Was in rax, temporary string + call release_array + + pop rsi ; restore output string +.map_check_end: + ; Check if this is the end of the map + mov cl, BYTE [r12 + Cons.typecdr] + cmp cl, content_nil + je .map_finished + + ; More left in the map + + ; Add space between values + mov cl, ' ' + mov rsi, r13 + call string_append_char + ; Get next Cons + mov r12, [r12 + Cons.cdr] + jmp .map_loop + +.map_finished: + ; put '}' at the end of the string + mov cl, '}' + mov rsi, r13 + call string_append_char + + mov rax, rsi + ret + diff --git a/nasm/reader.asm b/nasm/reader.asm index f23bb5df8d..6058784043 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -1,5 +1,7 @@ section .data +;; Reader macro strings + quote_symbol_string: db "quote" .len: equ $ - quote_symbol_string @@ -12,8 +14,16 @@ unquote_symbol_string: db "unquote" splice_unquote_symbol_string: db "splice-unquote" .len: equ $ - splice_unquote_symbol_string +deref_symbol_string: db "deref" +.len: equ $ - deref_symbol_string + +;; Error message strings + error_string_unexpected_end: db "Error: Unexpected end of input. Could be a missing )", 10 .len: equ $ - error_string_unexpected_end + +error_string_bracket_not_brace: db "Error: Expecting '}' but got ')'" +.len: equ $ - error_string_bracket_not_brace section .text @@ -64,14 +74,9 @@ read_str: jne .got_token ; Unexpected end of tokens - push r14 - push r15 mov rdx, error_string_unexpected_end.len mov rsi, error_string_unexpected_end - call print_rawstring - pop r15 - pop r14 - jmp .unwind + jmp .error .got_token: @@ -84,10 +89,16 @@ read_str: cmp cl, '(' je .list_start - + cmp cl, ')' je .return_nil ; Note: if reading a list, cl will be tested in the list reader + cmp cl, '{' + je .map_start + + cmp cl, '}' ; cl tested in map reader + je .return_nil + cmp cl, 39 ; quote ' je .handle_quote cmp cl, '`' @@ -96,6 +107,8 @@ read_str: je .handle_unquote cmp cl, 1 je .handle_splice_unquote + cmp cl, '@' + je .handle_deref ; Unknown jmp .return_nil @@ -207,6 +220,113 @@ read_str: ret + ; -------------------------------- + +.map_start: + + ; Get the first value + ; Note that we call rather than jmp because the first + ; value needs to be treated differently. There's nothing + ; to append to yet... + call .read_loop + + ; rax now contains the first object + cmp cl, '}' ; Check if it was end of map + jne .map_has_contents + mov cl, 0 ; so '}' doesn't propagate to nested maps + ; Set map to empty + mov [rax], BYTE maltype_empty_map + ret ; Returns 'nil' given "()" +.map_has_contents: + ; If this is a Cons then use it + ; If not, then need to allocate a Cons + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .map_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new map + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_map + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.map_is_value: + ; Cons in RAX + ; Make sure it's marked as a map + mov cl, BYTE [rax] + or cl, container_map + mov [rax], BYTE cl + + mov r12, rax ; Start of current map + mov r13, rax ; Set current map + cmp r15, 0 ; Test if first map + jne .map_read_loop + mov r15, rax ; Save the first, for unwinding + +.map_read_loop: + ; Repeatedly get the next value in the map + ; (which may be other maps) + ; until we get a '}' token + + push r12 + push r13 + call .read_loop ; object in rax + pop r13 + pop r12 + + cmp cl, '}' ; Check if it was end of map + je .map_done ; Have nil object in rax + + ; Test if this is a Cons value + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .map_loop_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new map + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_map + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.map_loop_is_value: + ; Cons in RAX + + ; Make sure it's marked as a map + mov cl, BYTE [rax] + or cl, container_map + mov [rax], BYTE cl + + ; Append to r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax ; Set current map + + jmp .map_read_loop + +.map_done: + ; Release nil object in rax + mov rsi, rax + call release_cons + + ; Terminate the map + mov [r13 + Cons.typecdr], BYTE content_nil + mov QWORD [r13 + Cons.cdr], QWORD 0 + mov rax, r12 ; Start of current map + + ret + ; -------------------------------- .handle_quote: ; Turn 'a into (quote a) @@ -293,11 +413,40 @@ read_str: pop r9 pop r8 jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- + +.handle_deref: + ; Turn @a into (deref a) + + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "deref" + push r8 + push r9 + mov rsi, deref_symbol_string + mov edx, deref_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + ; -------------------------------- .finished: ret +.error: + ; Jump here on error with raw string in RSI + ; and string length in rdx + push r14 + push r15 + call print_rawstring + pop r15 + pop r14 + + ; fall through to unwind .unwind: ; Jump to here cleans up diff --git a/nasm/types.asm b/nasm/types.asm index e40443d687..ddc6d4952a 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -116,7 +116,7 @@ ENDSTRUC %define maltype_symbol (block_array + container_symbol + content_char) %define maltype_nil (block_cons + container_value + content_nil) %define maltype_empty_list (block_cons + container_list + content_empty) - +%define maltype_empty_map (block_cons + container_map + content_empty) ;; ------------------------------------------ From 0c7d765c12c384c1cbacc56a8678962c788948ef Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 25 Oct 2017 00:16:06 +0100 Subject: [PATCH 0245/1998] map_find finds values in a Map type Works in simple tests, returns address of position in the map, and sets Zero Flag if value is found. This function will be used in both set and get methods --- nasm/types.asm | 95 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 94 insertions(+), 1 deletion(-) diff --git a/nasm/types.asm b/nasm/types.asm index ddc6d4952a..3deaccc967 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -687,7 +687,8 @@ compare_get_value: mov rax, rsi ret -;; Compare two objects. Note that this does not compare lists +;; Compare two objects in RSI and RDI. +;; Note that this does not compare lists ;; but will just compare the first element ;; ;; Modifies registers @@ -916,3 +917,95 @@ map_add: mov [rax], BYTE maltype_nil mov [rax + Cons.typecdr], BYTE content_nil ret + +;; Find a key in a map +;; +;; Inputs: RSI - map +;; RDI - key +;; +;; Outputs: RAX - Cons object containing value in CAR +;; +;; If value is found then the Zero Flag is set +;; +;; Examples: +;; {a 1 b 2} find a -> {1 b 2} +;; {1 2 3 4} find a -> {4} +map_find: + mov al, BYTE [rsi] + cmp al, maltype_empty_map + je .not_found + +.map_loop: + ; compare RSI and RDI, ignoring differences in container + push rsi + push rdi + call compare_objects + pop rdi + pop rsi + + ; rax is now zero if objects are equal + cmp rax, 0 + je .found + + ; Move along two cons to the next key + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .error ; Expecting value after key + + mov rsi, [rsi + Cons.cdr] ; Get value + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .not_found + + mov rsi, [rsi + Cons.cdr] ; Get next key + + jmp .map_loop ; Test next key + +.found: + + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + + ; key in rsi. Get next value + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .error ; Expecting value after key + + mov rsi, [rsi + Cons.cdr] + + ; increment reference count + mov ax, WORD [rsi + Cons.refcount] + inc ax + mov [rsi + Cons.refcount], WORD ax + ; Put address in rax + mov rax, rsi + ret + +.not_found: + lahf ; flags in AH + and ah, 255-64 ; remove zero flag + sahf + + ; last cons in rsi + ; increment reference count + mov ax, WORD [rsi + Cons.refcount] + inc ax + mov [rsi + Cons.refcount], WORD ax + ; Put address in rax + mov rax, rsi + + ret + +.error: + + lahf ; flags in AH + or ah, 255-64 ; set zero flag + sahf + + ; return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + From 7d4d355ecbcd4ce054d83172e3341f82231271cb Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 25 Oct 2017 20:56:46 +0000 Subject: [PATCH 0246/1998] factor: Add number?, fn?, macro? --- factor/lib/core/core.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/factor/lib/core/core.factor b/factor/lib/core/core.factor index 906be6553b..b51458b8a8 100644 --- a/factor/lib/core/core.factor +++ b/factor/lib/core/core.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs combinators combinators.short-circuit fry grouping hash-sets hashtables io io.encodings.utf8 io.files kernel lists lib.env lib.printer -lib.reader lib.types math namespaces readline sequences sets +lib.reader lib.types math namespaces quotations readline sequences sets strings system vectors ; IN: lib.core @@ -50,6 +50,9 @@ CONSTANT: ns H{ { "string?" [ first string? ] } { "keyword" [ first ] } { "keyword?" [ first malkeyword? ] } + { "number?" [ first number? ] } + { "fn?" [ first { [ callable? ] [ { [ malfn? ] [ macro?>> not ] } 1&& ] } 1|| ] } + { "macro?" [ first { [ malfn? ] [ macro?>> ] } 1&& ] } { "vector" [ >vector ] } { "vector?" [ first vector? ] } { "hash-map" [ 2 group parse-hashtable ] } From 2992dc7151a5981d1a88e8329d1e4f22ac641850 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 25 Oct 2017 22:48:05 +0100 Subject: [PATCH 0247/1998] Added map_set function Replaces a value if already in the map, or adds the key-value pair. --- nasm/types.asm | 156 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 153 insertions(+), 3 deletions(-) diff --git a/nasm/types.asm b/nasm/types.asm index 3deaccc967..641beb1e4e 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -39,6 +39,7 @@ ;; 80 5 - Pointer (memory address) ;; 96 6 - Function (instruction address) ;; 112 7 - Empty (distinct from Nil) +;; ;; ;; These represent MAL data types as follows: ;; @@ -804,7 +805,10 @@ compare_char_array: ;; ------------------------------------------------------------ ;; Map type - +;; +;; This uses a list (Cons type) to represent key-value pairs in +;; a single chain. The only map which consists of an odd number of Cons +;; objects is the empty map, created by map_new map_new: call alloc_cons mov [rax], BYTE (block_cons + container_map + content_empty) @@ -920,11 +924,16 @@ map_add: ;; Find a key in a map ;; -;; Inputs: RSI - map -;; RDI - key +;; Inputs: RSI - map [ Modified ] +;; RDI - key [ Modified ] ;; ;; Outputs: RAX - Cons object containing value in CAR ;; +;; Modifies registers: +;; RBX [compare_objects, alloc_cons] +;; RCX [compare_objects] +;; +;; ;; If value is found then the Zero Flag is set ;; ;; Examples: @@ -1008,4 +1017,145 @@ map_find: mov [rax], BYTE maltype_nil mov [rax + Cons.typecdr], BYTE content_nil ret + +;; Map set +;; +;; Sets a key-value pair in a map +;; +;; Inputs: RSI - map [modified] +;; RDI - key [modified] +;; RCX - value +;; +map_set: + ; Save inputs in less volatile registers + mov r8, rsi ; map + mov r9, rdi ; key + mov r10, rcx ; value + + ; Find the key, to see if it already exists in the map + call map_find ; Cons object in RAX + je .found_key + + ; Key not in map. RAX should be address of the last + ; value in the map, or empty + mov rbx, r8 + cmp bl, maltype_empty_map + je .set_key + + ; Append key + push rax + call alloc_cons ; New Cons in rax + pop rbx ; Last Cons in map + + ; append rax to rbx + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rax + jmp .set_key ; Put key into rax + +.found_key: + ; Key already in map, so replace value + ; address in RAX + + ; check type of value already there + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .set_value ; Not a pointer, just overwrite + + ; A pointer, so need to release + mov rsi, [rax + Cons.car] ; Address of object + push rax + call release_object + pop rax + + jmp .set_value ; put value into Cons + +.set_key: + ; Put key (R9) in RAX + + ; Check the type of object + mov bl, BYTE [r9] + mov bh, bl + and bh, block_mask + jnz .set_key_pointer ; Array, so point to it + + ; Here a Cons object + mov bh, bl + and bh, container_mask + cmp bl, container_value + jne .set_key_pointer ; Not a simple value, so point to it + ; A value, so copy + mov rcx, [r9 + Cons.car] + mov [rax + Cons.car], rcx + + ; Set the type + and bl, content_mask + or bl, (block_cons + container_map) + mov [rax], BYTE bl + + jmp .set_key_done + +.set_key_pointer: + ; The key is a pointer + + mov [rax + Cons.car], r9 + mov [rax], BYTE (block_cons + container_map + content_pointer) + ; Increment reference count + mov bx, WORD [r9 + Cons.refcount] + inc bx + mov [r9 + Cons.refcount], bx + ; fall through to .set_key_done + +.set_key_done: + ; Key in RAX. allocate and append a Cons for the value + push rax + call alloc_cons ; value Cons in rax + pop rbx ; key Cons + ; append rax to rbx + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rax + + ; fall through to .set_value + + ; -------------------------------- +.set_value: + ; Set the value into the Cons at [rax] + + ; Check the type of object + mov bl, BYTE [r10] + mov bh, bl + and bh, block_mask + jnz .set_value_pointer ; Array, so point to it + + ; Here a Cons object + mov bh, bl + and bh, container_mask + cmp bl, container_value + jne .set_value_pointer ; Not a simple value, so point to it + ; A value, so copy + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + ; Set the type + and bl, content_mask + or bl, (block_cons + container_map) + mov [rax], BYTE bl + + jmp .finished + +.set_value_pointer: + mov [rax + Cons.car], r10 ; Put address into CAR + mov [rax], BYTE (block_cons + container_map + content_pointer) ; Mark as a pointer + ; Increment reference count + mov bx, WORD [r10 + Cons.refcount] + inc bx + mov [r10 + Cons.refcount], bx + ; fall through to .finished + +.finished: + ; Put the map into rax + mov rax, r8 + ret + + From 3d1dbb204e9a6d8938736facf8cb3b175b353456 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 25 Oct 2017 22:38:09 -0500 Subject: [PATCH 0248/1998] Dart, Groovy, Haskell: add number?, fn? and macro? --- dart/core.dart | 9 +++++++++ groovy/core.groovy | 5 +++++ haskell/Core.hs | 3 +++ haskell/Types.hs | 15 +++++++++++++-- 4 files changed, 30 insertions(+), 2 deletions(-) diff --git a/dart/core.dart b/dart/core.dart index 9213a8034b..01462e603d 100644 --- a/dart/core.dart +++ b/dart/core.dart @@ -169,6 +169,15 @@ Map ns = { new MalSymbol('keyword?'): new MalBuiltin((List args) { return new MalBool(args.first is MalKeyword); }), + new MalSymbol('number?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalInt); + }), + new MalSymbol('fn?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalCallable && !(args.first.isMacro)); + }), + new MalSymbol('macro?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalCallable && args.first.isMacro); + }), new MalSymbol('vector'): new MalBuiltin((List args) { return new MalVector(args); }), diff --git a/groovy/core.groovy b/groovy/core.groovy index 712cc08844..7291de8e56 100644 --- a/groovy/core.groovy +++ b/groovy/core.groovy @@ -1,6 +1,7 @@ import types import types.MalException import types.MalSymbol +import types.MalFunc import reader import printer @@ -72,6 +73,10 @@ class core { "symbol?": { a -> a[0] instanceof MalSymbol }, "keyword": { a -> types.keyword(a[0]) }, "keyword?": { a -> types.keyword_Q(a[0]) }, + "number?": { a -> a[0] instanceof Integer }, + "fn?": { a -> (a[0] instanceof MalFunc && !a[0].ismacro) || + a[0] instanceof Closure }, + "macro?": { a -> a[0] instanceof MalFunc && a[0].ismacro }, "pr-str": core.&do_pr_str, "str": core.&do_str, diff --git a/haskell/Core.hs b/haskell/Core.hs index 99a2bfa30f..995e4dc407 100644 --- a/haskell/Core.hs +++ b/haskell/Core.hs @@ -257,6 +257,9 @@ ns = [ ("symbol?", _func $ run_1 $ _symbol_Q), ("keyword", _func $ keyword), ("keyword?", _func $ run_1 $ _keyword_Q), + ("number?", _func $ run_1 $ _number_Q), + ("fn?", _func $ run_1 $ _fn_Q), + ("macro?", _func $ run_1 $ _macro_Q), ("pr-str", _func pr_str), ("str", _func str), diff --git a/haskell/Types.hs b/haskell/Types.hs index fc26ddb32c..8cf413cdf9 100644 --- a/haskell/Types.hs +++ b/haskell/Types.hs @@ -1,8 +1,8 @@ module Types (MalVal (..), MalError (..), IOThrows (..), Fn (..), EnvData (..), Env, throwStr, throwMalVal, _get_call, _to_list, - _func, _malfunc, - _nil_Q, _true_Q, _false_Q, _string_Q, _symbol_Q, _keyword_Q, + _func, _malfunc, _fn_Q, _macro_Q, + _nil_Q, _true_Q, _false_Q, _string_Q, _symbol_Q, _keyword_Q, _number_Q, _list_Q, _vector_Q, _hash_map_Q, _atom_Q) where @@ -98,6 +98,14 @@ _malfunc_meta ast env params fn meta = MalFunc {fn=(Fn fn), ast=ast, env=env, params=params, macro=False, meta=meta} +_fn_Q (MalFunc {macro=False}) = MalTrue +_fn_Q (Func _ _) = MalTrue +_fn_Q _ = MalFalse + +_macro_Q (MalFunc {macro=True}) = MalTrue +_macro_Q _ = MalFalse + + -- Scalars _nil_Q Nil = MalTrue _nil_Q _ = MalFalse @@ -118,6 +126,9 @@ _string_Q _ = MalFalse _keyword_Q (MalString ('\x029e':_)) = MalTrue _keyword_Q _ = MalFalse +_number_Q (MalNumber _) = MalTrue +_number_Q _ = MalFalse + -- Lists _list_Q (MalList _ _) = MalTrue From 0218385f8b380408cced674ea520dd9d363094cb Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 25 Oct 2017 22:38:24 -0500 Subject: [PATCH 0249/1998] Haxe, Matlab: add number?, fn? and macro? --- haxe/core/Core.hx | 3 +++ haxe/types/Types.hx | 15 +++++++++++++++ matlab/core.m | 3 +++ matlab/type_utils.m | 13 +++++++++++++ 4 files changed, 34 insertions(+) diff --git a/haxe/core/Core.hx b/haxe/core/Core.hx index a990af97bd..d7b82d3b57 100644 --- a/haxe/core/Core.hx +++ b/haxe/core/Core.hx @@ -328,6 +328,9 @@ class Core { "symbol?" => function(a) { return BoolFn(symbol_Q(a[0])); }, "keyword" => keyword, "keyword?" => function(a) { return BoolFn(keyword_Q(a[0])); }, + "number?" => function(a) { return BoolFn(number_Q(a[0])); }, + "fn?" => function(a) { return BoolFn(_fn_Q(a[0])); }, + "macro?" => function(a) { return BoolFn(_macro_Q(a[0])); }, "pr-str" => pr_str, "str" => str, diff --git a/haxe/types/Types.hx b/haxe/types/Types.hx index 5c25cce416..669e29b466 100644 --- a/haxe/types/Types.hx +++ b/haxe/types/Types.hx @@ -73,6 +73,13 @@ class Types { } } + public static function _fn_Q(x:MalType) { + return switch (x) { + case MalFunc(_,_,_,_,ismacro,_): !ismacro; + case _: false; + } + } + public static function _macro_Q(x:MalType) { return switch (x) { case MalFunc(_,_,_,_,ismacro,_): ismacro; @@ -124,6 +131,14 @@ class Types { } } + public static function number_Q(x:MalType) { + return switch (x) { + case MalInt(_): true; + case _: false; + } + } + + // Sequence operations public static function list_Q(x:MalType) { return switch (x) { diff --git a/matlab/core.m b/matlab/core.m index 4354f3a218..fe455d9491 100644 --- a/matlab/core.m +++ b/matlab/core.m @@ -230,6 +230,9 @@ n('symbol?') = @(a) isa(a, 'types.Symbol'); n('keyword') = @(a) type_utils.keyword(a); n('keyword?') = @(a) type_utils.keyword_Q(a); + n('number?') = @(a) type_utils.number_Q(a); + n('fn?') = @(a) type_utils.fn_Q(a); + n('macro?') = @(a) type_utils.macro_Q(a); n('pr-str') = @(varargin) core.pr_str(varargin{:}); n('str') = @(varargin) core.do_str(varargin{:}); diff --git a/matlab/type_utils.m b/matlab/type_utils.m index 8a4ce210ad..939df5260e 100644 --- a/matlab/type_utils.m +++ b/matlab/type_utils.m @@ -74,6 +74,19 @@ ret = strcmp(class(obj), 'char') && ~type_utils.keyword_Q(obj); end + function ret = number_Q(obj) + ret = strcmp(class(obj), 'double'); + end + + function ret = fn_Q(obj) + ret = isa(obj,'function_handle') || ... + (isa(obj,'types.Function') && ~obj.is_macro); + end + + function ret = macro_Q(obj) + ret = isa(obj,'types.Function') && obj.is_macro; + end + function print_stack(err) for i=1:numel(err.stack) stack = err.stack(i); From 9d7af55272282bad7e86707eb0dc85f23a0a26ab Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 26 Oct 2017 08:47:31 +0000 Subject: [PATCH 0250/1998] elixir, erlang, julia, kotlin: Add number?, fn?, macro? --- elixir/lib/mal/core.ex | 9 +++++++++ erlang/src/core.erl | 26 ++++++++++++++++++++++++++ julia/core.jl | 3 +++ kotlin/src/mal/core.kt | 4 ++++ 4 files changed, 42 insertions(+) diff --git a/elixir/lib/mal/core.ex b/elixir/lib/mal/core.ex index 6bb67d202f..ca651a4b79 100644 --- a/elixir/lib/mal/core.ex +++ b/elixir/lib/mal/core.ex @@ -47,6 +47,8 @@ defmodule Mal.Core do "swap!" => &swap!/1, "conj" => &conj/1, "seq" => &seq/1, + "fn?" => &fn?/1, + "macro?" => ¯o?/1, "time-ms" => fn _ -> :erlang.system_time(:milli_seconds) end, "readline" => fn [prompt] -> readline(prompt) end, "sequential?" => fn arg -> vector?(arg) or list?(arg) end, @@ -55,6 +57,7 @@ defmodule Mal.Core do "true?" => fn [type] -> type == true end, "false?" => fn [type] -> type == false end, "string?" => fn [obj] -> String.valid?(obj) end, + "number?" => fn [obj] -> is_number(obj) end, "symbol" => fn [name] -> {:symbol, name} end, "read-string" => fn [input] -> Mal.Reader.read_str(input) end, "throw" => fn [arg] -> throw({:error, arg}) end, @@ -230,4 +233,10 @@ defmodule Mal.Core do defp seq([""]), do: nil defp seq([s]), do: {:list, String.split(s, "", trim: true), nil} defp seq(_), do: nil + + defp fn?([%Function{macro: false}]), do: true + defp fn?(_), do: false + + defp macro?([%Function{macro: true}]), do: true + defp macro?(_), do: false end diff --git a/erlang/src/core.erl b/erlang/src/core.erl index 154ddb1045..9aa2ba7578 100644 --- a/erlang/src/core.erl +++ b/erlang/src/core.erl @@ -20,6 +20,29 @@ false_p([Arg]) -> false_p(_) -> {error, "false? takes a single argument"}. +number_p([{integer, _}]) -> + true; +number_p([_]) -> + false; +number_p(_) -> + {error, "number? takes a single argument"}. + +fn_p([{function, _, _}]) -> + true; +fn_p([{closure, _, _, _, _, _}]) -> + true; +fn_p([_]) -> + false; +fn_p(_) -> + {error, "fn? takes a single argument"}. + +macro_p([{macro, _, _, _}]) -> + true; +macro_p([_]) -> + false; +macro_p(_) -> + {error, "macro? takes a single argument"}. + count([{Type, List, _Meta}]) when Type == list orelse Type == vector -> {integer, length(List)}; count([nil]) -> @@ -324,6 +347,7 @@ ns() -> "empty?" => fun empty_q/1, "false?" => fun false_p/1, "first" => fun first/1, + "fn?" => fun fn_p/1, "get" => fun types:map_get/1, "hash-map" => fun types:hash_map/1, "keys" => fun types:map_keys/1, @@ -331,11 +355,13 @@ ns() -> "keyword?" => fun types:keyword_p/1, "list" => fun types:list/1, "list?" => fun types:list_p/1, + "macro?" => fun macro_p/1, "map" => fun map_f/1, "map?" => fun types:map_p/1, "meta" => fun types:meta/1, "nil?" => fun nil_p/1, "nth" => fun nth/1, + "number?" => fun number_p/1, "pr-str" => fun pr_str/1, "println" => fun println/1, "prn" => fun prn/1, diff --git a/julia/core.jl b/julia/core.jl index 93057bcc47..680d25fd7c 100644 --- a/julia/core.jl +++ b/julia/core.jl @@ -79,6 +79,9 @@ ns = Dict{Any,Any}( symbol("symbol?") => (a) -> typeof(a) === Symbol, symbol("keyword") => (a) -> a[1] == '\u029e' ? a : "\u029e$(a)", symbol("keyword?") => keyword_Q, + symbol("number?") => (a) -> isa(a, AbstractFloat) || isa(a, Int64), + symbol("fn?") => (a) -> isa(a, Function) || (isa(a, types.MalFunc) && !a.ismacro), + symbol("macro?") => (a) -> isa(a, types.MalFunc) && a.ismacro, symbol("pr-str") => (a...) -> join(map((e)->pr_str(e, true),a)," "), :str => (a...) -> join(map((e)->pr_str(e, false),a),""), diff --git a/kotlin/src/mal/core.kt b/kotlin/src/mal/core.kt index addacd8d06..bc312c8b98 100644 --- a/kotlin/src/mal/core.kt +++ b/kotlin/src/mal/core.kt @@ -117,6 +117,10 @@ val ns = hashMapOf( if (param is MalKeyword) param else MalKeyword((a.nth(0) as MalString).value) }), envPair("keyword?", { a: ISeq -> if (a.nth(0) is MalKeyword) TRUE else FALSE }), + envPair("number?", { a: ISeq -> if (a.nth(0) is MalInteger) TRUE else FALSE }), + envPair("fn?", { a: ISeq -> if ((a.nth(0) as? MalFunction)?.is_macro ?: true) FALSE else TRUE }), + envPair("macro?", { a: ISeq -> if ((a.nth(0) as? MalFunction)?.is_macro ?: false) TRUE else FALSE }), + envPair("vector", { a: ISeq -> MalVector(a) }), envPair("vector?", { a: ISeq -> if (a.nth(0) is MalVector) TRUE else FALSE }), From 72311fee8a37838382dbee26f57be29fed5269f1 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 26 Oct 2017 23:36:44 +0100 Subject: [PATCH 0251/1998] Added map_get, and Environment type set/get Environments implemented as a list of maps, with each pointing to its outer environment. core_environment function (in core.asm) creates an Environment, and adds the core +,-,*,/ functions. --- nasm/core.asm | 93 ++++++++++++++++++ nasm/printer.asm | 16 +++- nasm/step2_eval.asm | 13 ++- nasm/types.asm | 225 +++++++++++++++++++++++++++++++++++++++----- 4 files changed, 318 insertions(+), 29 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 13b9436387..404ef93e33 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -2,8 +2,101 @@ ;; ;; +section .data + +core_add_symbol: db "+" +.len: equ $ - core_add_symbol + +core_sub_symbol: db "-" +.len: equ $ - core_sub_symbol + +core_mul_symbol: db "*" +.len: equ $ - core_mul_symbol + +core_div_symbol: db "/" +.len: equ $ - core_div_symbol + section .text +;; Create an Environment with core functions +;; +;; Returns Environment in RAX +;; +;; +core_environment: + ; Create the top-level environment + call env_new ; in RAX + push rax + + ; ----------------- + ; add + mov rsi, core_add_symbol + mov edx, core_add_symbol.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, core_add + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set + + ; ----------------- + ; sub + push rsi ; environment + mov rsi, core_sub_symbol + mov edx, core_sub_symbol.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, core_sub + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set + + + ; ----------------- + ; mul + push rsi ; environment + mov rsi, core_mul_symbol + mov edx, core_mul_symbol.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, core_mul + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set + + ; ----------------- + ; div + push rsi ; environment + mov rsi, core_div_symbol + mov edx, core_div_symbol.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, core_div + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set + + ; ----------------- + ; Put the environment in RAX + mov rax, rsi + ret + ;; Adds a list of numbers, address in RSI ;; Returns the sum as a number object with address in RAX ;; Since most of the code is common to all operators, diff --git a/nasm/printer.asm b/nasm/printer.asm index 839284322c..e7348eff25 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -5,10 +5,13 @@ section .data unknown_type_string: db "#" .len: equ $ - unknown_type_string - + unknown_value_string: db "#" .len: equ $ - unknown_value_string +function_type_string: db "#" +.len: equ $ - function_type_string + nil_value_string: db "nil" .len: equ $ - nil_value_string @@ -112,6 +115,9 @@ pr_str: cmp ch, container_map je .map + + cmp ch, container_function + je .function ; Unknown mov rsi, unknown_type_string @@ -354,4 +360,10 @@ pr_str: mov rax, rsi ret - + + ; -------------------------------- +.function: + mov rsi, function_type_string + mov edx, function_type_string.len + call raw_to_string ; Puts a String in RAX + ret diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 1bd9524d76..6e8f72353f 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -70,7 +70,15 @@ rep_seq: _start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov rsi, rax + call pr_str + mov rsi, rax ; Put into input of print_string + call print_string + ; ----------------------------- ; Main loop @@ -93,12 +101,9 @@ _start: call read_str push rax - ; Compare objects - mov rsi, rax - call core_equal_p ; Put into pr_str - mov rsi, rax + mov rsi, rax call pr_str push rax diff --git a/nasm/types.asm b/nasm/types.asm index 641beb1e4e..1a2536978e 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -145,7 +145,7 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 10 ; Number of cons objects which can be created +%define heap_cons_limit 20 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list @@ -403,8 +403,18 @@ raw_to_string: dec ecx jnz .copy_loop ret - - + +;; Convert a raw string to a symbol +;; +;; Input: Address of raw string in RSI, length in EDX +;; Output: Address of string in RAX +;; +;; Modifies registers: R8,R9,RCX +raw_to_symbol: + call raw_to_string + ; set the content type + mov [rax], BYTE (block_array + container_symbol + content_char) + ret ;; Appends a character to a string ;; Input: Address of string in RSI, character in CL @@ -983,24 +993,24 @@ map_find: mov rsi, [rsi + Cons.cdr] - ; increment reference count - mov ax, WORD [rsi + Cons.refcount] - inc ax - mov [rsi + Cons.refcount], WORD ax + ; ; increment reference count + ; mov ax, WORD [rsi + Cons.refcount] + ; inc ax + ; mov [rsi + Cons.refcount], WORD ax ; Put address in rax mov rax, rsi ret .not_found: lahf ; flags in AH - and ah, 255-64 ; remove zero flag + and ah, 255-64 ; clear zero flag sahf ; last cons in rsi ; increment reference count - mov ax, WORD [rsi + Cons.refcount] - inc ax - mov [rsi + Cons.refcount], WORD ax + ; mov ax, WORD [rsi + Cons.refcount] + ; inc ax + ; mov [rsi + Cons.refcount], WORD ax ; Put address in rax mov rax, rsi @@ -1009,7 +1019,7 @@ map_find: .error: lahf ; flags in AH - or ah, 255-64 ; set zero flag + and ah, 255-64 ; clear zero flag sahf ; return nil @@ -1022,9 +1032,9 @@ map_find: ;; ;; Sets a key-value pair in a map ;; -;; Inputs: RSI - map [modified] -;; RDI - key [modified] -;; RCX - value +;; Inputs: RSI - map [not modified] +;; RDI - key [not modified] +;; RCX - value [not modified] ;; map_set: ; Save inputs in less volatile registers @@ -1038,10 +1048,10 @@ map_set: ; Key not in map. RAX should be address of the last ; value in the map, or empty - mov rbx, r8 + mov bl, BYTE [rax] cmp bl, maltype_empty_map je .set_key - + ; Append key push rax call alloc_cons ; New Cons in rax @@ -1055,7 +1065,7 @@ map_set: .found_key: ; Key already in map, so replace value ; address in RAX - + ; check type of value already there mov bl, BYTE [rax] and bl, content_mask @@ -1078,7 +1088,7 @@ map_set: mov bh, bl and bh, block_mask jnz .set_key_pointer ; Array, so point to it - + ; Here a Cons object mov bh, bl and bh, container_mask @@ -1097,7 +1107,7 @@ map_set: .set_key_pointer: ; The key is a pointer - + mov [rax + Cons.car], r9 mov [rax], BYTE (block_cons + container_map + content_pointer) ; Increment reference count @@ -1120,7 +1130,7 @@ map_set: ; -------------------------------- .set_value: ; Set the value into the Cons at [rax] - + ; Check the type of object mov bl, BYTE [r10] mov bh, bl @@ -1153,9 +1163,178 @@ map_set: ; fall through to .finished .finished: - ; Put the map into rax - mov rax, r8 + ; Restore inputs + mov rsi, r8 + mov rdi, r9 + mov rcx, r10 + ret + +;; Get a value from a map, incrementing the reference count +;; of the object returned +;; +;; Inputs: RSI - map +;; RDI - key +;; +;; Returns: If found, Zero Flag is set and address in RAX +;; If not found, Zero Flag cleared +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; R8 +;; R9 +map_get: + ; Save inputs + mov r8, rsi ; map + mov r9, rdi ; key + + call map_find ; Cons object in RAX + je .found_key + + ; Not found + + mov rsi, r8 + mov rdi, r9 + + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + + ret + ; --------------- +.found_key: + ; Check if the object in RAX is a value or pointer + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + je .got_pointer + + ; A value, so copy + + push rax + push rbx + call alloc_cons ; cons in rax + pop rbx ; content type in bl + pop rcx ; Object to copy + + add bl, block_cons + container_value + mov [rax], BYTE bl ; set type + mov [rax + Cons.typecdr], BYTE content_nil + + ; Copy value + mov rbx, [rcx + Cons.car] + mov [rax + Cons.car], rbx + + jmp .finished_found + +.got_pointer: + ; A pointer, so get the address + mov rax, [rax + Cons.car] + + ; increment reference count + mov bx, WORD [rax + Cons.refcount] + inc bx + mov [rax + Cons.refcount], bx + + ; Fall through to .finished_found +.finished_found: + mov rsi, r8 + mov rdi, r9 + + ret + +;; ------------------------------------------------------------ +;; Environment type +;; +;; These are lists of maps. The head of the list is the +;; current environment, and CDR points to the outer environment +;; +;; ( {} {} ... ) + +;; Return a new Environment type in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +env_new: + call map_new ; map in RAX + push rax + call alloc_cons ; Cons in RAX + pop rbx ; map in RBX + + mov [rax], BYTE (block_cons + container_list + content_pointer) + ; CDR type already set to nil in alloc_cons + mov [rax + Cons.car], rbx + + ret + +;; Environment set +;; +;; Sets a key-value pair in an environment +;; +;; Inputs: RSI - env [not modified] +;; RDI - key [not modified] +;; RCX - value [not modified] +;; +env_set: + push rsi + ; Get the first CAR, which should be a map + mov rsi, [rsi + Cons.car] + call map_set + pop rsi ret +;; Environment get +;; +;; Get a value from an environment, incrementing the reference count +;; of the object returned +;; +;; Inputs: RSI - environment +;; RDI - key +;; +;; Returns: If found, Zero Flag is set and address in RAX +;; If not found, Zero Flag cleared +env_get: + push rsi + ; Get the map in CAR + mov rsi, [rsi + Cons.car] + call map_get + je .found + + ; Not found, so try outer + pop rsi + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .not_found + mov rsi, [rsi + Cons.cdr] ; outer + jmp env_get +.found: + pop rsi + ret + +.not_found: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +;; ------------------------------------------------------------ +;; Function type +;; +;; Functions are consist of a list +;; - First car is the function address to call +;; +;; ( addr ) +;; +;; + +;; Address of native function in RSI +;; returns Function object in RAX +native_function: + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov [rax + Cons.car], rsi + ret From 7ff3d6f005883a85886da49a8e4931d4bcd66dda Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 28 Oct 2017 16:20:25 +0100 Subject: [PATCH 0252/1998] Adding eval_ast and eval functions Currently evaluates lists and values, looking up symbols in the repl_env map. e.g (+ 1 (* 3 2)) -> (# 1 (# 3 2)) --- nasm/core.asm | 26 ++++++- nasm/step2_eval.asm | 171 +++++++++++++++++++++++++++++++++++--------- nasm/types.asm | 10 ++- 3 files changed, 172 insertions(+), 35 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 404ef93e33..95b7ddc5dc 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -15,6 +15,10 @@ core_mul_symbol: db "*" core_div_symbol: db "/" .len: equ $ - core_div_symbol + +core_equal_symbol: db "=" +.len: equ $ - core_equal_symbol + section .text @@ -87,6 +91,22 @@ core_environment: mov rsi, core_div call native_function ; Function in RAX + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set + + ; ----------------- + ; equal (=) + push rsi ; environment + mov rsi, core_equal_symbol + mov edx, core_equal_symbol.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, core_equal_p + call native_function ; Function in RAX + mov rcx, rax ; value (function) pop rdi ; key (symbol) pop rsi ; environment @@ -96,7 +116,11 @@ core_environment: ; Put the environment in RAX mov rax, rsi ret - + +;; ---------------------------------------------------- + +;; Integer arithmetic operations +;; ;; Adds a list of numbers, address in RSI ;; Returns the sum as a number object with address in RAX ;; Since most of the code is common to all operators, diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 6e8f72353f..b7247210c6 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -13,33 +13,13 @@ global _start %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String -section .data - -test_string1: db 10, "test1", 10 -.len: equ $ - test_string1 - -test_string2: db 10, "test2", 10 -.len: equ $ - test_string2 +section .bss -;str: ISTRUC Array -;AT Array.type, db maltype_string -;AT Array.length, dd 6 -;AT Array.data, db 'hello',10 -;IEND - -test_cons: ISTRUC Cons -AT Cons.typecar, db ( maltype_integer + 2 ) -AT Cons.typecdr, db 0 -AT Cons.car, dq 123 -IEND - -test_cons2: ISTRUC Cons -AT Cons.typecar, db ( maltype_integer + 2 ) -AT Cons.typecdr, db content_pointer -AT Cons.car, dq 456 -AT Cons.cdr, dq test_cons -IEND +;; Top-level (REPL) environment +repl_env:resq 1 +section .data + ;; ------------------------------------------ ;; Fixed strings for printing @@ -48,9 +28,126 @@ prompt_string: db 10,"user> " ; The string to print at the prompt section .text -;; Evaluates a form +;; Evaluates a form in RSI +eval_ast: + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + ; Not a list + cmp ah, container_symbol + je .symbol + + ; Not a symbol or a list + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; look in environment + mov rdi, rsi ; symbol is the key + mov rsi, [repl_env] ; Environment + call env_get + je .done ; result in RAX + + ; Not found, should raise an error + + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + mov rsi, [rsi + Cons.car] ; Get the address + call eval_ast ; Evaluate it, result in rax + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, container_mask + cmp bh, container_value + je .list_append + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + ; Fall through to .list_append + +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list +.done: + ret + +;; Evaluates a form in RSI eval: - mov rax, rsi ; Return the input + call eval_ast ret ;; Prints the result @@ -73,6 +170,8 @@ _start: ; Create and print the core environment call core_environment ; Environment in RAX + mov [repl_env], rax ; store in memory + mov rsi, rax call pr_str @@ -94,18 +193,22 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the string - + push rax ; Save address of the input string + ; Put into read_str mov rsi, rax call read_str - push rax + push rax ; Save AST + ; Eval + mov rsi, rax + call eval + push rax ; Save result ; Put into pr_str mov rsi, rax call pr_str - push rax + push rax ; Save output string mov rsi, rax ; Put into input of print_string call print_string @@ -113,12 +216,16 @@ _start: ; Release string from pr_str pop rsi call release_array + + ; Release result of eval + pop rsi + call release_object ; Release the object from read_str pop rsi call release_object ; Could be Cons or Array - ; Release the string + ; Release the input string pop rsi call release_array diff --git a/nasm/types.asm b/nasm/types.asm index 1a2536978e..f2a22cf6c1 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -145,12 +145,12 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 20 ; Number of cons objects which can be created +%define heap_cons_limit 50 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 10 ; Number of array objects which can be created +%define heap_array_limit 20 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 @@ -1204,6 +1204,7 @@ map_get: ret ; --------------- .found_key: + ; Check if the object in RAX is a value or pointer mov bl, BYTE [rax] and bl, content_mask @@ -1242,6 +1243,11 @@ map_get: mov rsi, r8 mov rdi, r9 + mov rbx, rax + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx ret ;; ------------------------------------------------------------ From 6c78c820fa3fa60c1f008003e54cf3ebe1379306 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 29 Oct 2017 15:27:20 +0000 Subject: [PATCH 0253/1998] Step 2: All non-deferrable tests pass Simple arithmetic operations with nested lists work. Map almost working: (keys {a 1 b 2}) -> (a b) but evaluating currently results in segfault so disabled. --- nasm/core.asm | 30 +++++++++- nasm/step2_eval.asm | 135 +++++++++++++++++++++++++++++++++++++++++--- nasm/types.asm | 86 +++++++++++++++++++++++++++- 3 files changed, 240 insertions(+), 11 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 95b7ddc5dc..2bb99c2c1b 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -18,7 +18,9 @@ core_div_symbol: db "/" core_equal_symbol: db "=" .len: equ $ - core_equal_symbol - + +core_keys_symbol: db "keys" +.len: equ $ - core_keys_symbol section .text @@ -107,6 +109,22 @@ core_environment: mov rsi, core_equal_p call native_function ; Function in RAX + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set + + ; ----------------- + ; keys + push rsi ; environment + mov rsi, core_keys_symbol + mov edx, core_keys_symbol.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, core_keys + call native_function ; Function in RAX + mov rcx, rax ; value (function) pop rdi ; key (symbol) pop rsi ; environment @@ -181,7 +199,7 @@ core_arithmetic: imul rax, [rsi + Cons.car] jmp .add_loop .do_division: - xor rdx, rdx ; Zero high bits + cqo ; Sign extend RAX into RDX mov rcx, [rsi + Cons.car] idiv rcx jmp .add_loop @@ -234,3 +252,11 @@ core_equal_p: mov [rax], BYTE maltype_nil mov [rax + Cons.typecdr], BYTE content_nil ret + +;; Given a map, returns a list of keys +;; Input: List in RSI with one Map element +;; Returns: List in RAX +core_keys: + mov rsi, [rsi + Cons.car] + call map_keys + ret diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index b7247210c6..8084eaa8a3 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -38,12 +38,15 @@ eval_ast: and ah, container_mask cmp ah, container_list je .list - - ; Not a list + + ;cmp ah, container_map + ;je .map + + ; Not a list or a map cmp ah, container_symbol je .symbol - - ; Not a symbol or a list + + ; Not a symbol, list or map call incref_object ; Increment reference count mov rax, rsi @@ -95,7 +98,7 @@ eval_ast: push r8 push r9 mov rsi, [rsi + Cons.car] ; Get the address - call eval_ast ; Evaluate it, result in rax + call eval ; Evaluate it, result in rax pop r9 pop r8 pop rsi @@ -103,10 +106,10 @@ eval_ast: ; Check the type it's evaluated to mov bl, BYTE [rax] mov bh, bl - and bh, container_mask - cmp bh, container_value + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) je .list_append - + ; Not a value, so need a pointer to it push rax call alloc_cons @@ -142,12 +145,128 @@ eval_ast: .list_done: mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + mov r10, rsi ; input in R10 + call map_keys + mov r11, rax ; Get list of keys in R11 + mov r13, rax ; Head of list in R13 + + call map_new + mov r12, rax ; new map in R12 + +.map_loop: + + ; Check the type of the key + mov al, BYTE [r13] + and al, content_mask + cmp al, content_pointer + je .map_key_pointer + + mov [r13], BYTE al ; Remove list container + + ; Get next value + mov rsi, r10 + mov rdi, r13 + call map_get ; Result in RAX + + ; Evaluate + + + mov rsi, r12 + mov rdi, r13 + mov rcx, rax + call map_set + + ; put back list container + mov al, BYTE [r13] + or al, container_list + mov [r13], BYTE al + + jmp .map_next + +.map_key_pointer: + mov rsi, r10 + mov rdi, [r13 + Cons.car] + call map_get ; Result in RAX + + ; Evaluate + + mov rsi, r12 + mov rdi, [r13 + Cons.car] + mov rcx, rax + call map_set + +.map_next: + + mov al, BYTE [r13 + Cons.typecdr] + cmp al, content_pointer + jne .map_done + + mov r13, [r13 + Cons.cdr] ; next key + jmp .map_loop + +.map_done: + ; Release list of keys + mov rsi, r11 + call release_cons + + mov rax, r12 + ret + ; --------------------- .done: ret ;; Evaluates a form in RSI eval: + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + ret +.list: + ; A list call eval_ast + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Call the function with the rest of the list in RSI + push rax + mov rsi, [rax + Cons.cdr] ; Rest of list + mov rdi, rbx ; Function object in RDI + call [rbx + Cons.car] ; Call function + ; Result in rax + pop rsi ; eval'ed list + push rax + call release_cons + pop rax + ret + +.list_not_function: + ; Not a function. Probably an error + ret + +.empty_list: + mov rax, rsi ret ;; Prints the result diff --git a/nasm/types.asm b/nasm/types.asm index f2a22cf6c1..0741d55615 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -118,6 +118,7 @@ ENDSTRUC %define maltype_nil (block_cons + container_value + content_nil) %define maltype_empty_list (block_cons + container_list + content_empty) %define maltype_empty_map (block_cons + container_map + content_empty) +%define maltype_function (block_cons + container_function + content_function) ;; ------------------------------------------ @@ -1092,8 +1093,9 @@ map_set: ; Here a Cons object mov bh, bl and bh, container_mask - cmp bl, container_value + cmp bh, container_value jne .set_key_pointer ; Not a simple value, so point to it + ; A value, so copy mov rcx, [r9 + Cons.car] mov [rax + Cons.car], rcx @@ -1249,6 +1251,88 @@ map_get: sahf mov rax, rbx ret + +;; Get a list of keys +;; +;; Input: Map in RSI +;; +;; Returns: List in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; R8 +;; R9 +map_keys: + ; check type + mov al, BYTE [rsi] + cmp al, maltype_empty_map + je .empty_map + + and al, container_mask + cmp al, container_map + jne .empty_map ; error + + xor r8, r8 ; Return list + + ; Take the current value +.loop: + ; Create a new Cons for this key + call alloc_cons + mov cl, BYTE [rsi] + and cl, content_mask + add cl, block_cons + container_list + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + and cl, content_mask + cmp cl, content_pointer + jne .append + + ; A pointer, so increment reference count + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.append: + cmp r8, 0 + je .first + + ; appending + mov [r9 + Cons.typecdr], BYTE content_pointer + mov [r9 + Cons.cdr], rax + mov r9, rax + jmp .next +.first: + ; First key, so put into r8 + mov r8, rax + mov r9, rax +.next: + ; First get the value + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done ; error. Should be a value + mov rsi, [rsi + Cons.cdr] + + ; Get the next key + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + mov rsi, [rsi + Cons.cdr] + jmp .loop +.done: + ; Finished, return the list + mov rax, r8 + ret + +.empty_map: + ; return empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + ;; ------------------------------------------------------------ ;; Environment type From e731205ac4ab41191479d90b206643910629d879 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 30 Oct 2017 22:52:34 +0000 Subject: [PATCH 0254/1998] Step 2: Map evaluation works Using different method, now relying on implementation detail of Map. Works for simple tests, and test suite cases. Vector not yet implemented,but all other step 2 tests pass --- nasm/step2_eval.asm | 154 +++++++++++++++++++++++++++++++------------- 1 file changed, 109 insertions(+), 45 deletions(-) diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 8084eaa8a3..166e075bf3 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -39,8 +39,8 @@ eval_ast: cmp ah, container_list je .list - ;cmp ah, container_map - ;je .map + cmp ah, container_map + je .map ; Not a list or a map cmp ah, container_symbol @@ -150,72 +150,136 @@ eval_ast: ; --------------------- .map: ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + mov r10, rsi ; input in R10 - call map_keys - mov r11, rax ; Get list of keys in R11 - mov r13, rax ; Head of list in R13 + xor r12, r12 ; New map in r12 - call map_new - mov r12, rax ; new map in R12 + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list .map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx ; Check the type of the key - mov al, BYTE [r13] - and al, content_mask + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] cmp al, content_pointer - je .map_key_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] - mov [r13], BYTE al ; Remove list container - - ; Get next value - mov rsi, r10 - mov rdi, r13 - call map_get ; Result in RAX + ; Now got value in r10 - ; Evaluate - - - mov rsi, r12 - mov rdi, r13 - mov rcx, rax - call map_set + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer - ; put back list container - mov al, BYTE [r13] - or al, container_list - mov [r13], BYTE al + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + mov rsi, [r10 + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r13 + pop r12 + pop r10 - jmp .map_next + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) -.map_key_pointer: - mov rsi, r10 - mov rdi, [r13 + Cons.car] - call map_get ; Result in RAX + jne .map_eval_pointer - ; Evaluate + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value - mov rsi, r12 - mov rdi, [r13 + Cons.car] - mov rcx, rax - call map_set +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx -.map_next: +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax - mov al, BYTE [r13 + Cons.typecdr] + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] cmp al, content_pointer - jne .map_done - - mov r13, [r13 + Cons.cdr] ; next key + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map jmp .map_loop .map_done: - ; Release list of keys - mov rsi, r11 - call release_cons + mov rax, r12 + ret +.map_error_missing_value: mov rax, r12 ret + ; --------------------- .done: ret From 72893cd1e4f482fe8b26d7263c38904629773b9b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 30 Oct 2017 23:45:55 +0000 Subject: [PATCH 0255/1998] Stage 3 : def! working Environment still hard-wired to be REPL env. Added special variable *env* which returns the environment object for printing. Helps debugging of environments. --- nasm/Makefile | 4 + nasm/env.asm | 108 +++++++++ nasm/step2_eval.asm | 1 + nasm/step3_env.asm | 548 ++++++++++++++++++++++++++++++++++++++++++++ nasm/types.asm | 77 ------- 5 files changed, 661 insertions(+), 77 deletions(-) create mode 100644 nasm/env.asm create mode 100644 nasm/step3_env.asm diff --git a/nasm/Makefile b/nasm/Makefile index 9dfc396bac..3eddf75ad6 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -11,3 +11,7 @@ step1_read_print: step1_read_print.asm $(COMPONENTS) step2_eval: step2_eval.asm $(COMPONENTS) nasm -felf64 step2_eval.asm ld -o $@ step2_eval.o + +step3_env: step3_env.asm $(COMPONENTS) + nasm -felf64 step3_env.asm + ld -o $@ step3_env.o diff --git a/nasm/env.asm b/nasm/env.asm new file mode 100644 index 0000000000..f3891c07aa --- /dev/null +++ b/nasm/env.asm @@ -0,0 +1,108 @@ + +;; ------------------------------------------------------------ +;; Environment type +;; +;; These are lists of maps. The head of the list is the +;; current environment, and CDR points to the outer environment +;; +;; ( {} {} ... ) + + +section .data + +env_symbol: ISTRUC Array +AT Array.type, db maltype_symbol +AT Array.length, dd 5 +AT Array.data, db '*env*' +IEND + +section .text + +;; Return a new Environment type in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +env_new: + call map_new ; map in RAX + push rax + call alloc_cons ; Cons in RAX + pop rbx ; map in RBX + + mov [rax], BYTE (block_cons + container_list + content_pointer) + ; CDR type already set to nil in alloc_cons + mov [rax + Cons.car], rbx + + ret + +;; Environment set +;; +;; Sets a key-value pair in an environment +;; +;; Inputs: RSI - env [not modified] +;; RDI - key [not modified] +;; RCX - value [not modified] +;; +env_set: + push rsi + ; Get the first CAR, which should be a map + mov rsi, [rsi + Cons.car] + call map_set + pop rsi + ret + +;; Environment get +;; +;; Get a value from an environment, incrementing the reference count +;; of the object returned +;; +;; Inputs: RSI - environment +;; RDI - key +;; +;; Returns: If found, Zero Flag is set and address in RAX +;; If not found, Zero Flag cleared +env_get: + push rsi + + ; Check special variable *env* + mov rsi, env_symbol + call compare_char_array + pop rsi + cmp rax, 0 + jne .not_env_symbol + + ; Env symbol, so return this environment + call incref_object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rsi + ret + +.not_env_symbol: + + ; Get the map in CAR + mov rsi, [rsi + Cons.car] + call map_get + je .found + + ; Not found, so try outer + pop rsi + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .not_found + + mov rsi, [rsi + Cons.cdr] ; outer + jmp env_get +.found: + pop rsi + ret + +.not_found: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret + + diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 166e075bf3..24364f32d2 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -8,6 +8,7 @@ global _start %include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type %include "system.asm" ; System calls %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm new file mode 100644 index 0000000000..c5d0db12a9 --- /dev/null +++ b/nasm/step3_env.asm @@ -0,0 +1,548 @@ +;; +;; nasm -felf64 step3_env.asm && ld step3_env.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + +prompt_string: db 10,"user> " ; The string to print at the prompt +.len: equ $ - prompt_string + + +def_symbol: ISTRUC Array +AT Array.type, db maltype_symbol +AT Array.length, dd 4 +AT Array.data, db 'def!' +IEND + +let_symbol: ISTRUC Array +AT Array.type, db maltype_symbol +AT Array.length, dd 4 +AT Array.data, db 'let*' +IEND + +section .text + +;; Evaluates a form in RSI +eval_ast: + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + ; Not a list or a map + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list or map + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; look in environment + mov rdi, rsi ; symbol is the key + mov rsi, [repl_env] ; Environment + call env_get + je .done ; result in RAX + + ; Not found, should raise an error + + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + mov rsi, [rsi + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_append + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + ; Fall through to .list_append + +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + mov rsi, [r10 + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; --------------------- +.done: + ret + +;; Evaluates a form in RSI +eval: + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + ret + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + push rsi + + ; Compare against def! + mov rsi, rbx + mov rdi, def_symbol + call compare_char_array + pop rsi + cmp rax, 0 + je .def_symbol + + push rsi + mov rdi, let_symbol + call compare_char_array + pop rsi + cmp rax, 0 + je .let_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + ; call alloc_cons + ; mov [rax], BYTE maltype_nil + ; mov [rax + Cons.typecdr], BYTE content_nil + ; ret + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + push r8 ; the symbol + mov rsi, [rsi + Cons.car] ; Pointer + call eval + mov rsi, rax + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, [repl_env] + call env_set + + mov rax, rcx ; Return the value + ret + +.def_error_missing_arg: + +.def_error_expecting_symbol: + + mov rax, rsi + ret + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + jmp .list_not_function +.list_eval: + + call eval_ast + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Call the function with the rest of the list in RSI + push rax + mov rsi, [rax + Cons.cdr] ; Rest of list + mov rdi, rbx ; Function object in RDI + call [rbx + Cons.car] ; Call function + ; Result in rax + pop rsi ; eval'ed list + push rax + call release_cons + pop rax + ret + +.list_not_function: + ; Not a function. Probably an error + ret + +.empty_list: + mov rax, rsi + ret + +;; Prints the result +print: + mov rax, rsi ; Return the input + ret + +;; Read-Eval-Print in sequence +rep_seq: + call read_str + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call print + mov rsi, rax ; Return value + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + mov rdx, prompt_string.len ; number of bytes + mov rsi, prompt_string ; address of raw string to output + call print_rawstring + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call read_str + push rax ; Save AST + + ; Eval + mov rsi, rax + call eval + push rax ; Save result + + ; Put into pr_str + mov rsi, rax + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + diff --git a/nasm/types.asm b/nasm/types.asm index 0741d55615..7012a0ab86 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -1334,83 +1334,6 @@ map_keys: ret -;; ------------------------------------------------------------ -;; Environment type -;; -;; These are lists of maps. The head of the list is the -;; current environment, and CDR points to the outer environment -;; -;; ( {} {} ... ) - -;; Return a new Environment type in RAX -;; -;; Modifies registers: -;; RAX -;; RBX -env_new: - call map_new ; map in RAX - push rax - call alloc_cons ; Cons in RAX - pop rbx ; map in RBX - - mov [rax], BYTE (block_cons + container_list + content_pointer) - ; CDR type already set to nil in alloc_cons - mov [rax + Cons.car], rbx - - ret - -;; Environment set -;; -;; Sets a key-value pair in an environment -;; -;; Inputs: RSI - env [not modified] -;; RDI - key [not modified] -;; RCX - value [not modified] -;; -env_set: - push rsi - ; Get the first CAR, which should be a map - mov rsi, [rsi + Cons.car] - call map_set - pop rsi - ret - -;; Environment get -;; -;; Get a value from an environment, incrementing the reference count -;; of the object returned -;; -;; Inputs: RSI - environment -;; RDI - key -;; -;; Returns: If found, Zero Flag is set and address in RAX -;; If not found, Zero Flag cleared -env_get: - push rsi - ; Get the map in CAR - mov rsi, [rsi + Cons.car] - call map_get - je .found - - ; Not found, so try outer - pop rsi - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .not_found - - mov rsi, [rsi + Cons.cdr] ; outer - jmp env_get -.found: - pop rsi - ret - -.not_found: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - ret - ;; ------------------------------------------------------------ ;; Function type ;; From dcd798841479fea5e7ddd98cf5ad53cfbd060e38 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 31 Oct 2017 13:41:36 +0100 Subject: [PATCH 0256/1998] elm, objpascal, plpgsql: Add number?, fn?, macro? --- elm/Core.elm | 41 +++++++++++++++++++++++++++++++++++++++++ objpascal/core.pas | 23 +++++++++++++++++++++++ plpgsql/core.sql | 18 ++++++++++++++++++ plpgsql/types.sql | 31 +++++++++++++++++++++++++++++++ 4 files changed, 113 insertions(+) diff --git a/elm/Core.elm b/elm/Core.elm index 1b31ae9e4e..07e6eced43 100644 --- a/elm/Core.elm +++ b/elm/Core.elm @@ -543,6 +543,16 @@ ns = _ -> False + isNumber args = + Eval.succeed <| + MalBool <| + case args of + (MalInt _) :: _ -> + True + + _ -> + False + isSymbol args = Eval.succeed <| MalBool <| @@ -606,6 +616,34 @@ ns = _ -> False + isFn args = + Eval.succeed <| + MalBool <| + case args of + (MalFunction (CoreFunc _)) :: _ -> + True + (MalFunction (UserFunc fn)) :: _ -> + if fn.isMacro then + False + else + True + + _ -> + False + + isMacro args = + Eval.succeed <| + MalBool <| + case args of + (MalFunction (UserFunc fn)) :: _ -> + if fn.isMacro then + True + else + False + + _ -> + False + symbol args = case args of [ MalString str ] -> @@ -892,12 +930,15 @@ ns = |> Env.set "nil?" (makeFn isNil) |> Env.set "true?" (makeFn isTrue) |> Env.set "false?" (makeFn isFalse) + |> Env.set "number?" (makeFn isNumber) |> Env.set "symbol?" (makeFn isSymbol) |> Env.set "keyword?" (makeFn isKeyword) |> Env.set "vector?" (makeFn isVector) |> Env.set "map?" (makeFn isMap) |> Env.set "string?" (makeFn isString) |> Env.set "sequential?" (makeFn isSequential) + |> Env.set "fn?" (makeFn isFn) + |> Env.set "macro?" (makeFn isMacro) |> Env.set "symbol" (makeFn symbol) |> Env.set "keyword" (makeFn keyword) |> Env.set "vector" (makeFn vector) diff --git a/objpascal/core.pas b/objpascal/core.pas index dd5fcb6d5c..1822d887e0 100644 --- a/objpascal/core.pas +++ b/objpascal/core.pas @@ -52,6 +52,10 @@ function false_Q(Args: TMalArray) : TMal; begin false_Q := wrap_tf(Args[0] is TMalFalse); end; +function number_Q(Args: TMalArray) : TMal; +begin + number_Q := wrap_tf(Args[0] is TMalInt); +end; function string_Q(Args: TMalArray) : TMal; begin string_Q := wrap_tf(_string_Q(Args[0])); @@ -82,6 +86,22 @@ function keyword_Q(Args: TMalArray) : TMal; begin keyword_Q := wrap_tf((Args[0] is TMalString) and not _string_Q(Args[0])); end; +function fn_Q(Args: TMalArray) : TMal; +begin + if Args[0] is TMalFunc then + fn_Q := wrap_tf(not (Args[0] as TMalFunc).isMacro) + else + fn_Q := TMalFalse.Create; +end; + +function macro_Q(Args: TMalArray) : TMal; +begin + if Args[0] is TMalFunc then + macro_Q := wrap_tf((Args[0] as TMalFunc).isMacro) + else + macro_Q := TMalFalse.Create; +end; + // String functions @@ -541,11 +561,14 @@ initialization NS['nil?'] := @nil_Q; NS['true?'] := @true_Q; NS['false?'] := @false_Q; + NS['number?'] := @number_Q; NS['string?'] := @string_Q; NS['symbol'] := @symbol; NS['symbol?'] := @symbol_Q; NS['keyword'] := @keyword; NS['keyword?'] := @keyword_Q; + NS['fn?'] := @fn_Q; + NS['macro?'] := @macro_Q; NS['pr-str'] := @do_pr_str; NS['str'] := @str; diff --git a/plpgsql/core.sql b/plpgsql/core.sql index 25614e7524..9e69491305 100644 --- a/plpgsql/core.sql +++ b/plpgsql/core.sql @@ -33,6 +33,11 @@ BEGIN RETURN types._wraptf(types._false_Q(args[1])); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION core.number_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._number_Q(args[1])); +END; $$ LANGUAGE plpgsql; + CREATE FUNCTION core.string_Q(args integer[]) RETURNS integer AS $$ BEGIN RETURN types._wraptf(types._string_Q(args[1])); @@ -62,6 +67,16 @@ BEGIN RETURN types._wraptf(types._keyword_Q(args[1])); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION core.fn_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._fn_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.macro_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._macro_Q(args[1])); +END; $$ LANGUAGE plpgsql; + -- string functions @@ -495,11 +510,14 @@ INSERT INTO envs.env (env_id, outer_id, data) 'nil?', types._function('core.nil_Q'), 'true?', types._function('core.true_Q'), 'false?', types._function('core.false_Q'), + 'number?', types._function('core.number_Q'), 'string?', types._function('core.string_Q'), 'symbol', types._function('core.symbol'), 'symbol?', types._function('core.symbol_Q'), 'keyword', types._function('core.keyword'), 'keyword?', types._function('core.keyword_Q'), + 'fn?', types._function('core.fn_Q'), + 'macro?', types._function('core.macro_Q'), 'pr-str', types._function('core.pr_str'), 'str', types._function('core.str'), diff --git a/plpgsql/types.sql b/plpgsql/types.sql index 62a63cc83b..a6cb67d1e6 100644 --- a/plpgsql/types.sql +++ b/plpgsql/types.sql @@ -207,6 +207,15 @@ BEGIN RETURN false; END; $$ LANGUAGE plpgsql; +-- _number_Q: +-- takes a value_id +-- returns the whether value_id is integer or float type +CREATE FUNCTION types._number_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE (type_id = 3 OR type_id = 4) + AND value_id = id)); +END; $$ LANGUAGE plpgsql; -- _valueToString: -- takes a value_id for a string @@ -304,6 +313,28 @@ BEGIN RETURN result; END; $$ LANGUAGE plpgsql; +-- _fn_Q: +-- takes a value_id +-- returns the whether value_id is a function +CREATE FUNCTION types._fn_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE (type_id = 11 OR type_id = 12) + AND macro IS NULL + AND value_id = id)); +END; $$ LANGUAGE plpgsql; + +-- _macro_Q: +-- takes a value_id +-- returns the whether value_id is a macro +CREATE FUNCTION types._macro_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE type_id = 12 + AND macro IS TRUE + AND value_id = id)); +END; $$ LANGUAGE plpgsql; + -- --------------------------------------------------------- -- sequence functions From ccb1f324518e2312db92b0a73e12c174cb3f2fef Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 31 Oct 2017 23:15:20 +0000 Subject: [PATCH 0257/1998] Small bugfix in Env and error messages * Bug in Env lookup could result in segfault * Added some error message printing. Not really handling errors properly yet. --- nasm/core.asm | 1 + nasm/env.asm | 19 ++++++++++---- nasm/step2_eval.asm | 60 ++++++++++++++++++++++++++++++++++++++++++++- nasm/step3_env.asm | 54 ++++++++++++++++++++++++++++++++++++++-- 4 files changed, 126 insertions(+), 8 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 2bb99c2c1b..b3194b28ba 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -31,6 +31,7 @@ section .text ;; core_environment: ; Create the top-level environment + xor rsi, rsi ; Set outer to nil call env_new ; in RAX push rax diff --git a/nasm/env.asm b/nasm/env.asm index f3891c07aa..9bb6117ba3 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -17,7 +17,11 @@ AT Array.data, db '*env*' IEND section .text - + +;; Create a new Environment +;; +;; Input: outer Environment in RSI. If zero, then nil outer. +;; ;; Return a new Environment type in RAX ;; ;; Modifies registers: @@ -32,7 +36,13 @@ env_new: mov [rax], BYTE (block_cons + container_list + content_pointer) ; CDR type already set to nil in alloc_cons mov [rax + Cons.car], rbx - + + cmp rsi, 0 + jne .set_outer + ret ; No outer, just return +.set_outer: + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi ret ;; Environment set @@ -80,14 +90,14 @@ env_get: ret .not_env_symbol: - + push rsi ; Get the map in CAR mov rsi, [rsi + Cons.car] call map_get + pop rsi je .found ; Not found, so try outer - pop rsi mov al, BYTE [rsi + Cons.typecdr] cmp al, content_pointer @@ -96,7 +106,6 @@ env_get: mov rsi, [rsi + Cons.cdr] ; outer jmp env_get .found: - pop rsi ret .not_found: diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 24364f32d2..639169dc16 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -26,7 +26,20 @@ section .data prompt_string: db 10,"user> " ; The string to print at the prompt .len: equ $ - prompt_string - + + +def_symbol: ISTRUC Array +AT Array.type, db maltype_symbol +AT Array.length, dd 4 +AT Array.data, db 'def!' +IEND + +let_symbol: ISTRUC Array +AT Array.type, db maltype_symbol +AT Array.length, dd 4 +AT Array.data, db 'let*' +IEND + section .text ;; Evaluates a form in RSI @@ -299,8 +312,53 @@ eval: ; Not a list. Evaluate and return call eval_ast ret + + ; -------------------- .list: ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + and bl, content_mask + cmp bl, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + push rsi + + ; Compare against def! + mov rsi, rbx + mov rdi, def_symbol + call compare_char_array + pop rsi + cmp rax, 0 + je .def_symbol + + push rsi + mov rdi, let_symbol + call compare_char_array + pop rsi + cmp rax, 0 + je .let_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + jmp .list_not_function +.let_symbol: + ; Create a new environment + + jmp .list_not_function +.list_eval: + call eval_ast ; Check that the first element of the return is a function diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index c5d0db12a9..b3ac569995 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -27,7 +27,18 @@ section .data prompt_string: db 10,"user> " ; The string to print at the prompt .len: equ $ - prompt_string +error_string: db 27,'[31m',"Error",27,'[0m',": " +.len: equ $ - error_string +not_found_string: db " not found.",10 +.len: equ $ - not_found_string + +def_missing_arg_string: db "missing argument to def!",10 +.len: equ $ - def_missing_arg_string + +def_expecting_symbol_string: db "expecting symbol as first argument to def!",10 +.len: equ $ - def_expecting_symbol_string + def_symbol: ISTRUC Array AT Array.type, db maltype_symbol AT Array.length, dd 4 @@ -68,12 +79,27 @@ eval_ast: .symbol: ; look in environment + push rsi mov rdi, rsi ; symbol is the key mov rsi, [repl_env] ; Environment call env_get + pop rsi je .done ; result in RAX ; Not found, should raise an error + push rsi + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + pop rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + mov rsi, not_found_string + mov rdx, not_found_string.len + call print_rawstring ; print ' not found' ; Return nil call alloc_cons @@ -422,10 +448,34 @@ eval: ret .def_error_missing_arg: + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + call print_rawstring -.def_error_expecting_symbol: + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret - mov rax, rsi + +.def_error_expecting_symbol: + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + call print_rawstring + + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil ret ; ----------------------------- From 3e072a0f047478f7f9a6c0c21ab51d3c3f1de5ba Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 1 Nov 2017 00:27:48 +0000 Subject: [PATCH 0258/1998] let* form bindings nearly working Defines a new environment, which is passed to Eval. Simple forms seem to work, printing environment to test: (let* (a 1 b (* a 2))) -> ({a 1 b 2} {+ # - # * # / # = # keys #}) but nested lists have a problem: user> (let* (a 1 b (* a (+ a 1)))) -> Error: * not found. ({a 1 b nil} #) though standalone nested loops seem ok: user> (+ 1 (* 2 3)) -> 7 --- nasm/env.asm | 4 ++ nasm/step3_env.asm | 176 ++++++++++++++++++++++++++++++++++++++++----- nasm/types.asm | 6 +- 3 files changed, 169 insertions(+), 17 deletions(-) diff --git a/nasm/env.asm b/nasm/env.asm index 9bb6117ba3..a4e73e8d7f 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -53,6 +53,10 @@ env_new: ;; RDI - key [not modified] ;; RCX - value [not modified] ;; +;; Modifies registers: +;; R8 +;; R9 +;; R10 env_set: push rsi ; Get the first CAR, which should be a map diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index b3ac569995..146c092d2e 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -52,9 +52,16 @@ AT Array.data, db 'let*' IEND section .text - -;; Evaluates a form in RSI + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; eval_ast: + mov r15, rdi ; Save Env in r15 + ; Check the type mov al, BYTE [rsi] @@ -80,8 +87,9 @@ eval_ast: .symbol: ; look in environment push rsi - mov rdi, rsi ; symbol is the key - mov rsi, [repl_env] ; Environment + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi call env_get pop rsi je .done ; result in RAX @@ -137,8 +145,11 @@ eval_ast: push rsi push r8 push r9 + push r15 ; Env mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 call eval ; Evaluate it, result in rax + pop r15 pop r9 pop r8 pop rsi @@ -271,8 +282,11 @@ eval_ast: push r10 ; Input push r12 ; start of result push r13 ; Current head of result + push r15 ; Env mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 call eval ; Evaluate it, result in rax + pop r15 pop r13 pop r12 pop r10 @@ -324,8 +338,17 @@ eval_ast: .done: ret -;; Evaluates a form in RSI +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI Form to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; eval: + mov r15, rdi ; Env + ; Check type mov al, BYTE [rsi] cmp al, maltype_empty_list @@ -356,18 +379,23 @@ eval: ; Is a symbol, address in RBX push rsi - + push rbx + ; Compare against def! mov rsi, rbx mov rdi, def_symbol call compare_char_array + pop rbx pop rsi cmp rax, 0 je .def_symbol push rsi + push rbx + mov rsi, rbx mov rdi, let_symbol call compare_char_array + pop rbx pop rsi cmp rax, 0 je .let_symbol @@ -377,12 +405,7 @@ eval: .def_symbol: ; Define a new symbol in current environment - - ; call alloc_cons - ; mov [rax], BYTE maltype_nil - ; mov [rax + Cons.typecdr], BYTE content_nil - ; ret - + ; Next item should be a symbol mov al, BYTE [rsi + Cons.typecdr] cmp al, content_pointer @@ -432,16 +455,19 @@ eval: .def_pointer: ; A pointer, so evaluate push r8 ; the symbol + push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 call eval mov rsi, rax + pop r15 pop r8 .def_got_value: ; Symbol in R8, value in RSI mov rdi, r8 ; key (symbol) mov rcx, rsi ; Value - mov rsi, [repl_env] + mov rsi, r15 ; Environment call env_set mov rax, rcx ; Return the value @@ -481,10 +507,127 @@ eval: ; ----------------------------- .let_symbol: ; Create a new environment + + mov r11, rsi - jmp .list_not_function -.list_eval: + mov rsi, r15 ; Outer env + call env_new + mov r14, rax ; New environment in r14 + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, block_cons + container_list + jne .let_error_bindings_list + + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + +.let_bind_loop: + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + + mov rax, r14 + ret + +.let_error_missing_bindings: +.let_error_bindings_list: ; expected a list, got something else +.let_error_bind_symbol: ; expected a symbol, got something else +.let_error_bind_value: ; Missing value in binding list + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.list_eval: + + mov rdi, r15 ; Environment call eval_ast ; Check that the first element of the return is a function @@ -563,7 +706,8 @@ _start: push rax ; Save AST ; Eval - mov rsi, rax + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment call eval push rax ; Save result diff --git a/nasm/types.asm b/nasm/types.asm index 7012a0ab86..bcd8ef2639 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -151,7 +151,7 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 20 ; Number of array objects which can be created +%define heap_array_limit 50 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 @@ -1037,6 +1037,10 @@ map_find: ;; RDI - key [not modified] ;; RCX - value [not modified] ;; +;; Modifies registers: +;; R8 +;; R9 +;; R10 map_set: ; Save inputs in less volatile registers mov r8, rsi ; map From 968faaad7c8fce1d7df1b9dc0567a5ed702f2206 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 1 Nov 2017 14:07:51 +0000 Subject: [PATCH 0259/1998] ada: Add number?, fn?, macro? --- ada/core.adb | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/ada/core.adb b/ada/core.adb index 68f45830f8..3f9e590ca1 100644 --- a/ada/core.adb +++ b/ada/core.adb @@ -587,6 +587,39 @@ package body Core is end Is_Keyword; + function Is_Number (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Int); + end Is_Number; + + + function Is_Fn (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + Res : Boolean; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + case Deref (First_Param).Sym_Type is + when Func => + Res := True; + when Lambda => + Res := not Deref_Lambda (First_Param).Get_Is_Macro; + when others => + Res := False; + end case; + return New_Bool_Mal_Type (Res); + end Is_Fn; + + + function Is_Macro (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Lambda and then Deref_Lambda (First_Param).Get_Is_Macro); + end Is_Macro; + + function New_List (Rest_Handle : Mal_Handle) return Types.Mal_Handle is Rest_List : Types.List_Mal_Type; @@ -1126,6 +1159,18 @@ package body Core is "keyword?", New_Func_Mal_Type ("keyword?", Is_Keyword'access)); + Envs.Set (Repl_Env, + "number?", + New_Func_Mal_Type ("number?", Is_Number'access)); + + Envs.Set (Repl_Env, + "fn?", + New_Func_Mal_Type ("fn?", Is_Fn'access)); + + Envs.Set (Repl_Env, + "macro?", + New_Func_Mal_Type ("macro?", Is_Macro'access)); + Envs.Set (Repl_Env, "pr-str", New_Func_Mal_Type ("pr-str", Pr_Str'access)); From aecec6d786034db9ad5395458ab4d5ec78d03b25 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 1 Nov 2017 17:37:47 +0000 Subject: [PATCH 0260/1998] Fix bug in let Nested lists in binding now work: (let* (a 1 b (* a (+ a 1)))) --- nasm/step3_env.asm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index 146c092d2e..f15f566af2 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -628,8 +628,10 @@ eval: .list_eval: mov rdi, r15 ; Environment + push r15 call eval_ast - + pop r15 + ; Check that the first element of the return is a function mov bl, BYTE [rax] and bl, content_mask @@ -643,10 +645,12 @@ eval: ; Call the function with the rest of the list in RSI push rax + push r15 mov rsi, [rax + Cons.cdr] ; Rest of list mov rdi, rbx ; Function object in RDI call [rbx + Cons.car] ; Call function ; Result in rax + pop r15 pop rsi ; eval'ed list push rax call release_cons From 145c38ae005126a9ad361084fc79d85430901426 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 1 Nov 2017 22:36:00 +0000 Subject: [PATCH 0261/1998] def! and let* working Tests pass (mostly...), and reference counting seems to be working; can run the same commands repeatedly without running out of memory. One test failing is (def! w (abc)) which is supposed to fail, but then abort the def!. Fixing this probably means adding error handling. --- nasm/env.asm | 14 ++++++- nasm/step3_env.asm | 91 ++++++++++++++++++++++++++++++++++++++++++++-- nasm/types.asm | 7 +++- 3 files changed, 104 insertions(+), 8 deletions(-) diff --git a/nasm/env.asm b/nasm/env.asm index a4e73e8d7f..0b30739e45 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -20,8 +20,10 @@ section .text ;; Create a new Environment ;; -;; Input: outer Environment in RSI. If zero, then nil outer. -;; +;; Input: outer Environment in RSI. +;; - If zero, then nil outer. +;; - If not zero, increments reference count +;; ;; Return a new Environment type in RAX ;; ;; Modifies registers: @@ -43,6 +45,11 @@ env_new: .set_outer: mov [rax + Cons.typecdr], BYTE content_pointer mov [rax + Cons.cdr], rsi + + ; increment reference counter of outer + mov rbx, rax ; because incref_object modifies rax + call incref_object + mov rax, rbx ret ;; Environment set @@ -53,6 +60,9 @@ env_new: ;; RDI - key [not modified] ;; RCX - value [not modified] ;; +;; Increments reference counts of key and value +;; if pointers to them are created +;; ;; Modifies registers: ;; R8 ;; R9 diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index f15f566af2..4437c94607 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -38,6 +38,22 @@ def_missing_arg_string: db "missing argument to def!",10 def_expecting_symbol_string: db "expecting symbol as first argument to def!",10 .len: equ $ - def_expecting_symbol_string + + +let_missing_bindings_string: db "let* missing bindings",10 +.len: equ $ - let_missing_bindings_string + +let_bindings_list_string: db "let* expected a list of bindings",10 +.len: equ $ - let_bindings_list_string + +let_bind_symbol_string: db "let* expected a symbol in bindings list",10 +.len: equ $ - let_bind_symbol_string + +let_bind_value_string: db "let* missing value in bindings list",10 +.len: equ $ - let_bind_value_string + +let_missing_body_string: db "let* missing body",10 +.len: equ $ - let_missing_body_string def_symbol: ISTRUC Array AT Array.type, db maltype_symbol @@ -508,11 +524,11 @@ eval: .let_symbol: ; Create a new environment - mov r11, rsi + mov r11, rsi ; Let form in R11 - mov rsi, r15 ; Outer env + mov rsi, r15 ; Outer env call env_new - mov r14, rax ; New environment in r14 + mov r14, rax ; New environment in R14 ; Second element should be the bindings @@ -597,6 +613,10 @@ eval: mov rdi, r13 ; key mov rcx, rax ; value call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object ; Check if there are more bindings mov al, BYTE [r12 + Cons.typecdr] @@ -608,15 +628,78 @@ eval: .let_done_binding: ; Done bindings. ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done +.body_pointer: + ; Evaluate using new environment - mov rax, r14 + mov rsi, r11 + mov rdi, r14 ; New environment + push r14 + call eval + pop r14 + +.let_done: + ; Release the environment + mov rsi, r14 + push rax + call release_object + pop rax ret .let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + .let_error_bindings_list: ; expected a list, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + .let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + .let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push rsi + push rdx + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message call alloc_cons mov [rax], BYTE maltype_nil diff --git a/nasm/types.asm b/nasm/types.asm index bcd8ef2639..d7eeb9e88b 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -146,12 +146,12 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 50 ; Number of cons objects which can be created +%define heap_cons_limit 100 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 50 ; Number of array objects which can be created +%define heap_array_limit 40 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 @@ -1037,6 +1037,9 @@ map_find: ;; RDI - key [not modified] ;; RCX - value [not modified] ;; +;; If references are added to key or value, +;; then reference counts are incremented. +;; ;; Modifies registers: ;; R8 ;; R9 From 2c457d9bf2f38fa0836d003d38d028844aa923eb Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 1 Nov 2017 23:58:32 +0000 Subject: [PATCH 0262/1998] Added error handling, step 3 test passing * Added simple error handling, which just provides a way to reset the stack and jump to a handler. At the moment no attempt is made to reclaim memory or tidy up. * Some failing tests due to vectors not yet being supported. --- nasm/step3_env.asm | 207 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 175 insertions(+), 32 deletions(-) diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index 4437c94607..9ad1327d02 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -18,6 +18,9 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 section .data @@ -69,6 +72,133 @@ IEND section .text +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -110,13 +240,14 @@ eval_ast: pop rsi je .done ; result in RAX - ; Not found, should raise an error + ; Not found, throw an error push rsi mov rsi, error_string mov rdx, error_string.len call print_rawstring ; print 'Error: ' pop rsi + push rsi mov edx, [rsi + Array.length] add rsi, Array.data call print_rawstring ; print symbol @@ -124,12 +255,9 @@ eval_ast: mov rsi, not_found_string mov rdx, not_found_string.len call print_rawstring ; print ' not found' - - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret + pop rsi + + jmp error_throw .list: ; Evaluate each element of the list @@ -470,6 +598,10 @@ eval: .def_pointer: ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer @@ -490,36 +622,29 @@ eval: ret .def_error_missing_arg: - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' - mov rsi, def_missing_arg_string mov rdx, def_missing_arg_string.len - call print_rawstring - - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - + jmp .def_handle_error .def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx mov rsi, error_string mov rdx, error_string.len call print_rawstring ; print 'Error: ' - - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - call print_rawstring - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret + pop rdx + pop rsi + call print_rawstring ; print message + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + ; ----------------------------- .let_symbol: ; Create a new environment @@ -691,6 +816,8 @@ eval: jmp .let_handle_error .let_handle_error: + push r11 ; For printing later + push rsi push rdx mov rsi, error_string @@ -701,10 +828,8 @@ eval: pop rsi call print_rawstring ; print message - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret + pop rsi ; let* form + jmp error_throw ; No return ; ----------------------------- @@ -769,6 +894,12 @@ _start: call core_environment ; Environment in RAX mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push ; ----------------------------- ; Main loop @@ -827,3 +958,15 @@ _start: jmp quit +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + From c3c9f34833c66b378313389b1fd23200f40ec0fb Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 1 Nov 2017 20:38:42 -0500 Subject: [PATCH 0263/1998] [swift] add number?, fn?, and macro? --- swift/core.swift | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/swift/core.swift b/swift/core.swift index 7e92b60017..52d662b3e2 100644 --- a/swift/core.swift +++ b/swift/core.swift @@ -61,6 +61,18 @@ private func fn_keywordQ(obj: MalVal) throws -> Bool { return is_keyword(obj) } +private func fn_numberQ(obj: MalVal) throws -> Bool { + return is_integer(obj) || is_float(obj) +} + +private func fn_functionQ(obj: MalVal) throws -> Bool { + return is_function(obj) +} + +private func fn_macroQ(obj: MalVal) throws -> Bool { + return is_macro(obj) +} + private func fn_prstr(args: MalVarArgs) throws -> String { let args_str_array = args.value.map { pr_str($0, true) } return args_str_array.joinWithSeparator(" ") @@ -688,6 +700,9 @@ let ns: [String: MalBuiltin.Signature] = [ "symbol?": { try unwrap_args($0, forFunction: fn_symbolQ) }, "keyword": { try unwrap_args($0, forFunction: fn_keyword) }, "keyword?": { try unwrap_args($0, forFunction: fn_keywordQ) }, + "number?": { try unwrap_args($0, forFunction: fn_numberQ) }, + "fn?": { try unwrap_args($0, forFunction: fn_functionQ) }, + "macro?": { try unwrap_args($0, forFunction: fn_macroQ) }, "pr-str": { try unwrap_args($0, forFunction: fn_prstr) }, "str": { try unwrap_args($0, forFunction: fn_str) }, From aa42fdcea3a41fda1b2b4ae823cac573a5901cb6 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 1 Nov 2017 21:45:28 -0500 Subject: [PATCH 0264/1998] [plsql] add number?, fn? and macro? --- plsql/core.sql | 6 ++++++ plsql/entrypoint.sh | 11 +++++++++-- plsql/types.sql | 35 +++++++++++++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 2 deletions(-) diff --git a/plsql/core.sql b/plsql/core.sql index ceaaaf32c5..1d4ad1f689 100644 --- a/plsql/core.sql +++ b/plsql/core.sql @@ -480,6 +480,9 @@ BEGIN WHEN fname = 'symbol?' THEN RETURN types.tf(M(a(1)).type_id = 7); WHEN fname = 'keyword' THEN RETURN keyword(M, a(1)); WHEN fname = 'keyword?' THEN RETURN types.tf(types.keyword_Q(M, a(1))); + WHEN fname = 'number?' THEN RETURN types.tf(types.number_Q(M, a(1))); + WHEN fname = 'fn?' THEN RETURN types.tf(types.function_Q(M, a(1))); + WHEN fname = 'macro?' THEN RETURN types.tf(types.macro_Q(M, a(1))); WHEN fname = 'pr-str' THEN RETURN pr_str(M, H, a); WHEN fname = 'str' THEN RETURN str(M, H, a); @@ -549,6 +552,9 @@ BEGIN 'symbol?', 'keyword', 'keyword?', + 'number?', + 'fn?', + 'macro?', 'pr-str', 'str', diff --git a/plsql/entrypoint.sh b/plsql/entrypoint.sh index ff4dd8d69b..549e7ce80c 100755 --- a/plsql/entrypoint.sh +++ b/plsql/entrypoint.sh @@ -1,7 +1,14 @@ #!/bin/bash -echo "Starting Oracle XE" -sudo /usr/sbin/startup.sh +case ${1} in +make*) + echo "Skipping Oracle XE startup" + ;; +*) + echo "Starting Oracle XE" + sudo /usr/sbin/startup.sh + ;; +esac if [ "${*}" ]; then exec "${@}" diff --git a/plsql/types.sql b/plsql/types.sql index a6fdc8ec9e..fb142c79c4 100644 --- a/plsql/types.sql +++ b/plsql/types.sql @@ -114,6 +114,9 @@ CREATE OR REPLACE PACKAGE types IS FUNCTION symbol(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; FUNCTION keyword(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; FUNCTION keyword_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION number_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION function_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION macro_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; -- sequence functions FUNCTION seq(M IN OUT NOCOPY mal_table, @@ -384,6 +387,38 @@ BEGIN END IF; END; +FUNCTION number_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id IN (3,4) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; +END; + +FUNCTION function_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id = 11 THEN + RETURN TRUE; + ELSIF M(val).type_id = 12 THEN + RETURN TREAT(M(val) AS mal_func_T).is_macro = 0; + ELSE + RETURN FALSE; + END IF; +END; + +FUNCTION macro_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id = 12 THEN + RETURN TREAT(M(val) AS mal_func_T).is_macro > 0; + ELSE + RETURN FALSE; + END IF; +END; + -- --------------------------------------------------------- -- sequence functions From 393d1140a3000dd9d7bff185e2439c642e1ad73b Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 1 Nov 2017 21:56:29 -0500 Subject: [PATCH 0265/1998] tests: move number?, fn? and macro? to optional --- tests/stepA_mal.mal | 50 +++++++++++++++++++++------------------------ 1 file changed, 23 insertions(+), 27 deletions(-) diff --git a/tests/stepA_mal.mal b/tests/stepA_mal.mal index 7ba1c30372..1d3601f098 100644 --- a/tests/stepA_mal.mal +++ b/tests/stepA_mal.mal @@ -97,9 +97,30 @@ ;=>(1 2 3) ;; ------------------------------------------------------------------ -;; TODO move these to optional functionality after adding them to all -;; implementations + +;>>> soft=True +;>>> optional=True +;; +;; ------- Optional Functionality -------------- +;; ------- (Not needed for self-hosting) ------- + ;; +;; Testing string? function +(string? "") +;=>true +(string? 'abc) +;=>false +(string? "abc") +;=>true +(string? :abc) +;=>false +(string? (keyword "abc")) +;=>false +(string? 234) +;=>false +(string? nil) +;=>false + ;; Testing number? function (number? 123) ;=>true @@ -138,31 +159,6 @@ (macro? :+) ;=>false -;; ------------------------------------------------------------------ - -;>>> soft=True -;>>> optional=True -;; -;; ------- Optional Functionality -------------- -;; ------- (Not needed for self-hosting) ------- - -;; -;; Testing string? function -(string? "") -;=>true -(string? 'abc) -;=>false -(string? "abc") -;=>true -(string? :abc) -;=>false -(string? (keyword "abc")) -;=>false -(string? 234) -;=>false -(string? nil) -;=>false - ;; ;; Testing conj function From f4a8accef878020a68beb1c69ac4e3af8708cb11 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sat, 14 Oct 2017 11:23:26 +0000 Subject: [PATCH 0266/1998] vhdl: Fix time-ms: Return milliseconds since last midnight UTC to fit in 32-bit integer We used to return milliseconds since 2000 but that number is too large to fit in a signed 32-bit integer. Instead we now return the number of milliseconds since last midnight UTC, which is between 0 and 86399999 (still fits in a 32-bit signed integer). --- vhdl/core.vhdl | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/vhdl/core.vhdl b/vhdl/core.vhdl index 00b18e0f1c..d228e246a8 100644 --- a/vhdl/core.vhdl +++ b/vhdl/core.vhdl @@ -226,17 +226,16 @@ package body core is assert false severity failure; end function gettimeofday; - -- Returns the number of milliseconds since 2000-01-01 00:00:00 UTC because - -- a standard VHDL integer is 32-bit and therefore cannot hold the number of + -- Returns the number of milliseconds since last midnight UTC because a + -- standard VHDL integer is 32-bit and therefore cannot hold the number of -- milliseconds since 1970-01-01. procedure fn_time_ms(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is variable tv: c_timeval; variable dummy: c_timezone; variable rc: integer; - constant utc_2000_01_01: c_seconds64 := 946684800 c_sec; -- UNIX time at 2000-01-01 00:00:00 UTC begin rc := gettimeofday(tv, dummy); - new_number(((tv.tv_sec - utc_2000_01_01) / 1 c_sec) * 1000 + (tv.tv_usec / 1000 c_usec), result); + new_number(((tv.tv_sec / 1 c_sec) mod 86400) * 1000 + (tv.tv_usec / 1000 c_usec), result); end procedure fn_time_ms; procedure fn_list(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is @@ -610,12 +609,6 @@ package body core is end procedure define_core_function; procedure define_core_functions(e: inout env_ptr) is - variable is_eof: boolean; - variable input_line, result, err: line; - variable sym: mal_val_ptr; - variable fn: mal_val_ptr; - variable outer: env_ptr; - variable repl_env: env_ptr; begin define_core_function(e, "="); define_core_function(e, "throw"); From 1d99c373a165cbb1284fa991528d4ac22683e69d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 2 Nov 2017 23:06:09 +0000 Subject: [PATCH 0267/1998] Using macros to shorten source code * Definition of symbols with repetition of the name in .len replaced by a macro "static" in macros.mac * core_environment now uses a macro to add native functions, since this involved a lot of code repetition. --- nasm/core.asm | 140 +++++++++++------------------------------------ nasm/macros.mac | 17 ++++++ nasm/printer.asm | 17 +++--- nasm/types.asm | 26 ++++++--- 4 files changed, 72 insertions(+), 128 deletions(-) create mode 100644 nasm/macros.mac diff --git a/nasm/core.asm b/nasm/core.asm index b3194b28ba..71fd00f8ab 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -2,134 +2,56 @@ ;; ;; -section .data - -core_add_symbol: db "+" -.len: equ $ - core_add_symbol - -core_sub_symbol: db "-" -.len: equ $ - core_sub_symbol +%include "macros.mac" -core_mul_symbol: db "*" -.len: equ $ - core_mul_symbol - -core_div_symbol: db "/" -.len: equ $ - core_div_symbol - -core_equal_symbol: db "=" -.len: equ $ - core_equal_symbol +section .data -core_keys_symbol: db "keys" -.len: equ $ - core_keys_symbol + static core_add_symbol, db "+" + static core_sub_symbol, db "-" + static core_mul_symbol, db "*" + static core_div_symbol, db "/" + static core_equal_symbol, db "=" + static core_keys_symbol, db "keys" section .text -;; Create an Environment with core functions -;; -;; Returns Environment in RAX -;; -;; -core_environment: - ; Create the top-level environment - xor rsi, rsi ; Set outer to nil - call env_new ; in RAX - push rax - - ; ----------------- - ; add - mov rsi, core_add_symbol - mov edx, core_add_symbol.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, core_add - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set - - ; ----------------- - ; sub +;; Add a native function to the core environment +;; This is used in core_environment +%macro core_env_native 2 push rsi ; environment - mov rsi, core_sub_symbol - mov edx, core_sub_symbol.len + mov rsi, %1 + mov edx, %1.len call raw_to_symbol ; Symbol in RAX push rax - mov rsi, core_sub + mov rsi, %2 call native_function ; Function in RAX mov rcx, rax ; value (function) pop rdi ; key (symbol) pop rsi ; environment call env_set +%endmacro - - ; ----------------- - ; mul - push rsi ; environment - mov rsi, core_mul_symbol - mov edx, core_mul_symbol.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, core_mul - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set +;; Create an Environment with core functions +;; +;; Returns Environment in RAX +;; +;; +core_environment: + ; Create the top-level environment + xor rsi, rsi ; Set outer to nil + call env_new + mov rsi, rax ; Environment in RSI - ; ----------------- - ; div - push rsi ; environment - mov rsi, core_div_symbol - mov edx, core_div_symbol.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, core_div - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set + core_env_native core_add_symbol, core_add + core_env_native core_sub_symbol, core_sub + core_env_native core_mul_symbol, core_mul + core_env_native core_div_symbol, core_div - ; ----------------- - ; equal (=) - push rsi ; environment - mov rsi, core_equal_symbol - mov edx, core_equal_symbol.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, core_equal_p - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set + core_env_native core_equal_symbol, core_equal_p - ; ----------------- - ; keys - push rsi ; environment - mov rsi, core_keys_symbol - mov edx, core_keys_symbol.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, core_keys - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set + core_env_native core_keys_symbol, core_keys ; ----------------- ; Put the environment in RAX diff --git a/nasm/macros.mac b/nasm/macros.mac new file mode 100644 index 0000000000..2e2d0aeaba --- /dev/null +++ b/nasm/macros.mac @@ -0,0 +1,17 @@ +;; Some useful macros + +%ifndef MACROS_MAC +%define MACROS_MAC + +;; Define a static data value +;; +;; static label value +;; +%macro static 2+ + %1: %2 + %1.len: equ $ - %1 +%endmacro + + +%endif + diff --git a/nasm/printer.asm b/nasm/printer.asm index e7348eff25..647a4d8406 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -2,18 +2,15 @@ ;;; ;;; +%include "macros.mac" + section .data -unknown_type_string: db "#" -.len: equ $ - unknown_type_string - -unknown_value_string: db "#" -.len: equ $ - unknown_value_string -function_type_string: db "#" -.len: equ $ - function_type_string - -nil_value_string: db "nil" -.len: equ $ - nil_value_string + ; Constant strings for printing + static unknown_type_string, db "#" + static unknown_value_string, db "#" + static function_type_string, db "#" + static nil_value_string, db "nil" section .text diff --git a/nasm/types.asm b/nasm/types.asm index d7eeb9e88b..bf777b99bc 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -23,22 +23,25 @@ ;; 1 1 - Array memory block ;; ;; Container type [3 bits]: -;; 0 0 - Value (single boxed value for Cons blocks, vector for Array blocks). +;; 0 0 - Value (single boxed value for Cons blocks, multiple values for Array blocks). ;; 2 1 - List (value followed by pointer). Only for Cons blocks ;; 4 2 - Symbol (special char array). Only for Array blocks -;; 6 3 - Keyword +;; 6 3 - Keyword. Only for Array blocks ;; 8 4 - Map ;; 10 5 - Function +;; 12 6 - Macro +;; 14 7 - Vector ;; ;; Content type [4 bits]: ;; 0 0 - Nil -;; 16 1 - Bool +;; 16 1 - True ;; 32 2 - Char ;; 48 3 - Int ;; 64 4 - Float ;; 80 5 - Pointer (memory address) ;; 96 6 - Function (instruction address) ;; 112 7 - Empty (distinct from Nil) +;; 208 8 - False ;; ;; ;; These represent MAL data types as follows: @@ -48,12 +51,12 @@ ;; integer Cons Value Int ;; symbol Array Symbol Char ;; list Cons List Any +;; vector Cons Vector Any ;; nil Cons Value Nil -;; true Cons Value Bool (1) -;; false Cons Value Bool (0) +;; true Cons Value True +;; false Cons Value False ;; string Array Value Char ;; keyword Array Keyword Char -;; vector Array Value Int/Float ;; hash-map Cons Map Alternate key, values ;; atom Cons Value Pointer ;; @@ -100,16 +103,19 @@ ENDSTRUC %define container_keyword 6 %define container_map 8 %define container_function 10 - +%define container_macro 12 +%define container_vector 14 + ;; Content type %define content_nil 0 -%define content_bool 16 +%define content_true 16 %define content_char 32 %define content_int 48 %define content_float 64 %define content_pointer 80 ; Memory pointer (to Cons or Array) %define content_function 96 ; Function pointer %define content_empty 112 +%define content_false 208 ;; Common combinations for MAL types %define maltype_integer (block_cons + container_value + content_int) @@ -119,7 +125,9 @@ ENDSTRUC %define maltype_empty_list (block_cons + container_list + content_empty) %define maltype_empty_map (block_cons + container_map + content_empty) %define maltype_function (block_cons + container_function + content_function) - +%define maltype_macro (block_cons + container_macro + content_function) +%define maltype_true (block_cons + container_value + content_true) +%define maltype_false (block_cons + container_value + content_false) ;; ------------------------------------------ section .data From 1e0fdbaa3216fc7681f64191775fb9e133997c30 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 3 Nov 2017 00:17:11 +0000 Subject: [PATCH 0268/1998] Adding support for vectors All step2 tests pass --- nasm/printer.asm | 97 +++++++++++++++++++++++++++++- nasm/reader.asm | 142 ++++++++++++++++++++++++++++++++++++++------ nasm/step2_eval.asm | 92 +++++++++++++++++++++++++++- nasm/step3_env.asm | 98 +++++++++++++++++++++++++++++- nasm/types.asm | 17 +++--- 5 files changed, 411 insertions(+), 35 deletions(-) diff --git a/nasm/printer.asm b/nasm/printer.asm index 647a4d8406..2fd2e61de9 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -97,7 +97,7 @@ pr_str: ; ---------------------------- .not_string: - ; Now test the container type (value, list) + ; Now test the container type (value, list, map, vector) mov ch, cl @@ -113,6 +113,9 @@ pr_str: cmp ch, container_map je .map + cmp ch, container_vector + je .vector + cmp ch, container_function je .function @@ -358,6 +361,98 @@ pr_str: mov rax, rsi ret + ; -------------------------------- +.vector: + + mov r12, rsi ; Input vector + + call string_new ; String in rax + mov r13, rax ; Output string in r13 + + ; Put '[' onto string + mov rsi, rax + mov cl, '[' + call string_append_char + + ; loop through vector +.vector_loop: + + ; Extract values and print + + mov rsi, r12 + mov cl, BYTE [rsi] ; Get type + + ; Check if it's a pointer (address) + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + je .vector_loop_pointer + + cmp ch, content_empty + je .vector_check_end + + ; A value (nil, int etc. or function) + xor cl, container_vector ; Remove vector type -> value + mov BYTE [rsi], cl + + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + + mov cl, BYTE [r12] + or cl, container_vector ; Restore vector type + mov BYTE [r12], cl + jmp .vector_loop_got_str +.vector_loop_pointer: + mov rsi, [rsi + Cons.car] ; Address of object + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + +.vector_loop_got_str: + ; concatenate strings in rax and rsi + mov rsi, r13 ; Output string + mov rdx, rax ; String to be copied + + push rsi ; Save output string + push rax ; save temporary string + call string_append_string + + ; Release the string + pop rsi ; Was in rax, temporary string + call release_array + + pop rsi ; restore output string +.vector_check_end: + ; Check if this is the end of the vector + mov cl, BYTE [r12 + Cons.typecdr] + cmp cl, content_nil + je .vector_finished + + ; More left in the vector + + ; Add space between values + mov cl, ' ' + mov rsi, r13 + call string_append_char + + ; Get next Cons + mov r12, [r12 + Cons.cdr] + jmp .vector_loop + +.vector_finished: + ; put ']' at the end of the string + mov cl, ']' + mov rsi, r13 + call string_append_char + + mov rax, rsi + ret + ; -------------------------------- .function: mov rsi, function_type_string diff --git a/nasm/reader.asm b/nasm/reader.asm index 6058784043..99cb97d8b0 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -1,29 +1,20 @@ +%include "macros.mac" + section .data ;; Reader macro strings - -quote_symbol_string: db "quote" -.len: equ $ - quote_symbol_string - -quasiquote_symbol_string: db "quasiquote" -.len: equ $ - quasiquote_symbol_string -unquote_symbol_string: db "unquote" -.len: equ $ - unquote_symbol_string - -splice_unquote_symbol_string: db "splice-unquote" -.len: equ $ - splice_unquote_symbol_string - -deref_symbol_string: db "deref" -.len: equ $ - deref_symbol_string + static quote_symbol_string, db "quote" + static quasiquote_symbol_string, db "quasiquote" + static unquote_symbol_string, db "unquote" + static splice_unquote_symbol_string, db "splice-unquote" + static deref_symbol_string, db "deref" + ;; Error message strings -error_string_unexpected_end: db "Error: Unexpected end of input. Could be a missing )", 10 -.len: equ $ - error_string_unexpected_end - -error_string_bracket_not_brace: db "Error: Expecting '}' but got ')'" -.len: equ $ - error_string_bracket_not_brace +static error_string_unexpected_end, db "Error: Unexpected end of input. Could be a missing )", 10 +static error_string_bracket_not_brace, db "Error: Expecting '}' but got ')'" section .text @@ -98,6 +89,12 @@ read_str: cmp cl, '}' ; cl tested in map reader je .return_nil + + cmp cl, '[' + je .vector_start + + cmp cl, ']' ; cl tested in vector reader + je .return_nil cmp cl, 39 ; quote ' je .handle_quote @@ -327,6 +324,113 @@ read_str: ret + ; -------------------------------- + +.vector_start: + + ; Get the first value + ; Note that we call rather than jmp because the first + ; value needs to be treated differently. There's nothing + ; to append to yet... + call .read_loop + + ; rax now contains the first object + cmp cl, ']' ; Check if it was end of vector + jne .vector_has_contents + mov cl, 0 ; so ']' doesn't propagate to nested vectors + ; Set vector to empty + mov [rax], BYTE maltype_empty_vector + ret ; Returns 'nil' given "()" +.vector_has_contents: + ; If this is a Cons then use it + ; If not, then need to allocate a Cons + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .vector_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new vector + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_vector + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.vector_is_value: + ; Cons in RAX + ; Make sure it's marked as a vector + mov cl, BYTE [rax] + or cl, container_vector + mov [rax], BYTE cl + + mov r12, rax ; Start of current vector + mov r13, rax ; Set current vector + cmp r15, 0 ; Test if first vector + jne .vector_read_loop + mov r15, rax ; Save the first, for unwinding + +.vector_read_loop: + ; Repeatedly get the next value in the vector + ; (which may be other vectors) + ; until we get a ']' token + + push r12 + push r13 + call .read_loop ; object in rax + pop r13 + pop r12 + + cmp cl, ']' ; Check if it was end of vector + je .vector_done ; Have nil object in rax + + ; Test if this is a Cons value + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .vector_loop_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new vector + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_vector + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.vector_loop_is_value: + ; Cons in RAX + + ; Make sure it's marked as a vector + mov cl, BYTE [rax] + or cl, container_vector + mov [rax], BYTE cl + + ; Append to r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax ; Set current vector + + jmp .vector_read_loop + +.vector_done: + ; Release nil object in rax + mov rsi, rax + call release_cons + + ; Terminate the vector + mov [r13 + Cons.typecdr], BYTE content_nil + mov QWORD [r13 + Cons.cdr], QWORD 0 + mov rax, r12 ; Start of current vector + + ret + ; -------------------------------- .handle_quote: ; Turn 'a into (quote a) diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 639169dc16..98025a0208 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -56,11 +56,14 @@ eval_ast: cmp ah, container_map je .map - ; Not a list or a map + cmp ah, container_vector + je .vector + + ; Not a list, map or vector cmp ah, container_symbol je .symbol - ; Not a symbol, list or map + ; Not a symbol, list, map or vector call incref_object ; Increment reference count mov rax, rsi @@ -294,6 +297,91 @@ eval_ast: mov rax, r12 ret + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + mov rsi, [rsi + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_append_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_append_value: + or bl, container_vector + mov [rax], BYTE bl + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + ; --------------------- .done: ret diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index 9ad1327d02..f740748138 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -220,11 +220,14 @@ eval_ast: cmp ah, container_map je .map - ; Not a list or a map + cmp ah, container_vector + je .vector + + ; Not a list, map or vector cmp ah, container_symbol je .symbol - ; Not a symbol, list or map + ; Not a symbol, list, map or vector call incref_object ; Increment reference count mov rax, rsi @@ -258,7 +261,8 @@ eval_ast: pop rsi jmp error_throw - + + ; ------------------------------ .list: ; Evaluate each element of the list ; @@ -478,6 +482,94 @@ eval_ast: mov rax, r12 ret + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_append_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_append_value: + or bl, container_vector + mov [rax], BYTE bl + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + ; --------------------- .done: ret diff --git a/nasm/types.asm b/nasm/types.asm index bf777b99bc..785019a8fd 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -60,6 +60,8 @@ ;; hash-map Cons Map Alternate key, values ;; atom Cons Value Pointer ;; + +%include "macros.mac" ;; Cons type. ;; Used to store either a single value with type information @@ -124,6 +126,7 @@ ENDSTRUC %define maltype_nil (block_cons + container_value + content_nil) %define maltype_empty_list (block_cons + container_list + content_empty) %define maltype_empty_map (block_cons + container_map + content_empty) +%define maltype_empty_vector (block_cons + container_vector + content_empty) %define maltype_function (block_cons + container_function + content_function) %define maltype_macro (block_cons + container_macro + content_function) %define maltype_true (block_cons + container_value + content_true) @@ -134,15 +137,9 @@ section .data ;; Fixed strings for printing - -error_msg_print_string: db "Error in print string",10 -.len: equ $ - error_msg_print_string - -error_array_memory_limit: db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 -.len: equ $ - error_array_memory_limit - -error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 -.len: equ $ - error_cons_memory_limit + static error_msg_print_string, db "Error in print string",10 + static error_array_memory_limit, db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 + static error_cons_memory_limit, db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 ;; ------------------------------------------ ;; Memory management @@ -159,7 +156,7 @@ error_cons_memory_limit: db "Error: Run out of memory for Cons objects. Increase heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 40 ; Number of array objects which can be created +%define heap_array_limit 50 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 From c301f1c4ca93e1a4b59b3c7298617655a633731d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 3 Nov 2017 07:28:55 +0000 Subject: [PATCH 0269/1998] Adding read/print of nil, true and false Previously these were read as symbols, not their own type. Now the reader recognises these as special and converts them to the correct internal type. --- nasm/macros.mac | 17 ++++++++++++ nasm/printer.asm | 22 ++++++++++++++- nasm/reader.asm | 68 +++++++++++++++++++++++++++++++++++++++++++--- nasm/step3_env.asm | 45 ++++++++++-------------------- 4 files changed, 116 insertions(+), 36 deletions(-) diff --git a/nasm/macros.mac b/nasm/macros.mac index 2e2d0aeaba..0122116a32 100644 --- a/nasm/macros.mac +++ b/nasm/macros.mac @@ -12,6 +12,23 @@ %1.len: equ $ - %1 %endmacro +;; Define a symbol which can be compared against +;; +;; static_symbol name, string +;; +;; Example: +;; +;; static_symbol def_symbol, 'def!' +;; +%macro static_symbol 2 + %strlen slen %2 ; length of string + + %1: ISTRUC Array + AT Array.type, db maltype_symbol + AT Array.length, dd slen + AT Array.data, db %2 + IEND +%endmacro %endif diff --git a/nasm/printer.asm b/nasm/printer.asm index 2fd2e61de9..cdcdea7542 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -11,6 +11,8 @@ section .data static unknown_value_string, db "#" static function_type_string, db "#" static nil_value_string, db "nil" + static true_value_string, db "true" + static false_value_string, db "false" section .text @@ -131,9 +133,15 @@ pr_str: and ch, content_mask jz .value_nil - cmp ch, 48 + cmp ch, content_int je .value_int + cmp ch, content_true + je .value_true + + cmp ch, content_false + je .value_false + mov rsi, unknown_value_string mov edx, unknown_value_string.len call raw_to_string ; Puts a String in RAX @@ -145,6 +153,18 @@ pr_str: mov edx, nil_value_string.len call raw_to_string ret + +.value_true: + mov rsi, true_value_string + mov edx, true_value_string.len + call raw_to_string + ret + +.value_false: + mov rsi, false_value_string + mov edx, false_value_string.len + call raw_to_string + ret ; -------------------------------- .value_int: diff --git a/nasm/reader.asm b/nasm/reader.asm index 99cb97d8b0..d4273f4c90 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -13,8 +13,14 @@ section .data ;; Error message strings -static error_string_unexpected_end, db "Error: Unexpected end of input. Could be a missing )", 10 -static error_string_bracket_not_brace, db "Error: Expecting '}' but got ')'" + static error_string_unexpected_end, db "Error: Unexpected end of input. Could be a missing )", 10 + static error_string_bracket_not_brace, db "Error: Expecting '}' but got ')'" + +;; Symbols for comparison + + static_symbol nil_symbol, 'nil' + static_symbol true_symbol, 'true' + static_symbol false_symbol, 'false' section .text @@ -75,8 +81,8 @@ read_str: je .finished cmp cl, '"' ; A string. Array object in RAX je .finished - cmp cl, 's' - je .finished + cmp cl, 's' ; A symbol + je .symbol cmp cl, '(' je .list_start @@ -535,7 +541,61 @@ read_str: pop r9 pop r8 jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- +.symbol: + ; symbol is in RAX + ; Some symbols are have their own type + ; - nil, true, false + ; + + mov rsi, rax + mov rdi, nil_symbol + push rsi + call compare_char_array + pop rsi + cmp rax, 0 + je .symbol_nil + + mov rdi, true_symbol + push rsi + call compare_char_array + pop rsi + cmp rax, 0 + je .symbol_true + + mov rdi, false_symbol + push rsi + call compare_char_array + pop rsi + cmp rax, 0 + je .symbol_false + + ; not a special symbol, so return + mov rax, rsi + ret + +.symbol_nil: + ; symbol in rsi not needed + call release_array + call alloc_cons + mov [rax], BYTE maltype_nil ; a nil type + ret + +.symbol_true: + call release_array + + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.symbol_false: + call release_array + + call alloc_cons + mov [rax], BYTE maltype_false + ret ; -------------------------------- .finished: diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index f740748138..ebbd2ad7aa 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -27,48 +27,31 @@ section .data ;; ------------------------------------------ ;; Fixed strings for printing -prompt_string: db 10,"user> " ; The string to print at the prompt -.len: equ $ - prompt_string + static prompt_string, db 10,"user> " ; The string to print at the prompt -error_string: db 27,'[31m',"Error",27,'[0m',": " -.len: equ $ - error_string + static error_string, db 27,'[31m',"Error",27,'[0m',": " -not_found_string: db " not found.",10 -.len: equ $ - not_found_string + static not_found_string, db " not found.",10 -def_missing_arg_string: db "missing argument to def!",10 -.len: equ $ - def_missing_arg_string + static def_missing_arg_string, db "missing argument to def!",10 -def_expecting_symbol_string: db "expecting symbol as first argument to def!",10 -.len: equ $ - def_expecting_symbol_string + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + static let_missing_bindings_string, db "let* missing bindings",10 -let_missing_bindings_string: db "let* missing bindings",10 -.len: equ $ - let_missing_bindings_string + static let_bindings_list_string, db "let* expected a list of bindings",10 -let_bindings_list_string: db "let* expected a list of bindings",10 -.len: equ $ - let_bindings_list_string + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 -let_bind_symbol_string: db "let* expected a symbol in bindings list",10 -.len: equ $ - let_bind_symbol_string + static let_bind_value_string, db "let* missing value in bindings list",10 -let_bind_value_string: db "let* missing value in bindings list",10 -.len: equ $ - let_bind_value_string + static let_missing_body_string, db "let* missing body",10 -let_missing_body_string: db "let* missing body",10 -.len: equ $ - let_missing_body_string - -def_symbol: ISTRUC Array -AT Array.type, db maltype_symbol -AT Array.length, dd 4 -AT Array.data, db 'def!' -IEND + +;; Symbols used for comparison -let_symbol: ISTRUC Array -AT Array.type, db maltype_symbol -AT Array.length, dd 4 -AT Array.data, db 'let*' -IEND + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' section .text From ef1d93042808eb06fc85f15a1dab826a53661ee4 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 3 Nov 2017 22:57:19 +0000 Subject: [PATCH 0270/1998] Bug fix in list and vector eval If a value was returned from an expression then it would be modified by being inserted into the list or vector. If this value was the result of a symbol lookup then this would modify the symbol value. let* form now takes either vectors or lists All stage 3 tests now pass --- nasm/step3_env.asm | 71 +++++++++++++++++++++++++++++++++++++--------- nasm/types.asm | 6 ++++ 2 files changed, 63 insertions(+), 14 deletions(-) diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index ebbd2ad7aa..bdc9e017b4 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -39,7 +39,7 @@ section .data static let_missing_bindings_string, db "let* missing bindings",10 - static let_bindings_list_string, db "let* expected a list of bindings",10 + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 @@ -259,7 +259,8 @@ eval_ast: cmp ah, content_pointer je .list_pointer - ; A value, so copy + ; A value in RSI, so copy + call alloc_cons mov bl, BYTE [rsi] and bl, content_mask @@ -290,7 +291,7 @@ eval_ast: mov bh, bl and bh, (block_mask + container_mask) cmp bh, (block_cons + container_value) - je .list_append + je .list_eval_value ; Not a value, so need a pointer to it push rax @@ -298,8 +299,29 @@ eval_ast: mov [rax], BYTE (block_cons + container_list + content_pointer) pop rbx ; Address to point to mov [rax + Cons.car], rbx - ; Fall through to .list_append + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + ; Fall through to .list_append .list_append: ; In RAX @@ -510,7 +532,7 @@ eval_ast: mov bh, bl and bh, (block_mask + container_mask) cmp bh, (block_cons + container_value) - je .vector_append_value + je .vector_eval_value ; Not a value, so need a pointer to it push rax @@ -520,9 +542,25 @@ eval_ast: mov [rax + Cons.car], rbx jmp .vector_append -.vector_append_value: - or bl, container_vector - mov [rax], BYTE bl +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi .vector_append: ; In RAX @@ -745,14 +783,19 @@ eval: mov r12, [r11 + Cons.car] ; should be bindings list mov al, BYTE [r12] and al, (block_mask + container_mask) + ; Can be either a list or vector cmp al, block_cons + container_list - jne .let_error_bindings_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: ; R12 now contains a list with an even number of items ; The first should be a symbol, then a value to evaluate - -.let_bind_loop: - + ; Get the symbol mov al, BYTE [r12] and al, content_mask @@ -851,7 +894,7 @@ eval: .body_pointer: ; Evaluate using new environment - mov rsi, r11 + mov rsi, [r11 + Cons.car] ; Object pointed to mov rdi, r14 ; New environment push r14 call eval @@ -870,7 +913,7 @@ eval: mov rdx, let_missing_bindings_string.len jmp .let_handle_error -.let_error_bindings_list: ; expected a list, got something else +.let_error_bindings_list: ; expected a list or vector, got something else mov rsi, let_bindings_list_string mov rdx, let_bindings_list_string.len jmp .let_handle_error diff --git a/nasm/types.asm b/nasm/types.asm index 785019a8fd..99b7b094af 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -302,6 +302,12 @@ alloc_cons: ;; Decrements the reference count of the cons in RSI ;; If the count reaches zero then push the cons ;; onto the free list +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; release_cons: mov ax, WORD [rsi + Cons.refcount] dec ax From a721b04c240fb11a677f34d6f1bd43998f167b64 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 3 Nov 2017 23:36:52 +0000 Subject: [PATCH 0271/1998] do form working Calls eval rather than eval_ast, since this allows things like multiple def! forms inside a do form. --- nasm/step4_if_fn_do.asm | 1193 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 1193 insertions(+) create mode 100644 nasm/step4_if_fn_do.asm diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm new file mode 100644 index 0000000000..14d5807e86 --- /dev/null +++ b/nasm/step4_if_fn_do.asm @@ -0,0 +1,1193 @@ +;; +;; nasm -felf64 step4_if_fn_do.asm && ld step4_if_fn_do.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found.",10 + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + mov rsi, not_found_string + mov rdx, not_found_string.len + call print_rawstring ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + cmp rax, 0 +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI Form to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; +eval: + mov r15, rdi ; Env + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + ret + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + call eval + mov rsi, rax + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx ; Return the value + ret + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new + mov r14, rax ; New environment in R14 + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + mov rdi, r14 ; New environment + push r14 + call eval + pop r14 + +.let_done: + ; Release the environment + mov rsi, r14 + push rax + call release_object + pop rax + ret + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + mov rsi, error_string + mov rdx, error_string.len + call print_rawstring ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body + mov r11, [r11 + Cons.cdr] + +.do_symbol_loop: + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value + + ; A pointer, so evaluate + push r15 + push r11 + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Check if there is another form + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_done ; No more, so finished + + ; Another form. Discard the result of the last eval + mov rsi, rax + call release_object +.do_next: + + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_done: + ret ; Return result in RAX + +.do_body_value: + + ; Got a value in R11. + ; If this is the last form then return, + ; but if not then can ignore + + mov bl, BYTE [r11 + Cons.typecdr] + and bl, block_mask + content_mask + cmp bl, content_pointer + jne .do_body_value_return + + ; Not the last, so ignore + jmp .do_next + +.do_body_value_return: + ; Got a value as last form. Copy and return + + push rax + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.do_no_body: + ; No expressions to evaluate. Return nil + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + + + ; ----------------------------- + +.fn_symbol: + + + ; ----------------------------- + +.list_eval: + + mov rdi, r15 ; Environment + push r15 + call eval_ast + pop r15 + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Call the function with the rest of the list in RSI + push rax + push r15 + mov rsi, [rax + Cons.cdr] ; Rest of list + mov rdi, rbx ; Function object in RDI + call [rbx + Cons.car] ; Call function + ; Result in rax + pop r15 + pop rsi ; eval'ed list + push rax + call release_cons + pop rax + ret + +.list_not_function: + ; Not a function. Probably an error + ret + +.empty_list: + mov rax, rsi + ret + +;; Prints the result +print: + mov rax, rsi ; Return the input + ret + +;; Read-Eval-Print in sequence +rep_seq: + call read_str + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call print + mov rsi, rax ; Return value + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + mov rdx, prompt_string.len ; number of bytes + mov rsi, prompt_string ; address of raw string to output + call print_rawstring + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call read_str + push rax ; Save AST + + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + call eval + push rax ; Save result + + ; Put into pr_str + mov rsi, rax + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + From d76bd06b50ae861477ac006e2bbbd0f416dc4b09 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sat, 4 Nov 2017 12:07:17 +0100 Subject: [PATCH 0272/1998] c: Make use of pkg-config for libffi flags --- c/Makefile | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/c/Makefile b/c/Makefile index 7aa44449b3..98ceee60b7 100644 --- a/c/Makefile +++ b/c/Makefile @@ -27,6 +27,9 @@ OTHER_HDRS = types.h readline.h reader.h printer.h core.h interop.h GLIB_CFLAGS ?= $(shell pkg-config --cflags glib-2.0) GLIB_LDFLAGS ?= $(shell pkg-config --libs glib-2.0) +FFI_CFLAGS ?= $(shell pkg-config libffi --cflags) +FFI_LDFLAGS ?= $(shell pkg-config libffi --libs) + ifeq ($(shell uname -s),Darwin) CFLAGS +=-DOSX=1 @@ -45,8 +48,8 @@ CFLAGS += -DUSE_GC=1 LDFLAGS += -lgc endif -CFLAGS += $(GLIB_CFLAGS) -LDFLAGS += -l$(RL_LIBRARY) $(GLIB_LDFLAGS) -ldl -lffi +CFLAGS += $(GLIB_CFLAGS) $(FFI_CFLAGS) +LDFLAGS += -l$(RL_LIBRARY) $(GLIB_LDFLAGS) $(FFI_LDFLAGS) -ldl ##################### From 77872467f66036dab7b2927a19296d574ae02269 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 4 Nov 2017 23:45:54 +0000 Subject: [PATCH 0273/1998] if and fn* forms working * Added if and fn* handling in eval * New Env constructor env_new_bind which takes a list of binding symbols and expressions * Macro print_str_mac to shorten raw string printing * Functions implemented as a list, storing an address to call, outer environment, bindings and body * apply_fn handles user-defined functions. Calls env_new_bind, evaluates the body of the function, and returns the result Simple tests seem to work: user> (def! f (fn* (a b) (+ a b))) # user> (f 1 2) 3 --- nasm/env.asm | 129 ++++++++++++++++++-- nasm/macros.mac | 8 ++ nasm/step4_if_fn_do.asm | 256 +++++++++++++++++++++++++++++++++++++--- nasm/types.asm | 9 +- 4 files changed, 374 insertions(+), 28 deletions(-) diff --git a/nasm/env.asm b/nasm/env.asm index 0b30739e45..8a87c0fdb4 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -1,4 +1,6 @@ - + +%include "macros.mac" + ;; ------------------------------------------------------------ ;; Environment type ;; @@ -6,16 +8,17 @@ ;; current environment, and CDR points to the outer environment ;; ;; ( {} {} ... ) + +section .data +;; Symbols used for comparison + static_symbol env_symbol, '*env*' -section .data - -env_symbol: ISTRUC Array -AT Array.type, db maltype_symbol -AT Array.length, dd 5 -AT Array.data, db '*env*' -IEND +;; Error message strings + static env_binds_error_string, db "Expecting symbol in binds list",10 + static env_binds_missing_string, db "Missing expression in bind",10 + section .text ;; Create a new Environment @@ -52,6 +55,116 @@ env_new: mov rax, rbx ret +;; Create a new environment using a binding list +;; +;; Input: RSI - Outer environment +;; RDI - Binds, a list of symbols +;; RCX - Exprs, a list of values to bind each symbol to +;; +;; Modifies registers +;; RBX +;; R8 +;; R9 +;; R10 +;; R11 +;; R12 +;; R13 +env_new_bind: + mov r11, rdi ; binds list in R11 + mov r12, rcx ; expr list in R12 + + call env_new + mov r13, rax ; New environment in R13 + +.bind_loop: + ; Check the type in the bind list + mov bl, BYTE [r11] + and bl, content_mask + cmp bl, content_pointer + jne .bind_not_symbol + + mov rdi, [r11 + Cons.car] ; Symbol object? + mov bl, BYTE [rdi] + cmp bl, maltype_symbol + jne .bind_not_symbol + + ; RDI now contains a symbol + ; Check the type in expr + + mov bl, BYTE [r12] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + je .value_pointer + + ; A value. Need to remove the container type + xchg bl,bh + mov [r12], BYTE bl + xchg bl,bh + mov rcx, r12 ; Value + mov rsi, r13 ; Env + push rbx + call env_set + pop rbx + ; Restore original type + mov [r12], BYTE bl + jmp .next + +.value_pointer: + ; A pointer to something, so just pass address to env_set + mov rcx, [r12 + Cons.car] + mov rsi, r13 + call env_set + ; Fall through to next +.next: + ; Check if there is a next + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .done + + ; Got another symbol + mov r11, [r11 + Cons.cdr] ; Next symbol + + ; Check if there's an expression to bind to + mov bl, BYTE [r12 + Cons.typecdr] + cmp bl, content_pointer + jne .bind_missing_expr + + mov r12, [r12 + Cons.cdr] ; Next expression + jmp .bind_loop +.done: + mov rax, r13 ; Env + ret + +.bind_not_symbol: ; Expecting a symbol + push r11 ; Binds list + + ; Release the environment + mov rsi, r13 + call release_object + + print_str_mac error_string ; print 'Error: ' + + print_str_mac env_binds_error_string + + pop rsi ; Throw binds list + jmp error_throw + +.bind_missing_expr: + push r11 ; Binds list + + ; Release the environment + mov rsi, r13 + call release_object + + print_str_mac error_string ; print 'Error: ' + + print_str_mac env_binds_missing_string + + pop rsi ; Throw binds list + jmp error_throw + + ;; Environment set ;; ;; Sets a key-value pair in an environment diff --git a/nasm/macros.mac b/nasm/macros.mac index 0122116a32..5f0d5fda90 100644 --- a/nasm/macros.mac +++ b/nasm/macros.mac @@ -29,6 +29,14 @@ AT Array.data, db %2 IEND %endmacro + +;; Macro for printing raw string +;; +%macro print_str_mac 1 + mov rsi, %1 ; String address + mov rdx, %1.len ; Length of string + call print_rawstring +%endmacro %endif diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index 14d5807e86..d6b1651a1e 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -231,19 +231,15 @@ eval_ast: ; Not found, throw an error push rsi - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' - + print_str_mac error_string ; print 'Error: ' + pop rsi push rsi mov edx, [rsi + Array.length] add rsi, Array.data call print_rawstring ; print symbol - - mov rsi, not_found_string - mov rdx, not_found_string.len - call print_rawstring ; print ' not found' + + print_str_mac not_found_string ; print ' not found' pop rsi jmp error_throw @@ -763,9 +759,7 @@ eval: .def_handle_error: push rsi push rdx - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' + print_str_mac error_string ; print 'Error: ' pop rdx pop rsi @@ -954,9 +948,8 @@ eval: push rsi push rdx - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' + + print_str_mac error_string ; print 'Error: ' pop rdx pop rsi @@ -1045,12 +1038,211 @@ eval: ; ----------------------------- .if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_nil + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval + ret + +.if_no_condition: ; just (if) without a condition + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +.if_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret ; ----------------------------- .fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_got_body ; Body in r11 + mov r11, [r11 + Cons.car] +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + ret + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + ; ----------------------------- @@ -1093,6 +1285,38 @@ eval: .empty_list: mov rax, rsi ret + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + pop rcx ; Exprs + + push rax + call env_new_bind + mov rdi, rax ; New environment in RDI + pop rax ; Function object + + mov rax, [rax + Cons.cdr] + mov rsi, [rax + Cons.car] ; Body + + push rdi ; Environment + call eval + pop rsi + + ; Release the environment + push rax + call release_object + pop rax + + ret ;; Prints the result print: @@ -1127,9 +1351,7 @@ _start: .mainLoop: ; print the prompt - mov rdx, prompt_string.len ; number of bytes - mov rsi, prompt_string ; address of raw string to output - call print_rawstring + print_str_mac prompt_string call read_line diff --git a/nasm/types.asm b/nasm/types.asm index 99b7b094af..0fd89e7cee 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -1160,7 +1160,7 @@ map_set: ; Here a Cons object mov bh, bl and bh, container_mask - cmp bl, container_value + cmp bh, container_value jne .set_value_pointer ; Not a simple value, so point to it ; A value, so copy mov rcx, [r10 + Cons.car] @@ -1357,8 +1357,11 @@ map_keys: ;; ;; Functions are consist of a list ;; - First car is the function address to call -;; -;; ( addr ) +;; - Second is the environment +;; - Third is the binds list +;; - Fourth is the body of the function +;; +;; ( addr env binds body ) ;; ;; From 2a6439a5a654009d4f9ea89b95602a8631393e67 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 5 Nov 2017 22:48:27 +0000 Subject: [PATCH 0274/1998] Adding core functions * Added list, list?, empty?, count * Working on pr-str and prn. Complete, but get a strange segfault when printing lists. Commenting out a "push" makes a difference... * Function call now passes empty list if no arguments are given. --- nasm/core.asm | 258 +++++++++++++++++++++++++++++++++++++++- nasm/printer.asm | 1 + nasm/step4_if_fn_do.asm | 18 ++- 3 files changed, 272 insertions(+), 5 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 71fd00f8ab..7fca59efb5 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -6,13 +6,29 @@ section .data +;; Symbols for comparison static core_add_symbol, db "+" static core_sub_symbol, db "-" static core_mul_symbol, db "*" static core_div_symbol, db "/" + + static core_listp_symbol, db "list?" + static core_emptyp_symbol, db "empty?" + static core_equal_symbol, db "=" - static core_keys_symbol, db "keys" + + static core_count_symbol, db "count" + static core_keys_symbol, db "keys" + + static core_list_symbol, db "list" + + static core_pr_str_symbol, db "pr-str" + static core_prn_symbol, db "prn" +;; Strings + + static core_emptyp_error_string, db "empty? expects a list, vector or map",10 + static core_count_error_string, db "count expects a list or vector",10 section .text ;; Add a native function to the core environment @@ -48,10 +64,18 @@ core_environment: core_env_native core_sub_symbol, core_sub core_env_native core_mul_symbol, core_mul core_env_native core_div_symbol, core_div - + + core_env_native core_listp_symbol, core_listp + core_env_native core_emptyp_symbol, core_emptyp + core_env_native core_count_symbol, core_count + core_env_native core_equal_symbol, core_equal_p - + core_env_native core_keys_symbol, core_keys + core_env_native core_list_symbol, core_list + + core_env_native core_pr_str_symbol, core_pr_str + core_env_native core_prn_symbol, core_prn ; ----------------- ; Put the environment in RAX @@ -176,6 +200,115 @@ core_equal_p: mov [rax + Cons.typecdr], BYTE content_nil ret +;; Test if a given object is a list +;; Input list in RSI +;; Returns true or false in RAX +core_listp: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .false ; Should be a pointer to a list + + mov rax, [rsi + Cons.car] + mov al, BYTE [rax] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + jne .false + + ; Is a list, return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + +;; Test if the given list, vector or map is empty +core_emptyp: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .error ; Expected a container + mov rax, [rsi + Cons.car] + mov al, BYTE [rax] + cmp al, maltype_empty_list + je .true + cmp al, maltype_empty_vector + je .true + cmp al, maltype_empty_map + je .true + + ; false + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret +.error: + push rsi + print_str_mac error_string + print_str_mac core_emptyp_error_string + pop rsi + jmp error_throw + +;; Count the number of elements in given list or vector +core_count: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .error ; Expected a container + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + mov ah, al + and ah, (block_mask + container_mask) + cmp ah, (block_cons + container_list) + je .start_count + cmp ah, (block_cons + container_vector) + je .start_count + + jmp .error ; Not a list or vector + +.start_count: + + xor rbx,rbx + mov ah, al + and ah, content_mask + cmp ah, content_empty + je .done ; Empty list or vector + +.loop: + inc rbx + + ; Check if there's another + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + + mov rsi, [rsi + Cons.cdr] + jmp .loop + +.done: ; Count is in RBX + + push rbx + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.error: + push rsi + print_str_mac error_string + print_str_mac core_count_error_string + pop rsi + jmp error_throw + + ;; Given a map, returns a list of keys ;; Input: List in RSI with one Map element ;; Returns: List in RAX @@ -183,3 +316,122 @@ core_keys: mov rsi, [rsi + Cons.car] call map_keys ret + +;; Return arguments as a list +;; +core_list: + call incref_object + mov rax, rsi + ret + +;; ------------------------------------------------ +;; String functions + +;; Convert arguments to a readable string, separated by a space +;; +core_pr_str: + + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_empty + je .empty ; Nothing to print + + xor r8, r8 ; Return string in r8 + +.loop: + cmp ah, content_pointer + je .got_pointer + + ; A value. Remove list container + xchg ah, al + mov [rsi], BYTE al + xchg ah, al + push rsi + push rax + call pr_str + pop rbx + pop rsi + mov [rsi], BYTE bl ; restore type + jmp .got_string + +.got_pointer: + push rsi + call pr_str + ret + + ;mov rsi, [rsi + Cons.car] ; Address pointed to + call pr_str + ;call string_new + pop rsi + +.got_string: + ; String now in rax + + cmp r8, 0 + jne .append + + ; first string + mov r8, rax ; Output string + jmp .next + +.append: + push rsi + push rax + + mov rsi, r8 ; Output string + mov rdx, rax ; String to be copied + call string_append_string + mov r8, rax + + pop rsi ; Was in rax, temporary string + call release_array ; Release the string + + pop rsi ; Restore input + +.next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; More inputs + mov rsi, [rsi + Cons.cdr] ; pointer + + ; Add separator + push rsi + mov rsi, r8 + mov cl, ' ' + call string_append_char + pop rsi + + ; Get the type in ah for comparison at start of loop + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + + jmp .loop +.done: + ; No more input, so return + mov rax, r8 + ret + +.empty: + call string_new ; An empty string + ret + +;; Print arguments readably, return nil +core_prn: + ; Convert to string + call core_pr_str + ; print the string + mov rsi, rax + push rsi ; Save the string address + call print_string + pop rsi + call release_array ; Release the string + + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + ret diff --git a/nasm/printer.asm b/nasm/printer.asm index cdcdea7542..3e26d77eba 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -24,6 +24,7 @@ section .text ;; RCX ;; R12 ;; R13 +;; R14 ;; Calls: raw_to_string, ;; ;; diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index d6b1651a1e..3fab6c75a9 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -55,6 +55,11 @@ section .data static_symbol do_symbol, 'do' static_symbol if_symbol, 'if' static_symbol fn_symbol, 'fn*' + +;; Empty list value, passed to functions without args +;; Note this is just a single byte, so the rest of the +;; list must never be accessed. +static_empty_list: db maltype_empty_list section .text @@ -1263,11 +1268,20 @@ eval: mov cl, BYTE [rbx] cmp cl, maltype_function jne .list_not_function - + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + ; No arguments + mov rsi, static_empty_list ; Point to an empty list + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: ; Call the function with the rest of the list in RSI push rax push r15 - mov rsi, [rax + Cons.cdr] ; Rest of list mov rdi, rbx ; Function object in RDI call [rbx + Cons.car] ; Call function ; Result in rax From cbcb37cd76f41721a68d34b06226f2b989b9f45d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 6 Nov 2017 23:09:10 +0000 Subject: [PATCH 0275/1998] functions =, pr-str and prn working pr-str was failing due to R8 being overwritten. Added push/pop and now works as expected. Test for equality now added compare_objects_rec which recursively compares lists and other structures --- nasm/core.asm | 62 ++++++++++++++++++--------- nasm/printer.asm | 1 + nasm/step4_if_fn_do.asm | 7 +--- nasm/types.asm | 92 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 136 insertions(+), 26 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 7fca59efb5..1398072703 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -69,7 +69,7 @@ core_environment: core_env_native core_emptyp_symbol, core_emptyp core_env_native core_count_symbol, core_count - core_env_native core_equal_symbol, core_equal_p + core_env_native core_equal_symbol, core_equalp core_env_native core_keys_symbol, core_keys core_env_native core_list_symbol, core_list @@ -167,10 +167,13 @@ core_arithmetic: mov [rax + Cons.typecdr], BYTE content_nil ret -;; Test objects for equality -core_equal_p: +;; compare objects for equality +core_equalp: ; Check that rsi contains a list mov cl, BYTE [rsi] + cmp cl, maltype_empty_list + je .error + and cl, block_mask + container_mask cmp cl, block_cons + container_list jne .error @@ -183,23 +186,42 @@ core_equal_p: ; move second pointer into rdi mov rdi, [rsi + Cons.cdr] - ; Compare rsi and rdi objects - call compare_objects ; result in rax + ; Remove next pointers + mov cl, BYTE [rsi + Cons.typecdr] + mov [rsi + Cons.typecdr], BYTE 0 + + mov bl, BYTE [rdi + Cons.typecdr] + mov [rdi + Cons.typecdr], BYTE 0 + + push rbx + push rcx + + ; Compare the objects recursively + call compare_objects_rec + + ; Restore next pointers + pop rcx + pop rbx + mov [rsi + Cons.typecdr], BYTE cl + mov [rdi + Cons.typecdr], BYTE bl - ; for now put result into Cons - mov rdi, rax + je .true + + +.false: call alloc_cons - mov [rax], BYTE maltype_integer - mov [rax + Cons.typecdr], BYTE content_nil - mov [rax + Cons.car], rdi + mov [rax], BYTE maltype_false ret -.error: - ; Return nil +.true: call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil + mov [rax], BYTE maltype_true ret - +.error: + push rsi + print_str_mac error_string ; print 'Error: ' + pop rsi + jmp error_throw + ;; Test if a given object is a list ;; Input list in RSI ;; Returns true or false in RAX @@ -349,7 +371,9 @@ core_pr_str: xchg ah, al push rsi push rax + push r8 call pr_str + pop r8 pop rbx pop rsi mov [rsi], BYTE bl ; restore type @@ -357,12 +381,10 @@ core_pr_str: .got_pointer: push rsi + push r8 + mov rsi, [rsi + Cons.car] ; Address pointed to call pr_str - ret - - ;mov rsi, [rsi + Cons.car] ; Address pointed to - call pr_str - ;call string_new + pop r8 pop rsi .got_string: diff --git a/nasm/printer.asm b/nasm/printer.asm index 3e26d77eba..83d2a1d9d5 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -22,6 +22,7 @@ section .text ;; ;; Modifies: ;; RCX +;; R8 ;; R12 ;; R13 ;; R14 diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index 3fab6c75a9..c577583971 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -1331,11 +1331,6 @@ apply_fn: pop rax ret - -;; Prints the result -print: - mov rax, rsi ; Return the input - ret ;; Read-Eval-Print in sequence rep_seq: @@ -1343,7 +1338,7 @@ rep_seq: mov rsi, rax ; Output of read into input of eval call eval mov rsi, rax ; Output of eval into input of print - call print + call pr_str mov rsi, rax ; Return value ret diff --git a/nasm/types.asm b/nasm/types.asm index 0fd89e7cee..ff78a83a03 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -777,6 +777,98 @@ compare_objects: ret +;; Recursively check objects, including lists +;; +;; Inputs: Objects in RSI and RDI +;; +;; Sets ZF if equal, clears flag otherwise +compare_objects_rec: + ; Compare rsi and rdi objects + + ; Check type + mov al, BYTE [rsi] + mov bl, BYTE [rdi] + cmp al, bl + jne .false + + ; Check the container type + and bl, block_mask + jnz .array + + ; Check if a pointer to something + and al, content_mask + cmp al, content_pointer + je .pointer + + ; Get the values + + mov rbx, [rsi + Cons.car] + mov rcx, [rdi + Cons.car] + cmp rbx, rcx + jne .false + + ; Value is the same, so get next + jmp .next + +.array: + ; Comparing arrays + call compare_char_array + cmp rax, 0 + ret ; Array has no next + +.pointer: + + mov rbx, [rsi + Cons.car] + mov rcx, [rdi + Cons.car] + cmp rbx, rcx + je .next ; Equal pointers + + push rsi + push rdi + ; Put the addresses to compare into RSI and RDI + mov rsi, rbx + mov rdi, rcx + call compare_objects_rec + pop rdi + pop rsi + jne .false + ; fall through to .next + +.next: + ; Check if both have a 'cdr' pointer + mov al, BYTE [rsi + Cons.typecdr] + mov bl, BYTE [rdi + Cons.typecdr] + + cmp al, content_pointer + je .rsi_has_next + + ; No next pointer in RSI + cmp bl, content_pointer + je .false ; RDI has a next pointer + + ; Neither have a next pointer, so done + jmp .true + +.rsi_has_next: + cmp bl, content_pointer + jne .false ; RDI has no next pointer + + ; Both have a next pointer, so keep going + mov rsi, [rsi + Cons.cdr] + mov rdi, [rdi + Cons.cdr] + jmp compare_objects_rec + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + ret + ;; Char array objects (strings, symbols, keywords) in RSI and RDI ;; Return code in RAX ;; From d692bd1f951aa414f95464510c5f193f633f703c Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 6 Nov 2017 23:37:57 +0000 Subject: [PATCH 0276/1998] Added numeric comparison operators TEST RESULTS (for ../tests/step4_if_fn_do.mal): 0: soft failing tests 60: failing tests 108: passing tests 168: total tests Some to look at next time: * (= "" "") -> false, should be true * (def! DO (fn* (a) 7)) (DO 3) -> (7), should be 7 * Function with empty argument list currently not allowed --- nasm/Makefile | 4 +++ nasm/core.asm | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++ nasm/types.asm | 4 +-- 3 files changed, 82 insertions(+), 2 deletions(-) diff --git a/nasm/Makefile b/nasm/Makefile index 3eddf75ad6..6c6b46d030 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -15,3 +15,7 @@ step2_eval: step2_eval.asm $(COMPONENTS) step3_env: step3_env.asm $(COMPONENTS) nasm -felf64 step3_env.asm ld -o $@ step3_env.o + +step4_if_fn_do: step4_if_fn_do.asm $(COMPONENTS) + nasm -felf64 step4_if_fn_do.asm + ld -o $@ step4_if_fn_do.o diff --git a/nasm/core.asm b/nasm/core.asm index 1398072703..ff71cfcb4a 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -16,6 +16,10 @@ section .data static core_emptyp_symbol, db "empty?" static core_equal_symbol, db "=" + static core_gt_symbol, db ">" + static core_lt_symbol, db "<" + static core_ge_symbol, db ">=" + static core_le_symbol, db "<=" static core_count_symbol, db "count" static core_keys_symbol, db "keys" @@ -29,6 +33,7 @@ section .data static core_emptyp_error_string, db "empty? expects a list, vector or map",10 static core_count_error_string, db "count expects a list or vector",10 + static core_numeric_expect_ints, db "comparison operator expected two numbers",10 section .text ;; Add a native function to the core environment @@ -70,6 +75,10 @@ core_environment: core_env_native core_count_symbol, core_count core_env_native core_equal_symbol, core_equalp + core_env_native core_gt_symbol, core_gt + core_env_native core_lt_symbol, core_lt + core_env_native core_ge_symbol, core_ge + core_env_native core_le_symbol, core_le core_env_native core_keys_symbol, core_keys core_env_native core_list_symbol, core_list @@ -221,6 +230,73 @@ core_equalp: print_str_mac error_string ; print 'Error: ' pop rsi jmp error_throw + +;; ----------------------------------------------------------------- +;; Numerical comparisons + + +core_gt: + mov rcx, core_compare_num.gt + jmp core_compare_num +core_lt: + mov rcx, core_compare_num.lt + jmp core_compare_num +core_ge: + mov rcx, core_compare_num.ge + jmp core_compare_num +core_le: + mov rcx, core_compare_num.le + ;jmp core_compare_num +core_compare_num: + ; The first argument should be an int + mov al, BYTE [rsi] + and al, content_mask + cmp al, maltype_integer + jne .error + + ; Check that there's a second argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .error + mov rax, [rsi + Cons.car] + mov rdi, [rsi + Cons.cdr] + + ; The second arg should also be an int + mov bl, BYTE [rdi] + and bl, content_mask + cmp bl, maltype_integer + jne .error + + mov rbx, [rdi + Cons.car] + + cmp rax, rbx + jmp rcx ; Address set above +.gt: + jg .true + jmp .false +.lt: + jl .true + jmp .false +.ge: + jge .true + jmp .false +.le: + jle .true + ;jmp .false +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret +.error: + push rsi + print_str_mac error_string ; print 'Error: ' + print_str_mac core_numeric_expect_ints + pop rsi + jmp error_throw ;; Test if a given object is a list ;; Input list in RSI diff --git a/nasm/types.asm b/nasm/types.asm index ff78a83a03..9767219f0d 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -151,12 +151,12 @@ section .data ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 100 ; Number of cons objects which can be created +%define heap_cons_limit 1000 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 50 ; Number of array objects which can be created +%define heap_array_limit 300 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 From aa722d73db1c8c87ace527c82bee5c493838e6df Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 7 Nov 2017 23:30:11 +0000 Subject: [PATCH 0277/1998] step 4 non-deferrable tests passing Down to 37 failing tests. Some odd ones, maybe indicating something strange going on with memory for string arrays. --- nasm/core.asm | 18 +++++++++-- nasm/env.asm | 5 ++- nasm/printer.asm | 3 ++ nasm/step4_if_fn_do.asm | 69 ++++++++++++++++++++++++++++++++++++----- nasm/types.asm | 11 +++++-- 5 files changed, 93 insertions(+), 13 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index ff71cfcb4a..613b095640 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -357,11 +357,16 @@ core_emptyp: core_count: mov al, BYTE [rsi] and al, content_mask + + cmp al, content_nil + je .zero + cmp al, content_pointer jne .error ; Expected a container mov rsi, [rsi + Cons.car] mov al, BYTE [rsi] + mov ah, al and ah, (block_mask + container_mask) cmp ah, (block_cons + container_list) @@ -389,7 +394,9 @@ core_count: mov rsi, [rsi + Cons.cdr] jmp .loop - + +.zero: ; Return zero count + mov rbx, 0 .done: ; Count is in RBX push rbx @@ -522,8 +529,15 @@ core_pr_str: core_prn: ; Convert to string call core_pr_str - ; print the string mov rsi, rax + + ; Put newline at the end + push rsi + mov cl, 10 ; newline + call string_append_char + pop rsi + + ; print the string push rsi ; Save the string address call print_string pop rsi diff --git a/nasm/env.asm b/nasm/env.asm index 8a87c0fdb4..dd4bd4a356 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -75,11 +75,14 @@ env_new_bind: call env_new mov r13, rax ; New environment in R13 - + .bind_loop: ; Check the type in the bind list mov bl, BYTE [r11] and bl, content_mask + cmp bl, content_empty + je .done ; No bindings + cmp bl, content_pointer jne .bind_not_symbol diff --git a/nasm/printer.asm b/nasm/printer.asm index 83d2a1d9d5..0322c55ff5 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -68,6 +68,9 @@ pr_str: cmp cl, '"' ; je .string_escape_char + cmp cl, 92 ; Escape '\' + je .string_escape_char + cmp cl, 10 ; Newline je .string_newline diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index c577583971..c2b11ee308 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -55,11 +55,19 @@ section .data static_symbol do_symbol, 'do' static_symbol if_symbol, 'if' static_symbol fn_symbol, 'fn*' - + ;; Empty list value, passed to functions without args ;; Note this is just a single byte, so the rest of the ;; list must never be accessed. -static_empty_list: db maltype_empty_list +static_empty_list: ISTRUC Cons +AT Cons.typecar, db maltype_empty_list +AT Cons.typecdr, db 0 +AT Cons.refcount, dw -1 +IEND + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" + section .text @@ -1183,8 +1191,14 @@ eval: mov al, BYTE [r11] and al, content_mask cmp al, content_pointer - jne .fn_got_body ; Body in r11 + jne .fn_is_value ; Body in r11 mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + .fn_got_body: ; Now put into function type @@ -1304,6 +1318,8 @@ eval: ;; ;; Input: RSI - Arguments to bind ;; RDI - Function object +;; +;; Output: Result in RAX apply_fn: push rsi ; Extract values from the list in RDI @@ -1311,16 +1327,29 @@ apply_fn: mov rsi, [rax + Cons.car] ; Env mov rax, [rax + Cons.cdr] mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body pop rcx ; Exprs + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + push rax + mov rsi, rax + call incref_object + pop rax + ret +.bind: + ; Create a new environment, binding arguments push rax call env_new_bind mov rdi, rax ; New environment in RDI - pop rax ; Function object - - mov rax, [rax + Cons.cdr] - mov rsi, [rax + Cons.car] ; Body + pop rsi ; Body + ; Evaluate the function body push rdi ; Environment call eval pop rsi @@ -1331,6 +1360,7 @@ apply_fn: pop rax ret + ;; Read-Eval-Print in sequence rep_seq: @@ -1354,6 +1384,31 @@ _start: mov rdi, .catch ; Address to jump to xor rcx, rcx ; No data call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rsi ; AST + + push rsi + mov rdi, [repl_env] ; Environment + call eval + pop rsi + + push rax + call release_object ; AST + pop rsi + call release_object ; Return from eval ; ----------------------------- ; Main loop diff --git a/nasm/types.asm b/nasm/types.asm index 9767219f0d..60b13cf9c9 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -386,6 +386,7 @@ incref_object: string_new: call alloc_array mov [rax], BYTE maltype_string + mov DWORD [rax + Array.length], 0 mov QWORD [rax + Array.next], 0 ret @@ -884,6 +885,10 @@ compare_char_array: jne .different ; same length + + cmp eax, 0 + je .equal ; Both zero length + mov rbx, rsi add rbx, Array.data mov rcx, rdi @@ -895,13 +900,13 @@ compare_char_array: jl .rdi_greater jg .rsi_greater - ; equal + ; this character is equal inc rbx inc rcx dec eax - jnz .compare_loop + jnz .compare_loop ; Next character - ; equal +.equal: mov rax, 0 ret From 2eba19559b585375cb74c227ac06b354950cde69 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 8 Nov 2017 23:31:09 +0000 Subject: [PATCH 0278/1998] step 4 keywords, []/() comparison, variadic args Finished support for "& more" style args. Now handles case where "more" is empty. Better handling of empty list, removing use of static empty list, since this seemed to lead to hard-to-debug memory issues. Comparison between Cons container types (vector, list, map for now) ignores container type, so (= [] (list)) -> true Step 4 down to 19 failing tests, all due to missing str and println functions. --- nasm/env.asm | 73 +++++++++++++++++++++++++++++++++++++---- nasm/step4_if_fn_do.asm | 59 +++++++++++++++++++++------------ nasm/types.asm | 19 +++++++++-- 3 files changed, 121 insertions(+), 30 deletions(-) diff --git a/nasm/env.asm b/nasm/env.asm index dd4bd4a356..ad35d8d01b 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -13,11 +13,13 @@ section .data ;; Symbols used for comparison static_symbol env_symbol, '*env*' - + static_symbol ampersand_symbol, '&' + ;; Error message strings - static env_binds_error_string, db "Expecting symbol in binds list",10 - static env_binds_missing_string, db "Missing expression in bind",10 + static env_binds_error_string, db "Env expecting symbol in binds list",10 + static env_binds_missing_string, db "Env missing expression in bind",10 + static env_missing_symbol_after_amp_string, db "Env missing symbol after &",10 section .text @@ -92,11 +94,24 @@ env_new_bind: jne .bind_not_symbol ; RDI now contains a symbol + + ; Check if it is '&' + mov rsi, ampersand_symbol + push rdi + call compare_char_array ; Compares RSI and RDI + pop rdi + cmp rax, 0 + je .variadic ; Bind rest of args to following symbol + ; Check the type in expr mov bl, BYTE [r12] mov bh, bl and bh, content_mask + + cmp bh, content_empty + je .bind_missing_expr ; No expression + cmp bh, content_pointer je .value_pointer @@ -120,7 +135,7 @@ env_new_bind: call env_set ; Fall through to next .next: - ; Check if there is a next + ; Check if there is a next symbol mov bl, BYTE [r11 + Cons.typecdr] cmp bl, content_pointer jne .done @@ -131,13 +146,57 @@ env_new_bind: ; Check if there's an expression to bind to mov bl, BYTE [r12 + Cons.typecdr] cmp bl, content_pointer - jne .bind_missing_expr + jne .next_no_expr ; No expr, but symbol could be & mov r12, [r12 + Cons.cdr] ; Next expression jmp .bind_loop + +.next_no_expr: + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov r12, rax + + jmp .bind_loop .done: mov rax, r13 ; Env ret + +.variadic: + ; R11 Cons contains '&' symbol + ; Bind next symbol to the rest of the list in R12 + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .missing_symbol_after_amp + + mov r11, [r11 + Cons.cdr] + + mov bl, BYTE [r11] + and bl, content_mask + cmp bl, content_pointer + jne .bind_not_symbol + + mov rdi, [r11 + Cons.car] ; Symbol object? + mov bl, BYTE [rdi] + cmp bl, maltype_symbol + jne .bind_not_symbol + + ; Bind symbol in RDI to R12 + mov rcx, r12 ; Value + mov rsi, r13 ; Env + call env_set + jmp .done + +.missing_symbol_after_amp: + push r12 + + ; Release the environment + mov rsi, r13 + call release_object + + print_str_mac error_string ; print 'Error: ' + print_str_mac env_missing_symbol_after_amp_string + pop rsi + jmp error_throw .bind_not_symbol: ; Expecting a symbol push r11 ; Binds list @@ -154,8 +213,10 @@ env_new_bind: jmp error_throw .bind_missing_expr: + ; Have a symbol, but no expression. + push r11 ; Binds list - + ; Release the environment mov rsi, r13 call release_object diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index c2b11ee308..9fc58d4dd9 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -46,7 +46,8 @@ section .data static let_bind_value_string, db "let* missing value in bindings list",10 static let_missing_body_string, db "let* missing body",10 - + static eval_list_not_function, db "list does not begin with a function",10 + ;; Symbols used for comparison @@ -56,15 +57,6 @@ section .data static_symbol if_symbol, 'if' static_symbol fn_symbol, 'fn*' -;; Empty list value, passed to functions without args -;; Note this is just a single byte, so the rest of the -;; list must never be accessed. -static_empty_list: ISTRUC Cons -AT Cons.typecar, db maltype_empty_list -AT Cons.typecdr, db 0 -AT Cons.refcount, dw -1 -IEND - ;; Startup string. This is evaluated on startup static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" @@ -233,6 +225,11 @@ eval_ast: ret .symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + ; look in environment push rsi xchg rsi, rdi @@ -256,7 +253,15 @@ eval_ast: pop rsi jmp error_throw - + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + ; ------------------------------ .list: ; Evaluate each element of the list @@ -638,7 +643,7 @@ eval: ; Check type mov al, BYTE [rsi] cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged + je .return_nil and al, container_mask cmp al, container_list @@ -654,6 +659,7 @@ eval: ; Check if the first element is a symbol mov al, BYTE [rsi] + and al, content_mask cmp al, content_pointer jne .list_eval @@ -1107,7 +1113,7 @@ eval: ; Skip the next item mov al, BYTE [r11 + Cons.typecdr] cmp al, content_pointer - jne .if_nil + jne .return_nil mov r11, [r11 + Cons.cdr] @@ -1115,7 +1121,7 @@ eval: ; Get the next item in the list and evaluate it mov al, BYTE [r11 + Cons.typecdr] cmp al, content_pointer - jne .if_nil + jne .return_nil ; Nothing to return mov r11, [r11 + Cons.cdr] @@ -1147,7 +1153,7 @@ eval: mov [rax + Cons.typecdr], BYTE content_nil ret -.if_nil: +.return_nil: call alloc_cons mov [rax], BYTE maltype_nil mov [rax + Cons.typecdr], BYTE content_nil @@ -1266,11 +1272,12 @@ eval: ; ----------------------------- .list_eval: - + push rsi mov rdi, r15 ; Environment push r15 call eval_ast pop r15 + pop rsi ; Check that the first element of the return is a function mov bl, BYTE [rax] @@ -1287,8 +1294,13 @@ eval: mov cl, BYTE [rax + Cons.typecdr] cmp cl, content_pointer je .list_got_args + ; No arguments - mov rsi, static_empty_list ; Point to an empty list + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax jmp .list_function_call .list_got_args: mov rsi, [rax + Cons.cdr] ; Rest of list @@ -1308,11 +1320,16 @@ eval: .list_not_function: ; Not a function. Probably an error - ret + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw -.empty_list: - mov rax, rsi - ret ;; Applies a user-defined function ;; diff --git a/nasm/types.asm b/nasm/types.asm index 60b13cf9c9..fb693ccc28 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -789,11 +789,19 @@ compare_objects_rec: ; Check type mov al, BYTE [rsi] mov bl, BYTE [rdi] - cmp al, bl + + mov ah, al + mov bh, bl + + ; Don't distinguish between [] and () + and ah, (block_mask + content_mask) + and bh, (block_mask + content_mask) + + cmp ah, bh jne .false - + ; Check the container type - and bl, block_mask + and bh, block_mask jnz .array ; Check if a pointer to something @@ -813,6 +821,11 @@ compare_objects_rec: .array: ; Comparing arrays + + ; Container type (symbol/string) does matter + cmp al, bl + jne .false + call compare_char_array cmp rax, 0 ret ; Array has no next From 17d45192b97d87d5a476c6a968d131ecc69482db Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 9 Nov 2017 00:13:20 +0000 Subject: [PATCH 0279/1998] print_readably flag, str and println functions Additional flag to pr_str in RDI. If zero, returns string without escaping special characters. Added str and println functions, using most of the same code as pr-str and prn Only one test now failing for step 4. --- nasm/core.asm | 21 ++++++++++++++++++--- nasm/printer.asm | 12 ++++++++++++ nasm/step4_if_fn_do.asm | 5 ++++- 3 files changed, 34 insertions(+), 4 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 613b095640..e776538d02 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -28,6 +28,8 @@ section .data static core_pr_str_symbol, db "pr-str" static core_prn_symbol, db "prn" + static core_str_symbol, db "str" + static core_println_symbol, db "println" ;; Strings @@ -85,6 +87,8 @@ core_environment: core_env_native core_pr_str_symbol, core_pr_str core_env_native core_prn_symbol, core_prn + core_env_native core_str_symbol, core_str + core_env_native core_println_symbol, core_println ; ----------------- ; Put the environment in RAX @@ -435,7 +439,11 @@ core_list: ;; Convert arguments to a readable string, separated by a space ;; core_pr_str: - + mov rdi, 1 ; print_readably + jmp core_str_functions +core_str: + xor rdi, rdi +core_str_functions: mov al, BYTE [rsi] mov ah, al and ah, content_mask @@ -503,13 +511,17 @@ core_pr_str: ; More inputs mov rsi, [rsi + Cons.cdr] ; pointer + cmp rdi, 0 ; print_readably + je .end_append_char ; No separator if not printing readably + ; Add separator push rsi mov rsi, r8 mov cl, ' ' call string_append_char pop rsi - +.end_append_char: + ; Get the type in ah for comparison at start of loop mov al, BYTE [rsi] mov ah, al @@ -527,8 +539,11 @@ core_pr_str: ;; Print arguments readably, return nil core_prn: - ; Convert to string call core_pr_str + jmp core_prn_functions +core_println: + call core_str +core_prn_functions: mov rsi, rax ; Put newline at the end diff --git a/nasm/printer.asm b/nasm/printer.asm index 0322c55ff5..2e0b91f66f 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -17,6 +17,7 @@ section .data section .text ;; Input: Address of object in RSI +;; print_readably in RDI. Set to zero for false ;; ;; Output: Address of string in RAX ;; @@ -41,6 +42,11 @@ pr_str: ; --------------------------- ; Handle string + + cmp rdi, 0 + je .string_not_readable + + ; printing readably, so escape characters call string_new ; Output string in rax @@ -102,6 +108,12 @@ pr_str: ret +.string_not_readable: + ; Just return the string + call incref_object + mov rax, rsi + ret + ; ---------------------------- .not_string: ; Now test the container type (value, list, map, vector) diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index 9fc58d4dd9..852192c403 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -184,6 +184,7 @@ error_throw: ; Print the object in RSI then quit cmp rsi, 0 je .done ; nothing to print + mov rdi, 1 ; print_readably call pr_str mov rsi, rax call print_string @@ -1454,7 +1455,8 @@ _start: push rax ; Save result ; Put into pr_str - mov rsi, rax + mov rsi, rax + mov rdi, 1 ; print_readably call pr_str push rax ; Save output string @@ -1488,6 +1490,7 @@ _start: ; Check if an object was thrown cmp rsi, 0 je .catch_done_print ; nothing to print + mov rdi, 1 call pr_str mov rsi, rax call print_string From b43cd5b63905b38bd62e948c0653b36319a99d3c Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 9 Nov 2017 23:25:37 +0000 Subject: [PATCH 0280/1998] Fixes for long strings Extra code in string_append_char, string_append_string, and print_string to handle long strings. Printing *env* no longer produces segfault. --- nasm/types.asm | 48 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 43 insertions(+), 5 deletions(-) diff --git a/nasm/types.asm b/nasm/types.asm index fb693ccc28..a795dc2fbc 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -431,14 +431,39 @@ raw_to_symbol: ;; Appends a character to a string ;; Input: Address of string in RSI, character in CL +;; +;; Modifies +;; RAX string_append_char: + push rsi + ; Get the end of the string +.get_end: + mov rax, [rsi + Array.next] + cmp rax, 0 + jz .got_dest_end + mov rsi, rax + jmp .get_end +.got_dest_end: + + ; Check if this chunk is full mov eax, DWORD [rsi + Array.length] + cmp eax, (array_chunk_len*8) + jne .append + + ; full, need to allocate another + call alloc_array + mov [rsi + Array.next], rax + mov rsi, rax + xor eax, eax ; Set length to zero +.append: inc eax mov DWORD [rsi + Array.length], eax dec eax add rax, rsi add rax, Array.data ; End of data - mov [rax], BYTE cl + mov [rax], BYTE cl + + pop rsi ; Restore original value ret ;; Appends a string to the end of a string @@ -468,6 +493,9 @@ string_append_string: mov r11, r10 mov r8d, DWORD [rbx + Array.length] add r11, r8 + + cmp r8d, 0 + je .return ; Appending zero-size array ; Find the end of the string in RSI ; and put the address of the Array object into rax @@ -485,7 +513,7 @@ string_append_string: mov r8, rax add r8, Array.data add r8d, DWORD [rax + Array.length] - + ; destination data end into r9 mov r9, rax add r9, Array.size @@ -500,7 +528,7 @@ string_append_string: ; Check if we've reached the end of this Array cmp r10, r11 jne .source_ok - + ; have reached the end of the source Array mov rbx, QWORD [rbx + Array.next] ; Get the next Array address cmp rbx, 0 ; Test if it's null @@ -523,6 +551,7 @@ string_append_string: cmp r8, r9 jne .copy_loop ; Next byte +.alloc_dest: ; Reached the end of the destination ; Need to allocate another Array push rax @@ -541,6 +570,7 @@ string_append_string: mov r9, rax add r9, Array.size + jmp .copy_loop .finished: ; Compare r8 (destination) with data start @@ -550,7 +580,7 @@ string_append_string: inc r8 ; r8 now contains length mov DWORD [rax + Array.length], r8d - +.return: ret ;; ------------------------------------------ @@ -567,11 +597,19 @@ print_string: mov al, [rsi] cmp al, maltype_string jne .error - + +.print_chunk: ; write(1, string, length) + push rsi mov edx, [rsi + Array.length] ; number of bytes add rsi, Array.data ; address of raw string to output call print_rawstring + pop rsi + + ; Check if this is the end + mov rsi, QWORD [rsi + Array.next] + cmp rsi, 0 + jne .print_chunk ; next chunk ; Restore registers pop rsi From 2edb2d3cf2d5e0ff0e6e72409488f7f29fffd73f Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 11 Nov 2017 01:04:11 +0000 Subject: [PATCH 0281/1998] Step 5: Tail call optimisation Not working yet, still get memory-related errors --- nasm/Makefile | 4 + nasm/env.asm | 1 + nasm/step5_tco.asm | 1603 ++++++++++++++++++++++++++++++++++++++++++++ nasm/types.asm | 6 + 4 files changed, 1614 insertions(+) create mode 100644 nasm/step5_tco.asm diff --git a/nasm/Makefile b/nasm/Makefile index 6c6b46d030..1756968a9a 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -19,3 +19,7 @@ step3_env: step3_env.asm $(COMPONENTS) step4_if_fn_do: step4_if_fn_do.asm $(COMPONENTS) nasm -felf64 step4_if_fn_do.asm ld -o $@ step4_if_fn_do.o + +step5_tco: step5_tco.asm $(COMPONENTS) + nasm -felf64 step5_tco.asm + ld -o $@ step5_tco.o diff --git a/nasm/env.asm b/nasm/env.asm index ad35d8d01b..95c96deb9d 100644 --- a/nasm/env.asm +++ b/nasm/env.asm @@ -65,6 +65,7 @@ env_new: ;; ;; Modifies registers ;; RBX +;; RDX ;; R8 ;; R9 ;; R10 diff --git a/nasm/step5_tco.asm b/nasm/step5_tco.asm new file mode 100644 index 0000000000..18807bd0de --- /dev/null +++ b/nasm/step5_tco.asm @@ -0,0 +1,1603 @@ +;; +;; nasm -felf64 step5_tco.asm && ld step5_tco.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found.",10 + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" + + +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + cmp rax, 0 +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI Form to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; +;; Note: The environment in RDI will have its reference count +;; reduced by one (released). This is to make tail call optimisation easier +;; +eval: + mov r15, rdi ; Env + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .return_nil + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + call eval + mov rsi, rax + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + jmp .return + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + push rax + ; Release environment + mov rsi, r15 + call release_object + pop rax + + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; +;; Output: Result in RAX +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + push rax + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + pop rax + ret +.bind: + ; Create a new environment, binding arguments + push rax + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Release the list passed in RDX +.release: + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + pop rsi ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Read-Eval-Print in sequence +rep_seq: + call read_str + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call pr_str + mov rsi, rax ; Return value + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rsi ; AST + + push rsi + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + pop rsi + + push rax + call release_object ; AST + pop rsi + call release_object ; Return from eval + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call read_str + push rax ; Save AST + + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + push rax ; Save result + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + diff --git a/nasm/types.asm b/nasm/types.asm index a795dc2fbc..3e9fed8c63 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -353,6 +353,12 @@ release_cons: ;; Releases either a Cons or Array ;; Address of object in RSI +;; +;; May modify: +;; RAX +;; RBX +;; RCX +;; release_object: mov al, BYTE [rsi] ; Get first byte and al, block_mask ; Test block type From cc38947443e7f97c4037b54220559de20a0457f9 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 11 Nov 2017 08:05:27 +0000 Subject: [PATCH 0282/1998] Bugfix in let and def forms Was releasing the environment too many times, so it got deleted/reused when it shouldn't. Step 5 tests now pass. --- nasm/step5_tco.asm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/nasm/step5_tco.asm b/nasm/step5_tco.asm index 18807bd0de..d861773f62 100644 --- a/nasm/step5_tco.asm +++ b/nasm/step5_tco.asm @@ -770,6 +770,11 @@ eval: push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + call eval mov rsi, rax pop r15 @@ -958,7 +963,7 @@ eval: mov rsi, r14 call release_object pop rax - jmp .return + ret ; already released env .let_error_missing_bindings: mov rsi, let_missing_bindings_string From cd34fb3b2e235febb27d300da7f9902cc70fc8aa Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 11 Nov 2017 23:33:58 +0000 Subject: [PATCH 0283/1998] Added read-string and slurp functions System calls using Linux 64-bit syscalls in system.asm. Wrapper code in core.asm --- nasm/core.asm | 51 ++++++++++++++++++++++ nasm/system.asm | 113 ++++++++++++++++++++++++++++++++++++++++++++++++ nasm/types.asm | 6 ++- 3 files changed, 169 insertions(+), 1 deletion(-) diff --git a/nasm/core.asm b/nasm/core.asm index e776538d02..38f1e02068 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -30,6 +30,9 @@ section .data static core_prn_symbol, db "prn" static core_str_symbol, db "str" static core_println_symbol, db "println" + + static core_read_string_symbol, db "read-string" + static core_slurp_symbol, db "slurp" ;; Strings @@ -89,6 +92,9 @@ core_environment: core_env_native core_prn_symbol, core_prn core_env_native core_str_symbol, core_str core_env_native core_println_symbol, core_println + + core_env_native core_read_string_symbol, core_read_string + core_env_native core_slurp_symbol, core_slurp ; ----------------- ; Put the environment in RAX @@ -562,3 +568,48 @@ core_prn_functions: call alloc_cons mov [rax], BYTE maltype_nil ret + +;; Given a string, calls read_str to get an AST +core_read_string: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + jne .no_string + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .no_string + + call read_str + ret + +.no_string: + ; Didn't get a string input + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + +;; Reads a file into a string +core_slurp: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + jne .no_string + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .no_string + + call read_file + ret + +.no_string: + ; Didn't get a string input + call alloc_cons + mov [rax], BYTE maltype_nil + ret diff --git a/nasm/system.asm b/nasm/system.asm index 6389b2a64f..de4d793bef 100644 --- a/nasm/system.asm +++ b/nasm/system.asm @@ -3,6 +3,11 @@ ;;; This file contains system-specific functions, ;;; which use calls to the operating system (Linux) +section .data + static error_open_file_string, db "Error opening file " + static error_read_file_string, db "Error reading file " + +section .text ;; ------------------------------------------- ;; Prints a raw string to stdout @@ -91,3 +96,111 @@ read_line: pop rax ; Restore pointer to string mov DWORD [rax + Array.length], ebx ; Set string length ret + +;; Reads a file into a string +;; +;; Input: RSI - File name string (char Array) +;; +;; Returns: string in RAX +;; +;; Pieces from https://stackoverflow.com/questions/20133698/how-to-read-from-and-write-to-files-using-nasm-for-x86-64bit +read_file: + + mov rdi, rsi ; Filename + + ; Need to add null terminator + mov eax, DWORD [rdi + Array.length] + cmp eax, (array_chunk_len * 8) + je .error_filename ; File name too long + + ; Insert a null terminator + add rax, rdi + mov [rax + Array.data], BYTE 0 + + ; Open the file + mov rax, 2 + add rdi, Array.data; filename in RDI + xor rsi, rsi ; O_RDONLY in RSI + syscall + + ; Check for error (return -1) + cmp eax, 0 + jl .error_open + + mov rdi, rax ; File handle in RDI + + ; Create a string + push rdi + call string_new ; In RAX + pop rdi + + mov r9, rax ; Current Array + push rax ; This is popped in .done +.loop: + ; Read next chunk + push r9 + + mov rsi, r9 + add rsi, Array.data ; address + + mov rax, 0 ; sys_read + ; file handle in RDI + mov rdx, (array_chunk_len * 8) ; count + syscall + + pop r9 + + ; Characters read in RAX + + cmp rax, 0 + jl .error_read + + cmp rax, (array_chunk_len * 8) + jg .error_read + + mov [r9 + Array.length], DWORD eax + + jl .done + + ; May still be more to read. + ; Allocate another + call string_new + mov [r9 + Array.next], rax + mov r9, rax + jmp .loop + +.done: + ; Close the file + mov rax, 3 + ;rdi = file handle + syscall + + pop rax + ret + +.error_filename: +.error_open: + ; File name in RDI + sub rdi, Array.data + + ; Make the error message + mov rsi, error_open_file_string + mov edx, error_open_file_string.len + call raw_to_string + mov rsi, rax + mov cl, 39 ; (') + call string_append_char + mov rdx, rdi ; file name + call string_append_string + mov cl, 39 + call string_append_char + + ; Error message in RSI + jmp error_throw + +.error_read: + mov rsi, error_read_file_string + mov edx, error_read_file_string.len + call raw_to_string + mov rsi, rax + jmp error_throw diff --git a/nasm/types.asm b/nasm/types.asm index 3e9fed8c63..7de8cf6a67 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -387,8 +387,12 @@ incref_object: ;; ------------------------------------------- ;; String type - +;; ;; Create a new string, address in RAX +;; +;; Modifies registers +;; RBX +;; string_new: call alloc_array mov [rax], BYTE maltype_string From 193bb9201623f6984d76c88781d34770d9889376 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 12 Nov 2017 08:01:19 +0000 Subject: [PATCH 0284/1998] Added eval and load-file functions Had to add code to reader to ignore LF and CR as whitespace. --- nasm/core.asm | 28 + nasm/reader.asm | 7 +- nasm/step6_file.asm | 1608 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1642 insertions(+), 1 deletion(-) create mode 100644 nasm/step6_file.asm diff --git a/nasm/core.asm b/nasm/core.asm index 38f1e02068..d8330f1c01 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -33,6 +33,7 @@ section .data static core_read_string_symbol, db "read-string" static core_slurp_symbol, db "slurp" + static core_eval_symbol, db "eval" ;; Strings @@ -95,6 +96,7 @@ core_environment: core_env_native core_read_string_symbol, core_read_string core_env_native core_slurp_symbol, core_slurp + core_env_native core_eval_symbol, core_eval ; ----------------- ; Put the environment in RAX @@ -613,3 +615,29 @@ core_slurp: call alloc_cons mov [rax], BYTE maltype_nil ret + +;; Evaluate an expression in the REPL environment +;; +core_eval: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .pointer + + ; Just a value, so return it + call incref_object + ret + +.pointer: + ; A pointer, so need to eval + mov rsi, [rsi + Cons.car] + + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + ret diff --git a/nasm/reader.asm b/nasm/reader.asm index d4273f4c90..80939cbe0c 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -731,7 +731,12 @@ tokenizer_next: cmp cl, ',' ; Comma je .next_char cmp cl, 9 ; Tab - + je .next_char + cmp cl, 10 ; Line Feed + je .next_char + cmp cl, 13 ; Carriage Return + je .next_char + ; Special characters. These are returned in CL as-is cmp cl, '(' je .found diff --git a/nasm/step6_file.asm b/nasm/step6_file.asm new file mode 100644 index 0000000000..e7eaf620aa --- /dev/null +++ b/nasm/step6_file.asm @@ -0,0 +1,1608 @@ +;; +;; nasm -felf64 step6_file.asm && ld step6_file.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found.",10 + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) )" + + +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + cmp rax, 0 +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI Form to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; +;; Note: The environment in RDI will have its reference count +;; reduced by one (released). This is to make tail call optimisation easier +;; +eval: + mov r15, rdi ; Env + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .return_nil + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + mov rsi, rax + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + push rax + ; Release environment + mov rsi, r15 + call release_object + pop rax + + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; +;; Output: Result in RAX +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + push rax + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + pop rax + ret +.bind: + ; Create a new environment, binding arguments + push rax + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Release the list passed in RDX +.release: + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + pop rsi ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Read-Eval-Print in sequence +rep_seq: + call read_str + mov rsi, rax ; Output of read into input of eval + call eval + mov rsi, rax ; Output of eval into input of print + call pr_str + mov rsi, rax ; Return value + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rsi ; AST + + push rsi + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + pop rsi + + push rax + call release_object ; AST + pop rsi + call release_object ; Return from eval + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call read_str + push rax ; Save AST + + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + push rax ; Save result + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + From 1b30ad76a886c519eebc42ed84b4b1ea3cea5221 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 12 Nov 2017 23:46:18 +0000 Subject: [PATCH 0285/1998] Adding support for atoms * Functions atom, atom?, deref, reset! * Printer support for atoms * Type maltype_atom --- nasm/Makefile | 4 + nasm/core.asm | 208 +++++++++++++++++++++++++++++++++++++++++++++++ nasm/printer.asm | 27 ++++++ nasm/types.asm | 10 ++- 4 files changed, 246 insertions(+), 3 deletions(-) diff --git a/nasm/Makefile b/nasm/Makefile index 1756968a9a..298b0e38e9 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -23,3 +23,7 @@ step4_if_fn_do: step4_if_fn_do.asm $(COMPONENTS) step5_tco: step5_tco.asm $(COMPONENTS) nasm -felf64 step5_tco.asm ld -o $@ step5_tco.o + +step6_file: step6_file.asm $(COMPONENTS) + nasm -felf64 step6_file.asm + ld -o $@ step6_file.o diff --git a/nasm/core.asm b/nasm/core.asm index d8330f1c01..da0efd111a 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -34,12 +34,21 @@ section .data static core_read_string_symbol, db "read-string" static core_slurp_symbol, db "slurp" static core_eval_symbol, db "eval" + + static core_atom_symbol, db "atom" + static core_deref_symbol, db "deref" + static core_atomp_symbol, db "atom?" + static core_reset_symbol, db "reset!" ;; Strings static core_emptyp_error_string, db "empty? expects a list, vector or map",10 static core_count_error_string, db "count expects a list or vector",10 static core_numeric_expect_ints, db "comparison operator expected two numbers",10 + + static core_deref_not_atom, db "Error: argument to deref is not an atom" + static core_reset_not_atom, db "Error: argument to reset is not an atom" + static core_reset_no_value, db "Error: missing value argument to reset" section .text ;; Add a native function to the core environment @@ -97,6 +106,11 @@ core_environment: core_env_native core_read_string_symbol, core_read_string core_env_native core_slurp_symbol, core_slurp core_env_native core_eval_symbol, core_eval + + core_env_native core_atom_symbol, core_atom + core_env_native core_deref_symbol, core_deref + core_env_native core_atomp_symbol, core_atomp + core_env_native core_reset_symbol, core_reset ; ----------------- ; Put the environment in RAX @@ -641,3 +655,197 @@ core_eval: call eval ret + +;; Create an atom +core_atom: + push rsi + call alloc_cons ; To hold the pointer + pop rsi + mov [rax], BYTE maltype_atom + + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + je .pointer + + ; A value + + ; make a copy + push rax + push rsi + push rbx + call alloc_cons + pop rbx + + mov bl, bh + mov [rax], BYTE bl ; Set type + + mov rbx, rax + pop rsi + pop rax + + mov rcx, [rsi + Cons.car] + mov [rbx + Cons.car], rcx ; Set value + + ; Set the atom to point to it + mov [rax + Cons.car], rbx + + ret + +.pointer: + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + + push rax + mov rsi, rbx + call incref_object ; Storing in atom + pop rax + ret + +;; Get the value from the atom +core_deref: + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .not_atom + + ; Get the atom + mov rsi, [rsi + Cons.car] + mov bl, BYTE [rsi] + cmp bl, maltype_atom + jne .not_atom + + ; Return what it points to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.not_atom: + ; Not an atom, so throw an error + mov rsi, core_deref_not_atom + mov edx, core_deref_not_atom.len + call raw_to_symbol + mov rsi, rax + jmp error_throw + +;; Test if given object is an atom +core_atomp: + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .false + + mov rsi, [rsi + Cons.car] + mov bl, BYTE [rsi] + cmp bl, maltype_atom + jne .false + + ; Got an atom, return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + +;; Change the value of an atom +core_reset: + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .not_atom + + ; Get the atom + mov rax, [rsi + Cons.car] ; Atom in RAX + mov bl, BYTE [rax] + cmp bl, maltype_atom + jne .not_atom + + ; Get the next argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_value + + mov rsi, [rsi + Cons.cdr] + + ; Got something in RSI + ; release the current value of the atom + push rax + push rsi + + mov rsi, [rax + Cons.car] ; The value the atom points to + call release_object + + pop rsi + pop rax + + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + je .pointer + + ; A value + + ; make a copy + push rax + push rsi + push rbx + call alloc_cons + pop rbx + + mov bl, bh + mov [rax], BYTE bl ; Set type + + mov rbx, rax + pop rsi + pop rax + + mov rcx, [rsi + Cons.car] + mov [rbx + Cons.car], rcx ; Set value + + ; Set the atom to point to it + mov [rax + Cons.car], rbx + + ; Increment refcount since return value will be released + mov rsi, rbx + call incref_object + mov rax, rsi + ret + +.pointer: + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + + mov rsi, rbx + call incref_object ; Storing in atom + call incref_object ; Returning + mov rax, rsi + ret + +.not_atom: + ; Not an atom, so throw an error + mov rsi, core_reset_not_atom + mov edx, core_reset_not_atom.len + call raw_to_symbol + mov rsi, rax + jmp error_throw + +.no_value: + ; No value given + mov rsi, core_reset_no_value + mov edx, core_reset_no_value.len + call raw_to_symbol + mov rsi, rax + jmp error_throw diff --git a/nasm/printer.asm b/nasm/printer.asm index 2e0b91f66f..a1e8a0627c 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -137,6 +137,9 @@ pr_str: cmp ch, container_function je .function + + cmp ch, container_atom + je .atom ; Unknown mov rsi, unknown_type_string @@ -496,3 +499,27 @@ pr_str: mov edx, function_type_string.len call raw_to_string ; Puts a String in RAX ret + + ; -------------------------------- +.atom: + mov rsi, [rsi + Cons.car] ; What the atom points to + + call string_new ; String in rax + + ; Start string with '(atom' + mov rbx, '(atom ' + mov [rax + Array.data], rbx + mov [rax + Array.length], DWORD 6 + + push rax + call pr_str + mov rdx, rax ; string to be copied + pop rsi ; Output string + + call string_append_string + + ; closing bracket + mov cl, ')' + call string_append_char + mov rax, rsi + ret diff --git a/nasm/types.asm b/nasm/types.asm index 7de8cf6a67..a01d79f462 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -29,7 +29,7 @@ ;; 6 3 - Keyword. Only for Array blocks ;; 8 4 - Map ;; 10 5 - Function -;; 12 6 - Macro +;; 12 6 - Atom ;; 14 7 - Vector ;; ;; Content type [4 bits]: @@ -42,6 +42,7 @@ ;; 96 6 - Function (instruction address) ;; 112 7 - Empty (distinct from Nil) ;; 208 8 - False +;; 224 9 - Macro ;; ;; ;; These represent MAL data types as follows: @@ -58,7 +59,7 @@ ;; string Array Value Char ;; keyword Array Keyword Char ;; hash-map Cons Map Alternate key, values -;; atom Cons Value Pointer +;; atom Cons Atom Pointer ;; %include "macros.mac" @@ -105,7 +106,7 @@ ENDSTRUC %define container_keyword 6 %define container_map 8 %define container_function 10 -%define container_macro 12 +%define container_atom 12 %define container_vector 14 ;; Content type @@ -118,6 +119,7 @@ ENDSTRUC %define content_function 96 ; Function pointer %define content_empty 112 %define content_false 208 +%define content_macro 224 ;; Common combinations for MAL types %define maltype_integer (block_cons + container_value + content_int) @@ -131,6 +133,8 @@ ENDSTRUC %define maltype_macro (block_cons + container_macro + content_function) %define maltype_true (block_cons + container_value + content_true) %define maltype_false (block_cons + container_value + content_false) +%define maltype_atom (block_cons + container_atom + content_pointer) + ;; ------------------------------------------ section .data From be99f655c18859e95b12fd5076657649af9a26d7 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 14 Nov 2017 21:08:43 +0000 Subject: [PATCH 0286/1998] Improved handling of comments, whitespace Previously a comment would end input. Now looks for a line feed and resumes parsing. --- nasm/reader.asm | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/nasm/reader.asm b/nasm/reader.asm index 80939cbe0c..4fe92921f1 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -762,7 +762,7 @@ tokenizer_next: je .handle_tilde cmp cl, ';' ; Start of a comment - je .tokens_finished + je .comment cmp cl, 34 ; Opening string quotes je .handle_string @@ -781,6 +781,20 @@ tokenizer_next: ; Here an integer jmp .handle_integer + +.comment: + ; Start of a comment. Keep reading until a new line or end + + ; Fetch the next char into CL + call tokenizer_next_char + + cmp cl, 0 + je .found ; End, no more tokens + + cmp cl, 10 + je .next_char ; Next line, start reading again + + jmp .comment .handle_minus: @@ -901,6 +915,11 @@ tokenizer_next: cmp cl, ',' ; Comma je .symbol_finished cmp cl, 9 ; Tab + je .symbol_finished + cmp cl, 10 ; Line Feed + je .symbol_finished + cmp cl, 13 ; Carriage Return + je .symbol_finished cmp cl, '(' je .symbol_finished @@ -1006,11 +1025,7 @@ tokenizer_next: ret ; --------------------------------- - -.tokens_finished: - mov cl, 0 ; End of tokens - ret - + .handle_tilde: ; Could have '~' or '~@'. Need to peek at the next char @@ -1034,8 +1049,7 @@ tokenizer_next: pop r11 pop r10 pop r9 - ; fall through to found - + ; fall through to .found .found: ret From ea550eba37889968f1523550e0464bf4641e35ea Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 14 Nov 2017 22:07:12 +0000 Subject: [PATCH 0287/1998] Fixed bug in str and eval, add string_copy * str was not copying the first argument, which was then being appended to. If the str call was inside a function, then a string literal in the function body would be modified with every call, leading to strange behaviour. * eval was crashing on a value input like (eval nil) because the return was not put into rax as it should. Added string_copy, used in str function to copy the first input so that it can then be modified. Most step 6 tests now pass. 10 failing due to missing *ARGV* and swap! --- nasm/core.asm | 28 ++++++++++++++++++++---- nasm/types.asm | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 82 insertions(+), 4 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index da0efd111a..4da66b7471 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -506,24 +506,37 @@ core_str_functions: cmp r8, 0 jne .append - ; first string - mov r8, rax ; Output string + ; first string. Since this string will be + ; appended to, it needs to be a copy + push rsi ; input + + push rax ; string to copy + mov rsi, rax + call string_copy ; New string in RAX + pop rsi ; copied string + + push rax ; the copy + call release_object ; release the copied string + pop r8 ; the copy + + pop rsi ; input + jmp .next .append: + push r8 push rsi push rax mov rsi, r8 ; Output string mov rdx, rax ; String to be copied call string_append_string - mov r8, rax pop rsi ; Was in rax, temporary string call release_array ; Release the string pop rsi ; Restore input - + pop r8 ; Output string .next: ; Check if there's another mov al, BYTE [rsi + Cons.typecdr] @@ -537,11 +550,13 @@ core_str_functions: je .end_append_char ; No separator if not printing readably ; Add separator + push r8 push rsi mov rsi, r8 mov cl, ' ' call string_append_char pop rsi + pop r8 .end_append_char: ; Get the type in ah for comparison at start of loop @@ -641,6 +656,11 @@ core_eval: ; Just a value, so return it call incref_object + + mov al, BYTE [rsi] + and al, content_mask + mov [rsi], BYTE al ; Removes list + mov rax, rsi ret .pointer: diff --git a/nasm/types.asm b/nasm/types.asm index a01d79f462..940f910ebf 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -639,6 +639,64 @@ print_string: call print_rawstring ; exit jmp quit_error + +;; Copy a string +;; +;; Input: RSI - String to copy +;; +;; Output: New string in RAX +;; +;; Modifies: +;; RBX +;; RCX +;; RDX +;; RSI +;; +string_copy: + call string_new ; new string in RAX + + push rsi + push rax + + ; Get lengths + mov ebx, DWORD [rsi + Array.length] + mov [rax + Array.length], ebx + + ; Copy the whole block of data + ; Not sure if this is quicker than copying byte-by-byte + ; Could divide ebx by 8 (rounded up) to get the number + ; of blocks needed + + add rsi, Array.data ; Start of input data + add rax, Array.data ; Start of output data + mov ecx, array_chunk_len ; Number of 64-bit chunks + +.loop: + mov rbx, QWORD [rsi] + mov [rax], QWORD rbx + add rsi, 8 + add rax, 8 + dec ecx + jnz .loop + + pop rax + pop rsi + ; Now check if there's another block + mov rsi, [rsi + Array.next] + cmp rsi, 0 + jz .done ; Result in RAX + + ; Another array chunk + push rax ; Save output + + call string_copy ; Copy next chunk + mov rbx, rax ; The copy in RBX + + pop rax + ; append + mov [rax + Array.next], rbx +.done: + ret ;; ------------------------------------------ ;; String itostring(Integer number) From 1f819490b642ffc539d1754612f588acaac813ab Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 16 Nov 2017 22:56:21 +0000 Subject: [PATCH 0288/1998] swap! function tests pass Added a core function swap! It works, but has some warts: * No error message is thrown on error yet, needs adding * To run the function, swap! calls into the middle of eval. This probably indicates that eval needs to be split up. --- nasm/core.asm | 109 +++++++++++++++++++++++++++++++++++++++++++- nasm/printer.asm | 2 + nasm/step6_file.asm | 10 +++- nasm/types.asm | 4 +- 4 files changed, 121 insertions(+), 4 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 4da66b7471..9b783c5869 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -39,7 +39,7 @@ section .data static core_deref_symbol, db "deref" static core_atomp_symbol, db "atom?" static core_reset_symbol, db "reset!" - + static core_swap_symbol, db "swap!" ;; Strings static core_emptyp_error_string, db "empty? expects a list, vector or map",10 @@ -111,6 +111,7 @@ core_environment: core_env_native core_deref_symbol, core_deref core_env_native core_atomp_symbol, core_atomp core_env_native core_reset_symbol, core_reset + core_env_native core_swap_symbol, core_swap ; ----------------- ; Put the environment in RAX @@ -869,3 +870,109 @@ core_reset: call raw_to_symbol mov rsi, rax jmp error_throw + +;; Applies a function to an atom, along with optional arguments +;; +;; In RSI should be a list consisting of +;; [ atom, pointer->Function , args...] +;; +;; The atom is dereferenced, and inserted into the list: +;; +;; [ pointer->Function , atom value , args...] +;; +;; This is then passed to eval.list_exec +;; which executes the function +;; +core_swap: + ; Check the type of the first argument (an atom) + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .not_atom + + ; Get the atom + mov r8, [rsi + Cons.car] ; Atom in R8 + mov bl, BYTE [r8] + cmp bl, maltype_atom + jne .not_atom + + ; Get the second argument (a function) + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_function + + mov r9, [rsi + Cons.cdr] ; List with function first + + ; Get a new Cons to insert into the list + ; containing the value in the atom + call alloc_cons ; In RAX + + ; Splice into the list + mov bl, BYTE [r9 + Cons.typecdr] + mov rcx, [r9 + Cons.cdr] + mov [rax + Cons.typecdr], bl + mov [rax + Cons.cdr], rcx + mov [r9 + Cons.typecdr], BYTE content_pointer + mov [r9 + Cons.cdr], rax + + ; Now get the value in the atom + mov rdx, [r8 + Cons.car] ; The object pointed to + + ; Check what it is + mov bl, BYTE [rdx] + mov bh, bl + and bh, (block_mask + container_mask) + jz .atom_value ; Just a value + + ; Not a simple value, so point to it + mov [rax + Cons.car], rdx + mov [rax], BYTE (container_list + content_pointer) + jmp .list_done + +.atom_value: + ; Copy the value + mov rcx, [rdx + Cons.car] + mov [rax + Cons.car], rcx + and bl, content_mask ; keep just the content + or bl, container_list ; mark as part of a list + mov [rax], BYTE bl + +.list_done: + ; Now have a list with function followed by args + ; This is the same state as after a call to eval_ast + ; + ; Note: Because eval releases the environment in R15 + ; on return, this needs to have its references + ; incremented before the call + ; + ; The list passed in RAX will be released by eval + + mov rsi, r15 + call incref_object + + mov rax, r9 + push r8 ; The atom + call eval.list_exec ; Result in RAX + pop r8 + + ; release the current value of the atom + push rax ; The result + mov rsi, [r8 + Cons.car] + call release_object + pop rsi + + ; Put into atom + mov [r8 + Cons.car], rsi + + ; Increase reference of new object + ; because when it is returned it will be released + push rsi + call incref_object + pop rax + ret + +.not_atom: +.no_function: + xor rsi,rsi + jmp error_throw diff --git a/nasm/printer.asm b/nasm/printer.asm index a1e8a0627c..8ea122869d 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -98,6 +98,8 @@ pr_str: .string_finished: + + mov [r12], BYTE '"' ; At the end inc r12 ; Calculate length of string diff --git a/nasm/step6_file.asm b/nasm/step6_file.asm index e7eaf620aa..8aff290d5d 100644 --- a/nasm/step6_file.asm +++ b/nasm/step6_file.asm @@ -1350,7 +1350,15 @@ eval: call eval_ast ; List of evaluated forms in RAX pop r15 pop rsi - + + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; ; Check that the first element of the return is a function mov bl, BYTE [rax] and bl, content_mask diff --git a/nasm/types.asm b/nasm/types.asm index 940f910ebf..425d1434a1 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -96,11 +96,11 @@ ENDSTRUC %define content_mask 16 + 32 + 64 + 128 ; Four bits for content type ;; Block types -%define block_cons 0 +%define block_cons 0 ; Note: This must be zero %define block_array 1 ;; Container types -%define container_value 0 +%define container_value 0 ; Note: This must be zero %define container_list 2 %define container_symbol 4 %define container_keyword 6 From 43092cf0e146e60ea79da89014ab7efc795128d2 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 17 Nov 2017 22:08:59 +0000 Subject: [PATCH 0289/1998] Fix bug in swap! for complex types Need to increment the reference count or the object will be garbage collected after evaluation. --- nasm/core.asm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index 9b783c5869..caed13a94d 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -928,6 +928,12 @@ core_swap: ; Not a simple value, so point to it mov [rax + Cons.car], rdx mov [rax], BYTE (container_list + content_pointer) + + ; Since the list will be released after eval + ; we need to increment the reference count + mov rsi, rdx + call incref_object + jmp .list_done .atom_value: From 0a5a3ab3390817d0d0169ce382dd50f4493c3edf Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 17 Nov 2017 23:30:43 +0000 Subject: [PATCH 0290/1998] Adding *ARGV* command-line arguments Can now run a script passed as first argument, and puts any remaining arguments into a list *ARGV*. All step 6 tests now pass Some missing/buggy things: * The error handler should be different to the REPL one, or go into the REPL correctly on error * Strange errors occur if the file is too long. Suspect string problems --- nasm/step6_file.asm | 178 ++++++++++++++++++++++++++++++++++---------- nasm/types.asm | 37 ++++++++- 2 files changed, 174 insertions(+), 41 deletions(-) diff --git a/nasm/step6_file.asm b/nasm/step6_file.asm index 8aff290d5d..c18e58ed6c 100644 --- a/nasm/step6_file.asm +++ b/nasm/step6_file.asm @@ -57,12 +57,15 @@ section .data static_symbol do_symbol, 'do' static_symbol if_symbol, 'if' static_symbol fn_symbol, 'fn*' + + static_symbol argv_symbol, '*ARGV*' ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) )" - - -section .text + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text ;; ---------------------------------------------- ;; @@ -1488,13 +1491,49 @@ apply_fn: ;; Read-Eval-Print in sequence +;; +;; Input string in RSI rep_seq: + ; ------------- + ; Read call read_str - mov rsi, rax ; Output of read into input of eval + push rax ; Save AST + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + call eval - mov rsi, rax ; Output of eval into input of print + push rax ; Save result of eval + + ; ------------- + ; Print + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably call pr_str - mov rsi, rax ; Return value + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array ret @@ -1539,6 +1578,21 @@ _start: call release_object ; AST pop rsi call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set ; ----------------------------- ; Main loop @@ -1557,40 +1611,7 @@ _start: ; Put into read_str mov rsi, rax - call read_str - push rax ; Save AST - - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval - push rax ; Save result - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from pr_str - pop rsi - call release_array - - ; Release result of eval - pop rsi - call release_object - - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array + call rep_seq ; Release the input string pop rsi @@ -1614,3 +1635,80 @@ _start: .catch_done_print: jmp .mainLoop ; Go back to the prompt + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval-Print "(load-file )" + call rep_seq + + jmp quit diff --git a/nasm/types.asm b/nasm/types.asm index 425d1434a1..ee1b400c7b 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -442,6 +442,41 @@ raw_to_symbol: ; set the content type mov [rax], BYTE (block_array + container_symbol + content_char) ret + +;; Convert a NUL terminated C string to string +;; +;; Input: RSI - Address of string +;; +;; Returns: String in RAX +;; +;; Modifies: +;; RBX +;; RCX +;; RDX + +cstring_to_string: + push rsi + call string_new ; in RAX + pop rsi + + mov rbx, rax + add rbx, Array.data ; Start of output + mov rcx, rax + add rcx, Array.size ; End of output +.loop: + mov dl, BYTE [rsi] + test dl, dl ; Check if NUL (0) + jz .done + mov [rbx], BYTE dl + inc rbx + inc rsi + jmp .loop +.done: + sub rbx, rax + sub rbx, Array.data + ; rbx now contains the length + mov [rax + Array.length], DWORD ebx + ret ;; Appends a character to a string ;; Input: Address of string in RSI, character in CL @@ -453,7 +488,7 @@ string_append_char: ; Get the end of the string .get_end: mov rax, [rsi + Array.next] - cmp rax, 0 + test rax, rax jz .got_dest_end mov rsi, rax jmp .get_end From 4459835a1c7222b66be7b6b0b3dc257230ffc7ae Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 18 Nov 2017 14:34:02 +0000 Subject: [PATCH 0291/1998] Fix bug in string_append_string When copying from a long string, the wrong length was used for the source string. This caused junk to get into the destination string. --- nasm/types.asm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/nasm/types.asm b/nasm/types.asm index ee1b400c7b..5a49395cd5 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -551,7 +551,7 @@ string_append_string: mov rax, rsi .find_string_end: mov r8, QWORD [rax + Array.next] - cmp r8, 0 ; Next chunk is null + test r8, r8 ; Next chunk is 0 je .got_dest_end ; so reached end mov rax, r8 ; Go to next chunk @@ -580,7 +580,7 @@ string_append_string: ; have reached the end of the source Array mov rbx, QWORD [rbx + Array.next] ; Get the next Array address - cmp rbx, 0 ; Test if it's null + test rbx, rbx ; Test if it's null je .finished ; No more, so we're done ; Move on to next Array object @@ -589,8 +589,8 @@ string_append_string: add r10, Array.data ; Start of the data ; Source end address - mov r11, rbx - add r11, Array.size + mov r11d, DWORD [rbx + Array.length] ; Length of the array + add r11, r10 .source_ok: From 5fc8a017d96ebd9b8d252395b044839d60c4e8de Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 18 Nov 2017 23:04:53 +0000 Subject: [PATCH 0292/1998] Add quote special form Just returns its argument unmodified, but some differences in handling values and pointers needed. Added generic Makefile rule, builds step7_quote --- nasm/Makefile | 7 + nasm/step7_quote.asm | 1749 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 1756 insertions(+) create mode 100644 nasm/step7_quote.asm diff --git a/nasm/Makefile b/nasm/Makefile index 298b0e38e9..b04192b7f6 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -27,3 +27,10 @@ step5_tco: step5_tco.asm $(COMPONENTS) step6_file: step6_file.asm $(COMPONENTS) nasm -felf64 step6_file.asm ld -o $@ step6_file.o + +%.o: %.asm + nasm -felf64 $< + +%: %.o + ld -o $@ $< + diff --git a/nasm/step7_quote.asm b/nasm/step7_quote.asm new file mode 100644 index 0000000000..8834a14944 --- /dev/null +++ b/nasm/step7_quote.asm @@ -0,0 +1,1749 @@ +;; +;; nasm -felf64 step7_quote.asm && ld step7_quote.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found.",10 + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) )" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI Form to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; +;; Note: The environment in RDI will have its reference count +;; reduced by one (released). This is to make tail call optimisation easier +;; +eval: + mov r15, rdi ; Env + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .return_nil + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + mov rsi, rax + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + push rax + ; Release environment + mov rsi, r15 + call release_object + pop rax + + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; +;; Output: Result in RAX +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + push rax + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + pop rax + ret +.bind: + ; Create a new environment, binding arguments + push rax + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Release the list passed in RDX +.release: + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + pop rsi ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + push rax ; Save AST + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + push rax ; Save result of eval + + ; ------------- + ; Print + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; Release the object from read_str + pop rsi + call release_object ; Could be Cons or Array + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rsi ; AST + + push rsi + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval + pop rsi + + push rax + call release_object ; AST + pop rsi + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call rep_seq + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval-Print "(load-file )" + call rep_seq + + jmp quit From a69523e790f9b7c95f947ccd6dfd88bdff36e7ca Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 20 Nov 2017 23:37:52 +0000 Subject: [PATCH 0293/1998] Add cons, concat functions * Helper function cons_seq_copy, which copies a list or vector This is used in concat to copy prepended lists (final list not copied). * Bug fix in printer, which would segfault if the container of a Cons did not match that of the first Cons e.g. a vector in a list. * Seems to be a bug in print, which now segfaults on printing *env* --- nasm/core.asm | 201 +++++++++++++++++++++++++++++++++++++++++++++++ nasm/printer.asm | 20 +++-- nasm/types.asm | 79 +++++++++++++++++++ 3 files changed, 292 insertions(+), 8 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index caed13a94d..d2df3d386f 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -40,6 +40,10 @@ section .data static core_atomp_symbol, db "atom?" static core_reset_symbol, db "reset!" static core_swap_symbol, db "swap!" + + static core_cons_symbol, db "cons" + static core_concat_symbol, db "concat" + ;; Strings static core_emptyp_error_string, db "empty? expects a list, vector or map",10 @@ -49,6 +53,11 @@ section .data static core_deref_not_atom, db "Error: argument to deref is not an atom" static core_reset_not_atom, db "Error: argument to reset is not an atom" static core_reset_no_value, db "Error: missing value argument to reset" + + static core_cons_missing_arg, db "Error: missing argument to cons" + static core_cons_not_vector, db "Error: cons expects a list or vector" + + static core_concat_not_list, db "Error: concat expects lists or vectors" section .text ;; Add a native function to the core environment @@ -112,6 +121,9 @@ core_environment: core_env_native core_atomp_symbol, core_atomp core_env_native core_reset_symbol, core_reset core_env_native core_swap_symbol, core_swap + + core_env_native core_cons_symbol, core_cons + core_env_native core_concat_symbol, core_concat ; ----------------- ; Put the environment in RAX @@ -982,3 +994,192 @@ core_swap: .no_function: xor rsi,rsi jmp error_throw + + +;; Takes two arguments, and prepends the first argument onto the second +;; The second argument can be a list or a vector, but the return is always +;; a list +core_cons: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + mov r8, rsi ; The object to prepend + + ; Check if there's a second argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .missing_args + + mov rsi, [rsi + Cons.cdr] + + ; Check that the second argument is a list or vector + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_vector + + mov r9, [rsi + Cons.car] ; Should be a list or vector + mov al, BYTE [r9] + and al, container_mask + cmp al, container_list + je .got_args + cmp al, container_vector + je .got_args + jmp .not_vector + +.got_args: + ; Got an object in R8 and list/vector in R9 + + ;call alloc_cons + ;mov r9, rax + ;mov [r9], BYTE container_list + content_nil ;; NOTE: Segfault if list changed to vector. Printer? + + call alloc_cons ; new Cons in RAX + + ; Mark as the same content in a list container + mov bl, BYTE [r8] + and bl, content_mask + mov bh, bl ; Save content in BH for checking if pointer later + or bl, block_cons + container_list + mov [rax], BYTE bl + + ; Copy the content + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx + + ; Put the list into CDR + mov [rax + Cons.cdr], r9 + ; mark CDR as a pointer + mov [rax + Cons.typecdr], BYTE content_pointer + + push rax ; popped before return + + ; Check if the new Cons contains a pointer + cmp bh, content_pointer + jne .done + + ; A pointer, so increment number of references + mov rsi, rcx + call incref_object + +.done: + ; Increment reference count of list + mov rsi, r9 + call incref_object + pop rax + + ret + +.missing_args: + mov rsi, core_cons_missing_arg + mov edx,core_cons_missing_arg.len + jmp .throw + +.not_vector: + mov rsi, core_cons_not_vector + mov edx, core_cons_not_vector.len + +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + + +;; Concatenate lists, returning a new list +;; +;; Notes: +;; * The last list does not need to be copied, but all others do +;; +core_concat: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_pointer + jne .not_list + + ; Check if there is only one argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + je .start_loop ; Start copy loop + + ; Only one input. + ; Just increment reference count and return + + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.start_loop: ; Have at least two inputs + xor r11, r11 ; Head of list. Start in R12 + +.loop: + + ; Check the type + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_list + + ; Check if this is the last + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .last + + ; not the last list, so need to copy + + push rsi + mov rsi, [rsi + Cons.car] ; The list + call cons_seq_copy ; Copy in RAX + pop rsi + + ; Check if this is the first + test r11, r11 + jnz .append + + ; First list + mov r11, rbx ; Last Cons in list + mov r12, rax ; Output list + jmp .next +.append: + ; End of previous list points to start of new list + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + ; Put end of new list into R11 + mov r11, rbx + +.next: + mov rsi, [rsi + Cons.cdr] + jmp .loop + +.last: + ; last list, so can just prepend + mov rsi, [rsi + Cons.car] + + call incref_object + + mov [r11 + Cons.cdr], rsi + mov [r11 + Cons.typecdr], BYTE content_pointer + + mov rax, r12 ; output list + ret + +.missing_args: + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.not_list: + ; Got an argument which is not a list + mov rsi, core_concat_not_list + mov edx, core_concat_not_list.len + +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw diff --git a/nasm/printer.asm b/nasm/printer.asm index 8ea122869d..f4f37398c4 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -225,17 +225,19 @@ pr_str: je .list_check_end ; A value (nil, int etc. or function) - xor cl, container_list ; Remove list type -> value + mov ch, cl ; Save type, container + and cl, content_mask ; Remove list type -> value mov BYTE [rsi], cl + push rcx push r13 push r12 call pr_str ; String in rax pop r12 pop r13 - - mov cl, BYTE [r12] - or cl, container_list ; Restore list type + pop rcx + + mov cl, ch ; Restore list type mov BYTE [r12], cl jmp .list_loop_got_str .list_loop_pointer: @@ -434,17 +436,19 @@ pr_str: je .vector_check_end ; A value (nil, int etc. or function) - xor cl, container_vector ; Remove vector type -> value + mov ch, cl ; Save type, container + and cl, content_mask ; Remove vector type -> value mov BYTE [rsi], cl + push rcx push r13 push r12 call pr_str ; String in rax pop r12 pop r13 - - mov cl, BYTE [r12] - or cl, container_vector ; Restore vector type + pop rcx + + mov cl, ch ; Restore vector type mov BYTE [r12], cl jmp .vector_loop_got_str .vector_loop_pointer: diff --git a/nasm/types.asm b/nasm/types.asm index 5a49395cd5..9af933d660 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -388,6 +388,85 @@ incref_object: ; Check for overflow? mov [rsi + Cons.refcount], WORD ax ret + +;; ------------------------------------------- +;; Copying lists/vectors +;; This does a shallow copy, copying only the +;; top level of objects. Any objects pointed to are not copied +;; +;; Input: RSI - address of list/vector +;; +;; Returns: New list/vector in RAX, last Cons in RBX +;; +;; Modifies: +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +;; R10 +;; +cons_seq_copy: + push rsi ; Restored at the end + + mov r8, rsi ; Input in R8 + xor r9, r9 ; Head of list in R9, start in R10 +.loop: + ; Check the type + mov cl, BYTE [r8] + mov ch, cl + and ch, block_mask + jnz .not_seq ; Not a Cons object + + call alloc_cons + mov rdx, rax ; New Cons in RDX + mov [rdx], BYTE cl ; Copy type in RCX + mov rbx, [r8 + Cons.car] ; Value in RBX + mov [rdx + Cons.car], rbx ; Copy value + + and cl, content_mask + cmp cl, content_pointer + jne .copied + + ; A pointer, so increment the reference count + mov rsi, rbx + call incref_object + +.copied: + ; Check if this is the first + test r9,r9 + jnz .append + + ; First Cons + mov r9, rdx + mov r10, rdx ; Start of the list, will be returned + jmp .next + +.append: + ; Appending to last Cons + mov [r9 + Cons.cdr], rdx + mov [r9 + Cons.typecdr], BYTE content_pointer + ; Replace + mov r9, rdx + +.next: + ; Check if there's another + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .done ; No more + ; Got another + mov r8, [r8 + Cons.cdr] + jmp .loop + +.done: + pop rsi ; Restore input + mov rax, r10 ; Output list + mov rbx, r9 ; Last Cons + ret + +.not_seq: + xor rsi,rsi + jmp error_throw ;; ------------------------------------------- ;; String type From 12ab92c37936321e12a258c96d3d483b0e84be6b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 21 Nov 2017 12:00:25 +0000 Subject: [PATCH 0294/1998] Fix bugs in string manipulation Handling corner cases when string chunks (Arrays) are full. This caused segfaults if string lengths hit magic numbers. --- nasm/core.asm | 4 ++-- nasm/printer.asm | 20 +++++++++++--------- nasm/types.asm | 10 +++++++--- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index d2df3d386f..61d04ad34b 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1169,9 +1169,9 @@ core_concat: ret .missing_args: - ; Return nil + ; Return empty list call alloc_cons - mov [rax], BYTE maltype_nil + mov [rax], BYTE maltype_empty_list ret .not_list: diff --git a/nasm/printer.asm b/nasm/printer.asm index f4f37398c4..2d7b8cf080 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -265,8 +265,8 @@ pr_str: .list_check_end: ; Check if this is the end of the list mov cl, BYTE [r12 + Cons.typecdr] - cmp cl, content_nil - je .list_finished + cmp cl, content_pointer + jne .list_finished ; More left in the list @@ -344,18 +344,20 @@ pr_str: je .map_check_end ; A value (nil, int etc. or function) - xor cl, container_map ; Remove map type -> value - mov BYTE [rsi], cl + xchg ch, cl + mov [rsi], BYTE cl ; Remove map type -> value + xchg ch, cl + push rcx push r13 push r12 call pr_str ; String in rax pop r12 pop r13 + pop rcx + + mov cl, BYTE [r12] ; Restore map type - mov cl, BYTE [r12] - or cl, container_map ; Restore map type - mov BYTE [r12], cl jmp .map_loop_got_str .map_loop_pointer: mov rsi, [rsi + Cons.car] ; Address of object @@ -476,8 +478,8 @@ pr_str: .vector_check_end: ; Check if this is the end of the vector mov cl, BYTE [r12 + Cons.typecdr] - cmp cl, content_nil - je .vector_finished + cmp cl, content_pointer + jne .vector_finished ; More left in the vector diff --git a/nasm/types.asm b/nasm/types.asm index 9af933d660..089240abf1 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -160,7 +160,7 @@ section .data heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 300 ; Number of array objects which can be created +%define heap_array_limit 1000 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 @@ -622,8 +622,8 @@ string_append_string: mov r8d, DWORD [rbx + Array.length] add r11, r8 - cmp r8d, 0 - je .return ; Appending zero-size array + test r8d, r8d + jz .return ; Appending zero-size array ; Find the end of the string in RSI ; and put the address of the Array object into rax @@ -645,6 +645,10 @@ string_append_string: ; destination data end into r9 mov r9, rax add r9, Array.size + + ; Check if we are at the end of the destination + cmp r8, r9 + je .alloc_dest .copy_loop: ; Copy one byte from source to destination From 6b0641cbab6fee2ca2cf98485db61940884bd37b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 22 Nov 2017 23:29:46 +0000 Subject: [PATCH 0295/1998] Working on quasiquote. Not yet done Quoting not yet working properly, so symbols in the input AST are evaluated when they should not be. Example failing test: (quasiquote (1 a 3)) The quasiquote function turns this into (cons 1 (cons a (quote (3)))) rather than (cons 1 (cons (quote a) (quote (3)))) --- nasm/core.asm | 19 ++- nasm/macros.mac | 1 + nasm/step7_quote.asm | 392 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 409 insertions(+), 3 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 61d04ad34b..c688992098 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1130,11 +1130,18 @@ core_concat: cmp al, content_pointer jne .last + ; Check if the list is empty + mov rbx, [rsi + Cons.car] ; The list + mov al, BYTE [rbx] + and al, content_mask + cmp al, content_empty ; If empty list or vector + je .next ; Skip to next + ; not the last list, so need to copy push rsi - mov rsi, [rsi + Cons.car] ; The list - call cons_seq_copy ; Copy in RAX + mov rsi, rbx ; The list + call cons_seq_copy ; Copy in RAX, last Cons in RBX pop rsi ; Check if this is the first @@ -1159,12 +1166,18 @@ core_concat: .last: ; last list, so can just prepend mov rsi, [rsi + Cons.car] + + ; Check if the list is empty + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty ; If empty list or vector + je .done ; Omit the empty list call incref_object mov [r11 + Cons.cdr], rsi mov [r11 + Cons.typecdr], BYTE content_pointer - +.done: mov rax, r12 ; output list ret diff --git a/nasm/macros.mac b/nasm/macros.mac index 5f0d5fda90..f3db819bdf 100644 --- a/nasm/macros.mac +++ b/nasm/macros.mac @@ -25,6 +25,7 @@ %1: ISTRUC Array AT Array.type, db maltype_symbol + AT Array.refcount, dw 1 AT Array.length, dd slen AT Array.data, db %2 IEND diff --git a/nasm/step7_quote.asm b/nasm/step7_quote.asm index 8834a14944..2295012c3b 100644 --- a/nasm/step7_quote.asm +++ b/nasm/step7_quote.asm @@ -62,6 +62,10 @@ section .data static_symbol quote_symbol, 'quote' static_symbol quasiquote_symbol, 'quasiquote' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) )" @@ -716,6 +720,9 @@ eval: eval_cmp_symbol quote_symbol ; quote je .quote_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol ; Unrecognised jmp .list_eval @@ -1381,6 +1388,50 @@ eval: ; ----------------------------- +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + call quasiquote + ret + + push r15 ; Environment + push r11 ; Original AST + call quasiquote + ; New AST in RAX + pop rsi ; Old AST + push rax + call release_object ; Release old AST + pop rsi + pop rdi ; Environment + + jmp eval ; Tail call + + ; ----------------------------- + .list_eval: push rsi mov rdi, r15 ; Environment @@ -1523,8 +1574,349 @@ apply_fn: jmp eval ; Tail call ; The new environment (in RDI) will be released by eval + + +;; Set ZF if RSI is a non-empty list or vector +;; Modifies RAX, does not modify RSI +is_pair: + mov al, BYTE [rsi] + test al, block_mask + jnz .false ; Not a Cons + cmp al, maltype_empty_list + je .false ; Empty list + cmp al, maltype_empty_vector + je .false ; Empty vector + + ; Something non empty + and al, container_mask + cmp al, container_list + jmp .true + cmp al, container_vector + jmp .true + ; Not a list or vector -> false + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + ret + +;; Called by eval with AST in RSI +quasiquote: + ; i. Check if AST is an empty list + call is_pair + jne .quote_ast + + ; ii. Check if the first element of RSI is the symbol + ; 'unquote' + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_unquote ; Not a pointer + mov rdi, [rsi + Cons.car] ; Get the pointer + mov cl, BYTE [rdi] + cmp cl, maltype_symbol + jne .not_unquote + + ; Compare against 'unquote' + mov r8, rsi + mov r9, rax + + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + + mov rax, r9 + mov rsi, r8 + + je .unquote + +.not_unquote: + ; iii. Handle splice-unquote + ; RSI -> ( ( splice-unquote ? ) ? ) + + ; Test if RSI contains a pointer + + cmp al, content_pointer + jne .not_splice + + mov rbx, [rsi + Cons.car] ; Get the object pointer + + ; RBX -> ( splice-unquote ? ) + + xchg rbx, rsi + call is_pair + xchg rbx, rsi + jne .not_splice ; First element not a pair + + ; Check if this list in RBX starts with 'splice-unquote' symbol + mov al, BYTE [rbx] + and al, content_mask + cmp al, content_pointer + jne .not_splice + + + mov rdi, [rbx + Cons.car] ; Get the pointer + mov al, BYTE [rdi] + cmp al, maltype_symbol + jne .not_splice + + mov r8, rsi + mov r9, rbx + + ; Compare against 'splice-unquote' + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + + mov rbx, r9 + mov rsi, r8 + + je .splice_unquote + +.not_splice: + + ; iv. Cons first and rest of AST in RSI + + ; Check if this is the end of the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .quote_ast ; Put in quote + + ; Not the end of the AST, so need to cons + ; check if pointer or value + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .cons_pointer + + ; a value, so copy + call alloc_cons + or cl, container_list + mov [rax], BYTE cl ; List + Content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + mov rcx, rax + jmp .cons_first + +.cons_pointer: + ; Get the pointer and increment references + mov rcx, [rsi + Cons.car] + xchg rcx, rsi + call incref_object + xchg rcx, rsi ; Object in RCX + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx ; The value + mov rcx, rax + +.cons_first: + ; Have Cons with first object in RCX + + ; Call quasiquote on the rest of the AST + push rcx + mov rsi, [rsi + Cons.cdr] + call quasiquote + mov rdx, rax ; List in RDX + pop rcx ; Value in RCX + + ; cons RCX and RDX + ; Work from the end of the list to the front + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + + ; Link to the RCX Cons + mov [rcx + Cons.typecdr], BYTE content_pointer + mov [rcx + Cons.cdr], rax + mov rdx, rcx + + call alloc_cons ; Cons for cons symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the cons symbol + mov rsi, cons_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.quote_ast: + ; Return (quote RSI) + + call incref_object ; RSI reference count + + ; Cons for RSI + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rsi, rax + + ; Cons for quote symbol + call alloc_cons + mov rbx, rax + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rsi + + ; Get a quote symbol, incrementing references + mov rsi, quote_symbol + call incref_object + + ; Put into the Cons in RBX + mov [rbx + Cons.car], rsi + mov [rbx], BYTE (block_cons + container_list + content_pointer) + mov rax, rbx + ret + ; ----------------------- + +.unquote: + + ; Got unquote symbol. Return second element of RSI + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; No second element + + mov rsi, [rsi + Cons.cdr] + + ; Check if it's a value or pointer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .unquote_pointer + + ; A value, so need a new Cons + call alloc_cons + mov [rax], BYTE cl ; content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Copy content + ret + +.unquote_pointer: + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + + ; ----------------------- +.splice_unquote: + ; RSI -> ( RBX->( splice-unquote A ) B ) + ; + ; RBX Car points to splice-unquote symbol + + ; Check if there is anything after the symbol + mov al, BYTE [rbx + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_empty + + ; Point to the second element of the splice-unquote list + mov rcx, [rbx + Cons.cdr] + + ; Check whether it's a value or pointer + mov al, BYTE [rcx] + and al, content_mask + cmp al, content_pointer + je .splice_unquote_pointer + + ; A value, so change the container to a value + mov [rcx], BYTE al + ; Remove pointer from RBX + mov [rbx + Cons.typecdr], BYTE 0 + jmp .splice_unquote_first ; Got the value in RCX + +.splice_unquote_pointer: + mov rcx, [rcx + Cons.car] ; Get the object pointed to + xchg rcx, rsi + call incref_object + xchg rcx, rsi ; Object in RCX + +.splice_unquote_first: ; Got the first object in RCX + + ; Check if RSI contains anything else + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_notail + + mov rsi, [rsi + Cons.cdr] + + ; Now have: + ; ( ( splice-unquote A ) B ) + ; RCX->A RSI->( B ) + ; Need to call quasiquote on the rest of the list + push rcx + call quasiquote + mov rdx, rax + pop rcx + ; Need to concat rcx and rdx + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + mov rdx, rax ; Push list into RDX + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx ; The splice-unquote object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + call alloc_cons ; Cons for concat symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the concat symbol + mov rsi, concat_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.splice_unquote_notail: + ; Just return the object in RCX + ; since nothing to concatenate with + mov rax, rcx + ret + +.splice_unquote_empty: + ; Nothing in the (splice-unquote) list, so ignore + ; Just call quasiquote on the rest of RSI + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; Nothing else + + mov rsi, [rsi + Cons.cdr] + jmp quasiquote ; Tail call + +.empty_list: + ; Return an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + + + + + ;; Read-Eval-Print in sequence ;; ;; Input string in RSI From 8d054892e11424beb6d7bd6197e99bb6049ea0f6 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 23 Nov 2017 00:06:34 +0000 Subject: [PATCH 0296/1998] quasiquote tests pass Needed to call quasiquote with first AST element, which then wrapped symbol in (quote ) Two tests still failing. One for cons with empty list, and another due to concat returning a vector --- nasm/step7_quote.asm | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/nasm/step7_quote.asm b/nasm/step7_quote.asm index 2295012c3b..5ca4a90a04 100644 --- a/nasm/step7_quote.asm +++ b/nasm/step7_quote.asm @@ -1415,8 +1415,8 @@ eval: ; RSI contains a pointer, so get the object pointed to mov rsi, [rsi + Cons.car] - call quasiquote - ret + ;call quasiquote + ;ret push r15 ; Environment push r11 ; Original AST @@ -1707,15 +1707,16 @@ quasiquote: jmp .cons_first .cons_pointer: - ; Get the pointer and increment references - mov rcx, [rsi + Cons.car] - xchg rcx, rsi - call incref_object - xchg rcx, rsi ; Object in RCX - + ; Get the pointer and call quasiquote + push rsi + mov rsi, [rsi + Cons.car] + call quasiquote + mov rcx, rax + pop rsi + call alloc_cons mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.car], rcx ; The value + mov [rax + Cons.car], rcx mov rcx, rax .cons_first: From 181dd159a3f4106d78c96d0dbf0b5f0285615912 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 24 Nov 2017 22:51:39 +0000 Subject: [PATCH 0297/1998] All step 7 tests pass concat sets the container type so that return is always a list. NOTE: The container type of every Cons is not changed, so if the list is sliced then the pieces may be vectors or lists. --- nasm/core.asm | 65 ++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 59 insertions(+), 6 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index c688992098..8d3544b5a7 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1031,10 +1031,6 @@ core_cons: .got_args: ; Got an object in R8 and list/vector in R9 - - ;call alloc_cons - ;mov r9, rax - ;mov [r9], BYTE container_list + content_nil ;; NOTE: Segfault if list changed to vector. Printer? call alloc_cons ; new Cons in RAX @@ -1048,12 +1044,19 @@ core_cons: ; Copy the content mov rcx, [r8 + Cons.car] mov [rax + Cons.car], rcx + + ; Check if R9 is empty + mov cl, BYTE [r9] + and cl, content_mask + cmp cl, content_empty + je .end_append ; Don't append the list ; Put the list into CDR mov [rax + Cons.cdr], r9 ; mark CDR as a pointer mov [rax + Cons.typecdr], BYTE content_pointer +.end_append: push rax ; popped before return ; Check if the new Cons contains a pointer @@ -1107,9 +1110,52 @@ core_concat: je .start_loop ; Start copy loop ; Only one input. + mov rsi, [rsi + Cons.car] + + ; Check if it's a list or vector + mov al, BYTE [rsi] + mov cl, al + and al, container_mask + cmp al, (block_cons + container_list) + je .single_list + + cmp al, (block_cons + container_vector) + jne .not_list ; not a list or vector + + ; A vector. Need to create a new Cons + ; for the first element, to mark it as a list + + call alloc_cons + and cl, content_mask + or cl, container_list + mov [rax], BYTE cl ; Set type + + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Set content + + mov dl, BYTE [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], BYTE dl ; CDR type + + mov rbx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rbx ; Set CDR content + + ; Check if CDR is a pointer + cmp dl, content_pointer + je .single_vector_incref + ; not a pointer, just return + ret + +.single_vector_incref: + ; increment the reference count of object pointed to + mov r12, rax ; The return Cons + mov rsi, rbx ; The object address + call incref_object + mov rax, r12 + ret + +.single_list: ; Just increment reference count and return - mov rsi, [rsi + Cons.car] call incref_object mov rax, rsi ret @@ -1164,11 +1210,12 @@ core_concat: jmp .loop .last: - ; last list, so can just prepend + ; last list, so can just append mov rsi, [rsi + Cons.car] ; Check if the list is empty mov al, BYTE [rsi] + mov ah, al and al, content_mask cmp al, content_empty ; If empty list or vector je .done ; Omit the empty list @@ -1178,7 +1225,13 @@ core_concat: mov [r11 + Cons.cdr], rsi mov [r11 + Cons.typecdr], BYTE content_pointer .done: + ; Make sure that return is a list + mov bl, BYTE [r12] + and bl, content_mask + or bl, container_list + mov [r12], BYTE bl mov rax, r12 ; output list + ret .missing_args: From 4a99a16c415c3c0d91127480d633b5153756d816 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 27 Nov 2017 14:07:00 +0000 Subject: [PATCH 0298/1998] Adding test to step7 for quasiquote Handling of the last element of the AST is tested by having an unquote as the last element. --- tests/step7_quote.mal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index bd5b22fe6f..973acbc743 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -72,7 +72,8 @@ b ;=>(1 b 3) (quasiquote (1 (unquote b) 3)) ;=>(1 (1 "b" "d") 3) - +(quasiquote ((unquote 1) (unquote 2))) +;=>(1 2) ;; Testing splice-unquote (def! c (quote (1 "b" "d"))) From 5ad295bd9d73c6903a5aa2b14099140e2983b7af Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 27 Nov 2017 15:51:15 +0000 Subject: [PATCH 0299/1998] Fix cons and quasiquote functions * Better handling of the final element in quasiquote * Cons now increments reference counts of objects pointed to so they are not accidentally deleted Now passes step7 tests again, including new test --- nasm/core.asm | 28 +++++++++++++++------------- nasm/step7_quote.asm | 38 +++++++++++++++++++++++++++----------- 2 files changed, 42 insertions(+), 24 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 8d3544b5a7..ec446f5857 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1042,13 +1042,13 @@ core_cons: mov [rax], BYTE bl ; Copy the content - mov rcx, [r8 + Cons.car] + mov rcx, [r8 + Cons.car] ; Content in RCX mov [rax + Cons.car], rcx ; Check if R9 is empty - mov cl, BYTE [r9] - and cl, content_mask - cmp cl, content_empty + mov dl, BYTE [r9] + and dl, content_mask + cmp dl, content_empty je .end_append ; Don't append the list ; Put the list into CDR @@ -1056,23 +1056,25 @@ core_cons: ; mark CDR as a pointer mov [rax + Cons.typecdr], BYTE content_pointer -.end_append: - push rax ; popped before return + ; Increment reference count + push rax + mov rsi, r9 + call incref_object + pop rax +.end_append: ; Check if the new Cons contains a pointer - cmp bh, content_pointer + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer jne .done ; A pointer, so increment number of references + push rax mov rsi, rcx call incref_object - -.done: - ; Increment reference count of list - mov rsi, r9 - call incref_object pop rax - +.done: ret .missing_args: diff --git a/nasm/step7_quote.asm b/nasm/step7_quote.asm index 5ca4a90a04..6f80eb23e2 100644 --- a/nasm/step7_quote.asm +++ b/nasm/step7_quote.asm @@ -1590,11 +1590,11 @@ is_pair: ; Something non empty and al, container_mask cmp al, container_list - jmp .true + je .true cmp al, container_vector - jmp .true + je .true ; Not a list or vector -> false - + .false: lahf ; flags in AH and ah, 255-64 ; clear zero flag @@ -1685,12 +1685,6 @@ quasiquote: ; iv. Cons first and rest of AST in RSI - ; Check if this is the end of the list - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .quote_ast ; Put in quote - - ; Not the end of the AST, so need to cons ; check if pointer or value mov cl, BYTE [rsi] and cl, content_mask @@ -1723,12 +1717,34 @@ quasiquote: ; Have Cons with first object in RCX ; Call quasiquote on the rest of the AST + ; Check if this is the end of the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .cons_ast_end + + mov rsi, [rsi + Cons.cdr] ; Rest of the list + + call incref_object ; Will release after quasiquote call + + jmp .cons_quasiquote_ast + +.cons_ast_end: + ; End of the AST, so make an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax + +.cons_quasiquote_ast: push rcx - mov rsi, [rsi + Cons.cdr] + push rsi call quasiquote mov rdx, rax ; List in RDX + + pop rsi + call release_object ; Release input + pop rcx ; Value in RCX - + ; cons RCX and RDX ; Work from the end of the list to the front From 08caa2faa063f9ec31106630f1f0b6b2c426146e Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 28 Nov 2017 15:03:13 +0000 Subject: [PATCH 0300/1998] Adding core first function Returns the first element of a list or vector --- nasm/core.asm | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index ec446f5857..805bcd5b6b 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -43,6 +43,8 @@ section .data static core_cons_symbol, db "cons" static core_concat_symbol, db "concat" + + static core_first_symbol, db "first" ;; Strings @@ -58,6 +60,9 @@ section .data static core_cons_not_vector, db "Error: cons expects a list or vector" static core_concat_not_list, db "Error: concat expects lists or vectors" + + static core_first_missing_arg, db "Error: missing argument to first" + static core_first_not_list, db "Error: first expects a list or vector" section .text ;; Add a native function to the core environment @@ -125,6 +130,8 @@ core_environment: core_env_native core_cons_symbol, core_cons core_env_native core_concat_symbol, core_concat + core_env_native core_first_symbol, core_first + ; ----------------- ; Put the environment in RAX mov rax, rsi @@ -1251,3 +1258,78 @@ core_concat: call raw_to_string mov rsi, rax jmp error_throw + + +;; Returns the first element of a list +;; +core_first: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_nil + je .return_nil + + cmp al, content_pointer + jne .not_list + + ; Get the list + mov rsi, [rsi + Cons.car] + + mov al, BYTE [rsi] + + ; Check for nil + cmp al, maltype_nil + je .return_nil + + mov ah, al + and ah, (block_mask + container_mask) + cmp ah, container_list + je .got_list + cmp ah, container_vector + jne .not_list ; Not a list or vector + +.got_list: + ; Check if list is empty + and al, content_mask + cmp al, content_empty + je .return_nil + + cmp al, content_pointer + je .return_pointer + + ; Returning a value, so need to copy + mov cl, al + call alloc_cons + mov [rax], BYTE cl ; Set type + + ; Copy value + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + ret + +.return_pointer: + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.missing_args: + mov rsi, core_first_missing_arg + mov edx, core_first_missing_arg.len + jmp .throw + +.not_list: + mov rsi, core_first_not_list + mov edx, core_first_not_list.len +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + From f2030f86968e726bc6c87db46b72568f965a68f0 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 28 Nov 2017 15:08:34 +0000 Subject: [PATCH 0301/1998] Fix raw_to_string function for long strings Previously assumed that the string would fit into a single Array object. Now handles the allocation of a chain of Array objects. --- nasm/types.asm | 56 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 53 insertions(+), 3 deletions(-) diff --git a/nasm/types.asm b/nasm/types.asm index 089240abf1..7352c7499e 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -130,7 +130,7 @@ ENDSTRUC %define maltype_empty_map (block_cons + container_map + content_empty) %define maltype_empty_vector (block_cons + container_vector + content_empty) %define maltype_function (block_cons + container_function + content_function) -%define maltype_macro (block_cons + container_macro + content_function) +%define maltype_macro (block_cons + container_function + content_macro) %define maltype_true (block_cons + container_value + content_true) %define maltype_false (block_cons + container_value + content_false) %define maltype_atom (block_cons + container_atom + content_pointer) @@ -489,25 +489,75 @@ string_new: ;; Output: Address of string in RAX ;; ;; Modifies registers: R8,R9,RCX +;; raw_to_string: + ; Save registers to restore at the end + push r10 + push r11 + push rsi push rdx call string_new ; String now in RAX pop rdx pop rsi - mov [rax + Array.length], DWORD edx + mov r8, rax add r8, Array.data ; Address of string data + mov r10, rax + add r10, Array.size ; End of the destination data + mov r11, rax ; First Array to return + mov r9, rsi ; Address of raw data mov ecx, edx ; Count + .copy_loop: + test ecx, ecx ; Check if count is zero + jz .done + ; Copy one byte mov bl, BYTE [r9] mov [r8], BYTE bl + + ; Move the destination inc r8 + cmp r8, r10 + jne .dest_ok + + ; Hit the end. Set the length of the array + mov [rax + Array.length], DWORD (array_chunk_len * 8) + + push rax ; Last Array + push rsi + push rdx + call string_new ; String now in RAX + pop rdx + pop rsi + pop rbx ; Last Array + mov [rbx + Array.next], rax ; Point to new Array + + mov r8, rax + add r8, Array.data ; Address of string data + mov r10, rax + add r10, Array.size ; End of the destination data + +.dest_ok: + inc r9 dec ecx - jnz .copy_loop + jmp .copy_loop +.done: + ; Set the length of the destination array + sub r8, Array.data + sub r8, rax + mov [rax + Array.length], DWORD r8d + + ; Move first Array into RAX + mov rax, r11 + + ; Restore registers + pop r11 + pop r10 + ret ;; Convert a raw string to a symbol From 07ac7a27141cfcedf9d9236c682e67ef3f2c9791 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 28 Nov 2017 16:16:53 +0000 Subject: [PATCH 0302/1998] Adding nth and rest functions nth returns an element at given index in a list. rest returns a list or vector with the first element removed. Currently this works by just returning a pointer to the second element. --- nasm/core.asm | 183 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 183 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index 805bcd5b6b..3d05131490 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -45,6 +45,8 @@ section .data static core_concat_symbol, db "concat" static core_first_symbol, db "first" + static core_rest_symbol, db "rest" + static core_nth_symbol, db "nth" ;; Strings @@ -63,6 +65,15 @@ section .data static core_first_missing_arg, db "Error: missing argument to first" static core_first_not_list, db "Error: first expects a list or vector" + + static core_rest_missing_arg, db "Error: missing argument to rest" + static core_rest_not_list, db "Error: rest expects a list or vector" + + static core_nth_missing_arg, db "Error: missing argument to nth" + static core_nth_not_list, db "Error: nth expects a list or vector as first argument" + static core_nth_not_int, db "Error: nth expects an integer as second argument" + static core_nth_out_of_range, db "Error: nth index out of range" + section .text ;; Add a native function to the core environment @@ -131,6 +142,9 @@ core_environment: core_env_native core_concat_symbol, core_concat core_env_native core_first_symbol, core_first + core_env_native core_rest_symbol, core_rest + core_env_native core_nth_symbol, core_nth + ; ----------------- ; Put the environment in RAX @@ -1333,3 +1347,172 @@ core_first: mov rsi, rax jmp error_throw + +;; Return a list with the first element removed +core_rest: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_nil + je .return_nil + + cmp al, content_pointer + jne .not_list + + ; Get the list + mov rsi, [rsi + Cons.car] + + mov al, BYTE [rsi] + + ; Check for nil + cmp al, maltype_nil + je .return_nil + + mov ah, al + and ah, (block_mask + container_mask) + cmp ah, container_list + je .got_list + cmp ah, container_vector + jne .not_list ; Not a list or vector + +.got_list: + ; Check if list is empty + and al, content_mask + cmp al, content_empty + je .empty_list + + ; Check if there is more in the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + je .return_rest + + ; No more list, so return empty list +.empty_list: + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +.return_rest: + + mov rsi, [rsi + Cons.cdr] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.missing_args: + mov rsi, core_rest_missing_arg + mov edx, core_rest_missing_arg.len + jmp .throw + +.not_list: + mov rsi, core_rest_not_list + mov edx, core_rest_not_list.len +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + + +;; Return the nth element of a list or vector +core_nth: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_nil + je .return_nil + + cmp al, content_pointer + jne .not_list + + ; Get the list into R8 + mov r8, [rsi + Cons.car] + + ; Check if we have a second argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .missing_args + + mov r9, [rsi + Cons.cdr] + + ; Check that it is a number + mov al, BYTE [r9] + and al, content_mask + cmp al, content_int + jne .not_int + + ; Get the number in RBX + mov rbx, [r9 + Cons.car] + + ; Now loop through the list, moving along n elements +.loop: + test rbx, rbx ; Test if zero + jz .done + + ; Move along next element + + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .out_of_range ; No element + + mov r8, [r8 + Cons.cdr] + dec rbx + jmp .loop + +.done: + ; Take the head of the list in R8 + mov al, BYTE [r8] + and al, content_mask + cmp al, content_pointer + je .return_pointer + + ; Copy a value + mov cl, al + call alloc_cons + mov [rax], BYTE cl + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx + ret + +.return_pointer: + mov rsi, [r8 + Cons.car] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.missing_args: + mov rsi, core_nth_missing_arg + mov edx, core_nth_missing_arg.len + jmp .throw + +.not_list: + mov rsi, core_nth_not_list + mov edx, core_nth_not_list.len + jmp .throw + +.not_int: + mov rsi, core_nth_not_int + mov edx, core_nth_not_int.len + jmp .throw + +.out_of_range: + mov rsi, core_nth_out_of_range + mov edx, core_nth_out_of_range.len + +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw From 6df6dfd35886ad3c27688afdcb1dd5ae28ec9956 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 29 Nov 2017 15:13:10 +0000 Subject: [PATCH 0303/1998] Fix memory leak, eval releases AST Quasiquote (and macroexpand) replace the AST in eval. This makes releasing the memory harder, so could give rise to both double-frees, and memory leaks. Eval now releases both its environment (for tail calls) and the AST. --- nasm/core.asm | 9 +-- nasm/step7_quote.asm | 146 +++++++++++++++++++++++++++++++------------ 2 files changed, 112 insertions(+), 43 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 3d05131490..eb72711a28 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -699,14 +699,15 @@ core_eval: .pointer: ; A pointer, so need to eval - mov rsi, [rsi + Cons.car] + mov rdi, [rsi + Cons.car] - mov rdi, [repl_env] ; Environment + mov rsi, [repl_env] ; Environment - xchg rsi, rdi call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval + xchg rsi, rdi ; Env in RDI, AST in RSI + call incref_object ; AST increment refs + call eval ret diff --git a/nasm/step7_quote.asm b/nasm/step7_quote.asm index 6f80eb23e2..2b71b70aa4 100644 --- a/nasm/step7_quote.asm +++ b/nasm/step7_quote.asm @@ -69,7 +69,9 @@ section .data ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) )" - + + ;static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) )" + ;; Command to run, appending the name of the script to run static run_script_string, db "(load-file ",34 section .text @@ -307,12 +309,13 @@ eval_ast: push r8 push r9 push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 - xchg rsi, rdi call incref_object ; Environment increment refs - xchg rsi, rdi + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs call eval ; Evaluate it, result in rax pop r15 @@ -476,6 +479,8 @@ eval_ast: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi + + call incref_object call eval ; Evaluate it, result in rax pop r15 @@ -564,6 +569,8 @@ eval_ast: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi + + call incref_object call eval ; Evaluate it, result in rax pop r15 @@ -659,16 +666,19 @@ eval_ast: ;; ---------------------------------------------------- ;; Evaluates a form ;; -;; Input: RSI Form to evaluate -;; RDI Environment +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] ;; ;; Returns: Result in RAX ;; -;; Note: The environment in RDI will have its reference count -;; reduced by one (released). This is to make tail call optimisation easier +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) ;; eval: mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return ; Check type mov al, BYTE [rsi] @@ -790,6 +800,8 @@ eval: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs call eval mov rsi, rax @@ -916,6 +928,9 @@ eval: push r13 ; symbol to bind push r14 ; new environment mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + mov rdi, r14 call eval ; Evaluate it, result in rax pop r14 @@ -968,6 +983,13 @@ eval: ; Evaluate using new environment mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + mov rdi, r14 ; New environment jmp eval ; Tail call @@ -979,6 +1001,12 @@ eval: mov rsi, r14 call release_object pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax ret ; already released env .let_error_missing_bindings: @@ -1061,6 +1089,8 @@ eval: ; since eval will release Env mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + mov rdi, r15 ; Env call eval ; Result in RAX @@ -1103,14 +1133,29 @@ eval: mov [rax], BYTE bl mov rbx, [r11 + Cons.car] mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + ret .do_body_expr_return: ; An expression to evaluate as the last form ; Tail call optimise, jumping to eval ; Don't increment Env reference count + + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 - mov rsi, [r11 + Cons.car] ; Form mov rdi, r15 ; Env jmp eval ; Tail call @@ -1119,6 +1164,10 @@ eval: mov rsi, r15 call release_object ; Release Env + + ; release the AST + pop rsi + call release_object call alloc_cons mov [rax], BYTE maltype_nil @@ -1152,6 +1201,8 @@ eval: call incref_object ; Increase Env reference mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + mov rdi, r15 ; Env call eval ; Result in RAX pop r11 @@ -1219,6 +1270,13 @@ eval: .if_got_pointer: mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + mov rdi, r15 ; Env jmp eval ; Tail call @@ -1239,12 +1297,16 @@ eval: mov [rax + Cons.typecdr], BYTE content_nil .return: - push rax ; Release environment mov rsi, r15 + mov r15, rax ; Save RAX (return value) call release_object - pop rax - + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value ret ; ----------------------------- @@ -1419,15 +1481,17 @@ eval: ;ret push r15 ; Environment - push r11 ; Original AST + ; Original AST already on stack + call quasiquote ; New AST in RAX - pop rsi ; Old AST - push rax - call release_object ; Release old AST - pop rsi pop rdi ; Environment + pop rsi ; Old AST + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + jmp eval ; Tail call ; ----------------------------- @@ -1520,6 +1584,9 @@ eval: ;; R15 - Env (will be released) ;; ;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval apply_fn: push rsi ; Extract values from the list in RDI @@ -1537,7 +1604,8 @@ apply_fn: jnz .bind ; Just a value (in RAX). No eval needed - push rax + mov r14, rax ; Save return value in R14 + mov rsi, rax call incref_object @@ -1548,12 +1616,16 @@ apply_fn: ; Release the environment mov rsi, r15 call release_object + + ; Release the AST, pushed at start of eval + pop rsi + call release_object - pop rax + mov rax, r14 ret .bind: ; Create a new environment, binding arguments - push rax + push rax ; Body push rdx call env_new_bind @@ -1571,6 +1643,7 @@ apply_fn: call release_object pop rsi ; Body + call incref_object ; Will be released by eval jmp eval ; Tail call ; The new environment (in RDI) will be released by eval @@ -1606,7 +1679,9 @@ is_pair: sahf ret -;; Called by eval with AST in RSI +;; Called by eval with AST in RSI [ modified ] +;; Returns new AST in RAX + quasiquote: ; i. Check if AST is an empty list call is_pair @@ -1941,8 +2016,7 @@ rep_seq: ; ------------- ; Read call read_str - push rax ; Save AST - + ; ------------- ; Eval mov rsi, rax ; Form to evaluate @@ -1952,7 +2026,7 @@ rep_seq: call incref_object ; Environment increment refs xchg rsi, rdi ; since it will be decremented by eval - call eval + call eval ; This releases Env and Form/AST push rax ; Save result of eval ; ------------- @@ -1975,9 +2049,8 @@ rep_seq: pop rsi call release_object - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array + ; The AST from read_str is released by eval + ret @@ -2006,21 +2079,16 @@ _start: push rax ; AST call release_array ; string - pop rsi ; AST - - push rsi - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval + xchg rsi, rdi ; Env in RDI, AST in RSI call eval - pop rsi - push rax - call release_object ; AST - pop rsi + mov rsi, rax call release_object ; Return from eval ; ----------------------------- From d00896dcadfd634d7c38670bed1796291eef182d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 30 Nov 2017 00:20:25 +0000 Subject: [PATCH 0304/1998] step 8 macros * Added macroexpand functions and special symbol * Some changes to how AST is freed by apply_fn, to avoid having to shuffle the stack after a call. 7 failing tests. "rest" can return vector or list, but should always return a list. Other errors in -> and ->> macros seem more difficult to solve. --- nasm/core.asm | 2 +- nasm/printer.asm | 15 +- nasm/step8_macros.asm | 2453 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 2467 insertions(+), 3 deletions(-) create mode 100644 nasm/step8_macros.asm diff --git a/nasm/core.asm b/nasm/core.asm index eb72711a28..dc94c95f23 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1357,7 +1357,7 @@ core_rest: je .missing_args cmp al, content_nil - je .return_nil + je .empty_list cmp al, content_pointer jne .not_list diff --git a/nasm/printer.asm b/nasm/printer.asm index 2d7b8cf080..21e72ee7a8 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -10,6 +10,7 @@ section .data static unknown_type_string, db "#" static unknown_value_string, db "#" static function_type_string, db "#" + static macro_type_string, db "#" static nil_value_string, db "nil" static true_value_string, db "true" static false_value_string, db "false" @@ -138,7 +139,7 @@ pr_str: je .vector cmp ch, container_function - je .function + je .function_or_macro cmp ch, container_atom je .atom @@ -502,12 +503,22 @@ pr_str: ret ; -------------------------------- -.function: +.function_or_macro: + cmp cl, maltype_macro + je .macro + + ; a function mov rsi, function_type_string mov edx, function_type_string.len call raw_to_string ; Puts a String in RAX ret +.macro: + mov rsi, macro_type_string + mov edx, macro_type_string.len + call raw_to_string ; Puts a String in RAX + ret + ; -------------------------------- .atom: mov rsi, [rsi + Cons.car] ; What the atom points to diff --git a/nasm/step8_macros.asm b/nasm/step8_macros.asm new file mode 100644 index 0000000000..b0d1714bbb --- /dev/null +++ b/nasm/step8_macros.asm @@ -0,0 +1,2453 @@ +;; +;; nasm -felf64 step8_macros.asm && ld step8_macros.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found.",10 + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static defmacro_expecting_function_string, db "defmacro expects function",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + ; Special symbols + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + static_symbol defmacro_symbol, 'defmacro!' + static_symbol macroexpand_symbol, 'macroexpand' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + ; + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) )" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .return_nil + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Macro expand + pop rax ; Old AST, discard from stack + call macroexpand ; Replaces RSI + push rsi ; New AST + + ; Check if RSI is a list, and if + ; the first element is a symbol + mov al, BYTE [rsi] + + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list_still_list + + ; Not a list, so call eval_ast on it + mov rdi, r15 ; Environment + call eval_ast + jmp .return + +.list_still_list: + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + eval_cmp_symbol defmacro_symbol ; defmacro! + je .defmacro_symbol + + eval_cmp_symbol macroexpand_symbol ; macroexpand + je .macroexpand_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.defmacro_symbol: + mov r9, 1 + jmp .def_common +.def_symbol: + xor r9, r9 ; Set R9 to 0 +.def_common: + ; Define a new symbol in current environment + ; If R9 is set to 1 then defmacro + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + + ; Test if this is defmacro! + test r9, r9 + jnz .defmacro_not_function + + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + push r9 + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r9 + + ; If this is defmacro, and the object in RSI is a function, + ; then change to a macro + test r9, r9 + jz .def_not_macro ; Not defmacro + + ; Check RSI + mov al, BYTE [rsi] + cmp al, maltype_function + jne .defmacro_not_function + + ; Got a function, change to macro + mov [rsi], BYTE maltype_macro + +.def_not_macro: + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.defmacro_not_function: + mov rsi, defmacro_expecting_function_string + mov rdx, defmacro_expecting_function_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + ; Uncomment these two lines to test quasiquote + ;call quasiquote + ;ret + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- +.macroexpand_symbol: + ; Check if we have a second list element + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .macroexpand_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.macroexpand_pointer: + mov rsi, [rsi + Cons.car] + call incref_object ; Since RSI will be released + + call macroexpand ; May release and replace RSI + + mov rax, rsi + jmp .return ; Releases original AST + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + pop rsi ; Body + call incref_object ; Will be released by eval + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Set ZF if RSI is a non-empty list or vector +;; Modifies RAX, does not modify RSI +is_pair: + mov al, BYTE [rsi] + test al, block_mask + jnz .false ; Not a Cons + cmp al, maltype_empty_list + je .false ; Empty list + cmp al, maltype_empty_vector + je .false ; Empty vector + + ; Something non empty + and al, container_mask + cmp al, container_list + je .true + cmp al, container_vector + je .true + ; Not a list or vector -> false + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + ret + +;; Called by eval with AST in RSI [ modified ] +;; Returns new AST in RAX +quasiquote: + ; i. Check if AST is an empty list + call is_pair + jne .quote_ast + + ; ii. Check if the first element of RSI is the symbol + ; 'unquote' + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_unquote ; Not a pointer + + mov rdi, [rsi + Cons.car] ; Get the pointer + mov cl, BYTE [rdi] + cmp cl, maltype_symbol + jne .not_unquote + + ; Compare against 'unquote' + mov r8, rsi + mov r9, rax + + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + + mov rax, r9 + mov rsi, r8 + + je .unquote + +.not_unquote: + ; iii. Handle splice-unquote + ; RSI -> ( ( splice-unquote ? ) ? ) + + ; Test if RSI contains a pointer + + cmp al, content_pointer + jne .not_splice + + mov rbx, [rsi + Cons.car] ; Get the object pointer + + ; RBX -> ( splice-unquote ? ) + + xchg rbx, rsi + call is_pair + xchg rbx, rsi + jne .not_splice ; First element not a pair + + ; Check if this list in RBX starts with 'splice-unquote' symbol + mov al, BYTE [rbx] + and al, content_mask + cmp al, content_pointer + jne .not_splice + + + mov rdi, [rbx + Cons.car] ; Get the pointer + mov al, BYTE [rdi] + cmp al, maltype_symbol + jne .not_splice + + mov r8, rsi + mov r9, rbx + + ; Compare against 'splice-unquote' + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + + mov rbx, r9 + mov rsi, r8 + + je .splice_unquote + +.not_splice: + + ; iv. Cons first and rest of AST in RSI + + ; check if pointer or value + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .cons_pointer + + ; a value, so copy + call alloc_cons + or cl, container_list + mov [rax], BYTE cl ; List + Content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + mov rcx, rax + jmp .cons_first + +.cons_pointer: + ; Get the pointer and call quasiquote + push rsi + mov rsi, [rsi + Cons.car] + call quasiquote + mov rcx, rax + pop rsi + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx + mov rcx, rax + +.cons_first: + ; Have Cons with first object in RCX + + ; Call quasiquote on the rest of the AST + ; Check if this is the end of the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .cons_ast_end + + mov rsi, [rsi + Cons.cdr] ; Rest of the list + + call incref_object ; Will release after quasiquote call + + jmp .cons_quasiquote_ast + +.cons_ast_end: + ; End of the AST, so make an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax + +.cons_quasiquote_ast: + push rcx + push rsi + call quasiquote + mov rdx, rax ; List in RDX + + pop rsi + call release_object ; Release input + + pop rcx ; Value in RCX + + ; cons RCX and RDX + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + + ; Link to the RCX Cons + mov [rcx + Cons.typecdr], BYTE content_pointer + mov [rcx + Cons.cdr], rax + mov rdx, rcx + + call alloc_cons ; Cons for cons symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the cons symbol + mov rsi, cons_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.quote_ast: + ; Return (quote RSI) + + call incref_object ; RSI reference count + + ; Cons for RSI + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rsi, rax + + ; Cons for quote symbol + call alloc_cons + mov rbx, rax + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rsi + + ; Get a quote symbol, incrementing references + mov rsi, quote_symbol + call incref_object + + ; Put into the Cons in RBX + mov [rbx + Cons.car], rsi + mov [rbx], BYTE (block_cons + container_list + content_pointer) + mov rax, rbx + ret + ; ----------------------- + +.unquote: + + ; Got unquote symbol. Return second element of RSI + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; No second element + + mov rsi, [rsi + Cons.cdr] + + ; Check if it's a value or pointer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .unquote_pointer + + ; A value, so need a new Cons + call alloc_cons + mov [rax], BYTE cl ; content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Copy content + ret + +.unquote_pointer: + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + + ; ----------------------- +.splice_unquote: + ; RSI -> ( RBX->( splice-unquote A ) B ) + ; + ; RBX Car points to splice-unquote symbol + + ; Check if there is anything after the symbol + mov al, BYTE [rbx + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_empty + + ; Point to the second element of the splice-unquote list + mov rcx, [rbx + Cons.cdr] + + ; Check whether it's a value or pointer + mov al, BYTE [rcx] + and al, content_mask + cmp al, content_pointer + je .splice_unquote_pointer + + ; A value, so change the container to a value + mov [rcx], BYTE al + ; Remove pointer from RBX + mov [rbx + Cons.typecdr], BYTE 0 + jmp .splice_unquote_first ; Got the value in RCX + +.splice_unquote_pointer: + mov rcx, [rcx + Cons.car] ; Get the object pointed to + xchg rcx, rsi + call incref_object + xchg rcx, rsi ; Object in RCX + +.splice_unquote_first: ; Got the first object in RCX + + ; Check if RSI contains anything else + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_notail + + mov rsi, [rsi + Cons.cdr] + + ; Now have: + ; ( ( splice-unquote A ) B ) + ; RCX->A RSI->( B ) + ; Need to call quasiquote on the rest of the list + push rcx + call quasiquote + mov rdx, rax + pop rcx + ; Need to concat rcx and rdx + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + mov rdx, rax ; Push list into RDX + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx ; The splice-unquote object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + call alloc_cons ; Cons for concat symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the concat symbol + mov rsi, concat_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.splice_unquote_notail: + ; Just return the object in RCX + ; since nothing to concatenate with + mov rax, rcx + ret + +.splice_unquote_empty: + ; Nothing in the (splice-unquote) list, so ignore + ; Just call quasiquote on the rest of RSI + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; Nothing else + + mov rsi, [rsi + Cons.cdr] + jmp quasiquote ; Tail call + +.empty_list: + ; Return an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list +.return: + ret + + +;; Tests if an AST in RSI is a list containing +;; a macro defined in the ENV in R15 +;; +;; Inputs: AST in RSI (not modified) +;; ENV in R15 (not modified) +;; +;; Returns: Sets ZF if macro call. If set (true), +;; then the macro object is in RAX +;; +;; Modifies: +;; RAX +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +is_macro_call: + ; Test if RSI is a list which contains a pointer + mov al, BYTE [rsi] + cmp al, (block_cons + container_list + content_pointer) + jne .false + + ; Test if this is a symbol + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .false + + ; Look up symbol in Env + push rsi + push r15 + mov rdi, rbx ; symbol in RDI + mov rsi, r15 ; Environment in RSI + call env_get + pop r15 + pop rsi + jne .false ; Not in environment + + ; Object in RAX + ; If this is not a macro then needs to be released + mov dl, BYTE [rax] + + cmp dl, maltype_macro + je .true + + ; Not a macro, so release + mov r8, rsi + mov rsi, rax + call release_object + mov rsi, r8 + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + mov rbx, rax ; Returning Macro object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Expands macro calls +;; +;; Input: AST in RSI (released and replaced) +;; Env in R15 (not modified) +;; +;; Result: New AST in RSI +macroexpand: + push r15 + + call is_macro_call + jne .done + + mov r13, rsi + + mov rdi, rax ; Macro in RDI + + ; Check the rest of the args + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + je .got_args + + ; No arguments. Create an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rdx, rax + + mov rsi, rdx ; Arguments (empty list) + call incref_object + jmp .macro_call +.got_args: + mov rsi, [rsi + Cons.cdr] ; Rest of list + call incref_object + mov rdx, rsi ; Released +.macro_call: + ; Here have: + ; RSI - Arguments + ; RDI - Macro object + ; RDX - List to release + ; R15 - Environment + ; R13 - AST + + ; Increment reference for Environment + ; since this will be released by apply_fn + xchg rsi, r15 + call incref_object + xchg rsi, r15 + + call apply_fn + + mov rsi, rax ; Result in RSI + + pop r15 + jmp macroexpand +.done: + pop r15 + ret + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; The AST from read_str is released by eval + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call rep_seq + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval-Print "(load-file )" + call rep_seq + + jmp quit From bd1961f76be05d85d2db4abde93833dcef329d84 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 30 Nov 2017 23:41:32 +0000 Subject: [PATCH 0305/1998] rest core function always returns list If given a vector, allocates a new Cons for the head of the list, pointing to the rest of the elements. This is still O(1), since only needs to copy one element. --- nasm/core.asm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index dc94c95f23..08561113c5 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1398,8 +1398,58 @@ core_rest: .return_rest: mov rsi, [rsi + Cons.cdr] + + ; Check if this is a list or a vector + mov cl, BYTE [rsi] + mov ch, cl + and ch, container_mask + cmp ch, container_list + je .return_list + + ; Need to allocate a new Cons to replace this first element + call alloc_cons + and cl, content_mask + mov ch, cl ; Save CAR content type in ch + or cl, container_list ; Keep content type, set container type to list + mov [rax], BYTE cl + + mov dl, BYTE [rsi + Cons.typecdr] ; CDR type in DL + mov [rax + Cons.typecdr], BYTE dl + + ; Copy content of CAR and CDR + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + + mov rcx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rcx ; Note: Might be pointer + + ; Check if car contains a pointer + cmp ch, content_pointer + jne .check_cdr + + ; CAR contains a pointer, so increment reference count + + mov r8, rax ; Save return Cons + mov rsi, rbx ; Content of CAR + call incref_object + mov rax, r8 ; Restore return Cons + +.check_cdr: + ; Check if cdr contains a pointer + cmp dl, content_pointer + jne .return ; Not a pointer, so just return + + ; A pointer, so increment its reference count + mov rbx, rax ; Save the return Cons + mov rsi, rcx ; The pointer in CDR + call incref_object + mov rax, rbx ; Restore the return Cons + ret + +.return_list: call incref_object mov rax, rsi +.return: ret .return_nil: From 7410ca9e12595a325f59b5dc4be9962577ccb453 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 30 Nov 2017 23:42:48 +0000 Subject: [PATCH 0306/1998] Fix bug in read_str for long strings Symbols are read by the tokenizer into RSI, but RSI was overwritten when a new string chunk was fetched. If the reader happened to be reading a symbol as the end of an Array chunk was reached, then the symbol would be changed to part of the input string. All step 8 tests now pass. --- nasm/reader.asm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/nasm/reader.asm b/nasm/reader.asm index 4fe92921f1..05872d0537 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -666,8 +666,10 @@ tokenizer_next_chunk: cmp r10, 0 je .no_more ; More chunks left + push rsi mov rsi, r10 call tokenizer_init + pop rsi ret .no_more: ; No more chunks left. R10 is zero From ad66dd9d7d76bdedb8df19b03aa870a02c592440 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 1 Dec 2017 22:35:19 +0000 Subject: [PATCH 0307/1998] Adding predicate functions to core nil? true? false? number? test the contents type symbol? string? fn? and macro? test object types, similar to the atom? function These two sets of functions are each implemented as one function with different input parameters. --- nasm/core.asm | 82 +++++++++++++++++++++++++++++++++++++++++++++++-- nasm/reader.asm | 2 +- 2 files changed, 80 insertions(+), 4 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 08561113c5..05eef977ac 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -47,7 +47,16 @@ section .data static core_first_symbol, db "first" static core_rest_symbol, db "rest" static core_nth_symbol, db "nth" - + + static core_nilp_symbol, db "nil?" + static core_truep_symbol, db "true?" + static core_falsep_symbol, db "false?" + static core_numberp_symbol, db "number?" + + static core_symbolp_symbol, db "symbol?" + static core_stringp_symbol, db "string?" + static core_fnp_symbol, db "fn?" + static core_macrop_symbol, db "macro?" ;; Strings static core_emptyp_error_string, db "empty? expects a list, vector or map",10 @@ -73,7 +82,8 @@ section .data static core_nth_not_list, db "Error: nth expects a list or vector as first argument" static core_nth_not_int, db "Error: nth expects an integer as second argument" static core_nth_out_of_range, db "Error: nth index out of range" - + + static core_value_p_missing_args, db "Error: value predicate (nil/true/false) missing args" section .text ;; Add a native function to the core environment @@ -145,6 +155,15 @@ core_environment: core_env_native core_rest_symbol, core_rest core_env_native core_nth_symbol, core_nth + core_env_native core_nilp_symbol, core_nilp + core_env_native core_truep_symbol, core_truep + core_env_native core_falsep_symbol, core_falsep + core_env_native core_numberp_symbol, core_numberp + + core_env_native core_symbolp_symbol, core_symbolp + core_env_native core_stringp_symbol, core_stringp + core_env_native core_fnp_symbol, core_fnp + core_env_native core_macrop_symbol, core_macrop ; ----------------- ; Put the environment in RAX @@ -790,6 +809,22 @@ core_deref: ;; Test if given object is an atom core_atomp: + mov al, maltype_atom + jmp core_pointer_type_p +core_symbolp: + mov al, maltype_symbol + jmp core_pointer_type_p +core_stringp: + mov al, maltype_string + jmp core_pointer_type_p +core_fnp: + mov al, maltype_function + jmp core_pointer_type_p +core_macrop: + mov al, maltype_macro + jmp core_pointer_type_p + +core_pointer_type_p: mov bl, BYTE [rsi] mov bh, bl and bh, content_mask @@ -798,7 +833,7 @@ core_atomp: mov rsi, [rsi + Cons.car] mov bl, BYTE [rsi] - cmp bl, maltype_atom + cmp bl, al jne .false ; Got an atom, return true @@ -1567,3 +1602,44 @@ core_nth: call raw_to_string mov rsi, rax jmp error_throw + +;; Check if the argument is a given value type +core_nilp: + mov al, BYTE content_nil + jmp core_value_type_p +core_truep: + mov al, BYTE content_true + jmp core_value_type_p +core_falsep: + mov al, BYTE content_false + jmp core_value_type_p +core_numberp: + mov al, BYTE content_int +;; predicates for nil, true, false and number jump here +core_value_type_p: + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_empty + je .missing_args + + cmp al, bl + je .true + + ; false + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.missing_args: + mov rsi, core_value_p_missing_args + mov edx, core_value_p_missing_args.len + + call raw_to_string + mov rsi, rax + jmp error_throw + + diff --git a/nasm/reader.asm b/nasm/reader.asm index 05872d0537..57c8aa92d2 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -666,7 +666,7 @@ tokenizer_next_chunk: cmp r10, 0 je .no_more ; More chunks left - push rsi + push rsi ; Because symbol reading uses RSI (tokenizer_next.handle_symbol) mov rsi, r10 call tokenizer_init pop rsi From c71ed43f49580bd8fde6d1babe1b7767d064e809 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sun, 3 Dec 2017 23:20:37 +0000 Subject: [PATCH 0308/1998] Add vector? map? and contains? vector? and map? almost the same as list? so just change list? to take a container type argument. --- nasm/core.asm | 85 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 83 insertions(+), 2 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 05eef977ac..13e28632cb 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -57,6 +57,10 @@ section .data static core_stringp_symbol, db "string?" static core_fnp_symbol, db "fn?" static core_macrop_symbol, db "macro?" + + static core_containsp_symbol, db "contains?" + static core_vectorp_symbol, db "vector?" + static core_mapp_symbol, db "map?" ;; Strings static core_emptyp_error_string, db "empty? expects a list, vector or map",10 @@ -84,6 +88,9 @@ section .data static core_nth_out_of_range, db "Error: nth index out of range" static core_value_p_missing_args, db "Error: value predicate (nil/true/false) missing args" + + static core_containsp_not_map, db "Error: contains? expects map as first argument" + static core_containsp_no_key, db "Error: contains? missing key argument" section .text ;; Add a native function to the core environment @@ -164,6 +171,11 @@ core_environment: core_env_native core_stringp_symbol, core_stringp core_env_native core_fnp_symbol, core_fnp core_env_native core_macrop_symbol, core_macrop + + core_env_native core_containsp_symbol, core_containsp + + core_env_native core_vectorp_symbol, core_vectorp + core_env_native core_mapp_symbol, core_mapp ; ----------------- ; Put the environment in RAX @@ -381,6 +393,15 @@ core_compare_num: ;; Input list in RSI ;; Returns true or false in RAX core_listp: + mov bl, (block_cons + container_list) + jmp core_container_p +core_vectorp: + mov bl, (block_cons + container_vector) + jmp core_container_p +core_mapp: + mov bl, (block_cons + container_map) + ;jmp core_container_p +core_container_p: mov al, BYTE [rsi] and al, content_mask cmp al, content_pointer @@ -389,7 +410,7 @@ core_listp: mov rax, [rsi + Cons.car] mov al, BYTE [rax] and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) + cmp al, bl jne .false ; Is a list, return true @@ -501,13 +522,73 @@ core_keys: call map_keys ret +;; Given a map and a key, return true if the key is in the map +;; +core_containsp: + ; Check the type of the first argument + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_pointer + jne .not_map + + mov rcx, [rsi + Cons.car] ; Map in RCX + mov bl, BYTE [rcx] + and bl, (block_mask + container_mask) + cmp bl, container_map + jne .not_map + + ; Check second argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_key + mov rsi, [rsi + Cons.cdr] + mov dl, BYTE [rsi] + and dl, content_mask + cmp dl, content_pointer + jne .key_value + + ; Pointer, so put into RDI + mov rdi, [rsi + Cons.car] + jmp .find + +.key_value: + ; A value + mov [rsi], BYTE dl + mov rdi, rsi ; Value in RDI + +.find: + mov rsi, rcx ; Map + call map_find + je .true + + ; false + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.not_map: + mov rsi, core_containsp_not_map + mov edx, core_containsp_not_map.len + jmp .throw +.no_key: + mov rsi, core_containsp_no_key + mov edx, core_containsp_no_key.len +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + ;; Return arguments as a list ;; core_list: call incref_object mov rax, rsi ret - + ;; ------------------------------------------------ ;; String functions From 2c686f42eafee4953c2a2f21e7250cf6286dd7ce Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 8 Dec 2017 08:17:35 +0000 Subject: [PATCH 0309/1998] Fix bug in apply_fn releasing memory The list was released too early, before the function body had its reference count incremented. If the function was a lambda function then this released the function, leading to odd behaviour e.g. ((fn* [x] (+ 1 x)) 2) --- nasm/step8_macros.asm | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/nasm/step8_macros.asm b/nasm/step8_macros.asm index b0d1714bbb..60973781f6 100644 --- a/nasm/step8_macros.asm +++ b/nasm/step8_macros.asm @@ -1602,8 +1602,7 @@ eval: call eval_ast ; List of evaluated forms in RAX pop r15 pop rsi - - + .list_exec: ; This point can be called to run a function ; used by swap! @@ -1655,11 +1654,10 @@ eval: ; Result in rax pop r15 pop rsi ; eval'ed list - + push rax call release_cons - pop rax - + pop rax jmp .return ; Releases Env .list_not_function: @@ -1739,6 +1737,15 @@ apply_fn: mov rdi, rax ; New environment in RDI + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + ; Release the list passed in RDX mov rsi, rdx call release_cons @@ -1750,9 +1757,8 @@ apply_fn: ; Release the old AST mov rsi, r14 call release_object - - pop rsi ; Body - call incref_object ; Will be released by eval + + mov rsi, r8 ; Body jmp eval ; Tail call ; The new environment (in RDI) will be released by eval From a4ca0426a23e62b8e655424994498ff853acc906 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 8 Dec 2017 08:19:57 +0000 Subject: [PATCH 0310/1998] Adding map and throw functions Also some more useful error messages for the arithmetic operators, rather than returning nil. --- nasm/core.asm | 299 ++++++++++++++++++++++++++++++++++++++++++------ nasm/macros.mac | 6 + 2 files changed, 273 insertions(+), 32 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 13e28632cb..79a3bc4519 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -61,8 +61,15 @@ section .data static core_containsp_symbol, db "contains?" static core_vectorp_symbol, db "vector?" static core_mapp_symbol, db "map?" + + static core_throw_symbol, db "throw" + + static core_map_symbol, db "map" ;; Strings + static core_arith_missing_args, db "integer arithmetic missing arguments" + static core_arith_not_int, db "non-integer argument to integer arithmetic" + static core_emptyp_error_string, db "empty? expects a list, vector or map",10 static core_count_error_string, db "count expects a list or vector",10 static core_numeric_expect_ints, db "comparison operator expected two numbers",10 @@ -91,6 +98,11 @@ section .data static core_containsp_not_map, db "Error: contains? expects map as first argument" static core_containsp_no_key, db "Error: contains? missing key argument" + + static core_map_missing_args, db "Error: map expects two arguments (function, list/vector)" + static core_map_not_function, db "Error: map expects a ufunction for first argument" + static core_map_not_seq, db "Error: map expects a list or vector as second argument" + section .text ;; Add a native function to the core environment @@ -110,6 +122,7 @@ section .text pop rsi ; environment call env_set %endmacro + ;; Create an Environment with core functions ;; @@ -176,6 +189,10 @@ core_environment: core_env_native core_vectorp_symbol, core_vectorp core_env_native core_mapp_symbol, core_mapp + + core_env_native core_throw_symbol, core_throw + + core_env_native core_map_symbol, core_map ; ----------------- ; Put the environment in RAX @@ -184,6 +201,17 @@ core_environment: ;; ---------------------------------------------------- +;; Jumped to from many core functions, with +;; string address in RSI and length in EDX +core_throw_str: + call raw_to_string + mov rsi, rax + jmp error_throw + +;; ---------------------------------------------------- + + + ;; Integer arithmetic operations ;; ;; Adds a list of numbers, address in RSI @@ -208,11 +236,15 @@ core_arithmetic: mov ch, cl and ch, block_mask cmp ch, block_cons - jne .error + jne .missing_args + mov ch, cl and ch, content_mask + cmp ch, content_empty + je .missing_args + cmp ch, content_int - jne .error + jne .not_int ; Put the starting value in rax mov rax, [rsi + Cons.car] @@ -220,18 +252,16 @@ core_arithmetic: .add_loop: ; Fetch the next value mov cl, [rsi + Cons.typecdr] - cmp cl, content_nil - je .finished ; Nothing let cmp cl, content_pointer - jne .error - + jne .finished ; Nothing let + mov rsi, [rsi + Cons.cdr] ; Get next cons ; Check that it is an integer mov cl, BYTE [rsi] and cl, content_mask cmp cl, content_int - jne .error + jne .not_int ; Jump to the required operation, address in RBX jmp rbx @@ -260,12 +290,13 @@ core_arithmetic: mov [rax], BYTE maltype_integer mov [rax + Cons.car], rbx ret -.error: - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret + +.missing_args: + load_static core_arith_missing_args + jmp core_throw_str +.not_int: + load_static core_arith_not_int + jmp core_throw_str ;; compare objects for equality core_equalp: @@ -571,16 +602,11 @@ core_containsp: ret .not_map: - mov rsi, core_containsp_not_map - mov edx, core_containsp_not_map.len - jmp .throw + load_static core_containsp_not_map + jmp core_throw_str .no_key: - mov rsi, core_containsp_no_key - mov edx, core_containsp_no_key.len -.throw: - call raw_to_string - mov rsi, rax - jmp error_throw + load_static core_containsp_no_key + jmp core_throw_str ;; Return arguments as a list ;; @@ -1216,18 +1242,12 @@ core_cons: ret .missing_args: - mov rsi, core_cons_missing_arg - mov edx,core_cons_missing_arg.len - jmp .throw + load_static core_cons_missing_arg + jmp core_throw_str .not_vector: - mov rsi, core_cons_not_vector - mov edx, core_cons_not_vector.len - -.throw: - call raw_to_string - mov rsi, rax - jmp error_throw + load_static core_cons_not_vector + jmp core_throw_str ;; Concatenate lists, returning a new list @@ -1723,4 +1743,219 @@ core_value_type_p: mov rsi, rax jmp error_throw +;; Throws an exception +core_throw: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .throw_nil ; No arguments + + cmp al, content_pointer + je .throw_pointer + + ; A value. Remove list content type + mov [rsi], BYTE al + jmp error_throw + +.throw_pointer: + mov rsi, [rsi + Cons.car] + jmp error_throw + +.throw_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov rsi, rax + jmp error_throw + +;; Applies a function to a list or vector +;; +;; Uses registers +;; R8 - function +;; R9 - Input list/vector +;; R10 - Current end of return list (for appending) +core_map: + xor r10,r10 ; Zero, signal no list + + ; First argument should be a function + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_empty + je .missing_args + + ; Check the first argument is a pointer + cmp bl, content_pointer + jne .not_function + + mov r8, [rsi + Cons.car] ; Function in R8 + mov bl, BYTE [r8] + cmp bl, maltype_function + jne .not_function + + ; Check for second argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .missing_args + + mov rsi, [rsi + Cons.cdr] + + ; Should be a pointer to a list or vector + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_pointer + jne .not_seq + + mov r9, [rsi + Cons.car] ; List or vector in R9 + + mov bl, BYTE [r9] + + mov bh, bl + and bh, content_mask + cmp bh, content_empty + je .empty_list + + and bl, (block_mask + container_mask) + cmp bl, container_list + je .start + cmp bl, container_vector + je .start + + ; not list or vector + jmp .not_seq + +.start: + ; Got function in R8, list or vector in R9 + + mov cl, BYTE [r9] + and cl, content_mask + + call alloc_cons + mov [rax], BYTE cl ; set content type + mov rbx, [r9 + Cons.car] + mov [rax + Cons.car], rbx ; Copy content + mov rsi, rax + + cmp cl, content_pointer + jne .run + + ; A pointer, so increment ref count + + mov rcx, rsi + mov rsi, rbx + call incref_object + mov rsi, rcx + +.run: + ; Here have function in R8, args in RSI + ; Check whether the function is built-in or user + mov rax, [r8 + Cons.car] + cmp rax, apply_fn + je .user_function + + ; A built-in function + push r8 ; function + push r9 ; input list/vector + push r10 ; End of return list + push rsi + + call rax + ; Result in RAX + + pop rsi + pop r10 + pop r9 + pop r8 + + push rax + call release_object ; Release arguments + pop rax + + jmp .got_return + +.user_function: + ; a user-defined function, so need to evaluate + ; RSI - Args + + mov rdi, r8 ; Function in RDI + mov rdx, rsi ; Release args after binding + + mov rsi, r15 ; Environment + call incref_object ; Released by eval + call incref_object ; also released from R13 + mov r13, r15 + + mov rsi, rdx + + push r8 + push r9 + push r10 + call apply_fn ; Result in RAX + pop r10 + pop r9 + pop r8 + +.got_return: + ; Have a return result in RAX + ; Check if it's a value type + mov bl, BYTE [rax] + mov bh, bl + and bl, (block_mask + container_mask) + jz .return_value + + ; A more complicated type, point to it + mov rcx, rax + call alloc_cons ; Create a Cons for address + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx + jmp .update_return + +.return_value: + mov bl, bh + and bl, content_mask + or bl, container_list + mov [rax], BYTE bl ; mark as a list + +.update_return: + ; Now append to result list + test r10,r10 + jnz .append + + ; First value + mov r10, rax ; End of list + push r10 ; popped before return + jmp .next +.append: + mov [r10 + Cons.cdr], rax ; Point to new Cons + mov [r10 + Cons.typecdr], BYTE content_pointer + mov r10, rax +.next: + ; Check if there is another value + mov al, [r9 + Cons.typecdr] + cmp al, content_pointer + jne .done ; no more + + mov r9, [r9 + Cons.cdr] ; next + jmp .start + +.done: + pop rax ; Pushed in .update_return + ret + +.empty_list: + ; Got an empty list, so return an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +.missing_args: + ; Either zero or one args, expect two + load_static core_map_missing_args + jmp core_throw_str +.not_function: + ; First argument not a function + load_static core_map_not_function + jmp core_throw_str +.not_seq: + ; Second argument not list or vector + load_static core_map_not_seq + jmp core_throw_str diff --git a/nasm/macros.mac b/nasm/macros.mac index f3db819bdf..8adac59e30 100644 --- a/nasm/macros.mac +++ b/nasm/macros.mac @@ -12,6 +12,12 @@ %1.len: equ $ - %1 %endmacro +;; Puts address of data in RSI, length in EDX +%macro load_static 1 + mov rsi, %1 + mov edx, %1.len +%endmacro + ;; Define a symbol which can be compared against ;; ;; static_symbol name, string From 4a65988988ca046097db18db9cd71ca79b8c5bc6 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 8 Dec 2017 20:49:02 +0000 Subject: [PATCH 0311/1998] Add apply function to core Tested both built-in and user functions, seems to be working --- nasm/core.asm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 163 insertions(+), 1 deletion(-) diff --git a/nasm/core.asm b/nasm/core.asm index 79a3bc4519..69b40c60a6 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -65,6 +65,8 @@ section .data static core_throw_symbol, db "throw" static core_map_symbol, db "map" + static core_apply_symbol, db "apply" + ;; Strings static core_arith_missing_args, db "integer arithmetic missing arguments" @@ -102,7 +104,10 @@ section .data static core_map_missing_args, db "Error: map expects two arguments (function, list/vector)" static core_map_not_function, db "Error: map expects a ufunction for first argument" static core_map_not_seq, db "Error: map expects a list or vector as second argument" - + + static core_apply_not_function, db "Error: apply expects function as first argument" + static core_apply_missing_args, db "Error: apply missing arguments" + static core_apply_not_seq, db "Error: apply last argument must be list or vector" section .text ;; Add a native function to the core environment @@ -193,6 +198,7 @@ core_environment: core_env_native core_throw_symbol, core_throw core_env_native core_map_symbol, core_map + core_env_native core_apply_symbol, core_apply ; ----------------- ; Put the environment in RAX @@ -1959,3 +1965,159 @@ core_map: load_static core_map_not_seq jmp core_throw_str + +;; Applies a function to a list of arguments, concatenated with +;; a final list of args +;; (function, ..., []) +core_apply: + ; First argument should be a function + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_function + + mov r8, [rsi + Cons.car] ; function in R8 + mov al, BYTE [r8] + cmp al, maltype_function + jne .not_function + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .missing_args + + xor r9,r9 + ; Optional args, followed by final list/vector +.loop: + mov rsi, [rsi + Cons.cdr] + + ; Check if this is the last + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .last + + ; Not the last, so copy + call alloc_cons ; New Cons in RAX + mov bl, BYTE [rsi] + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + + and bl, content_mask + cmp bl, content_pointer + jne .got_value + + ; A pointer, so increment reference + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.got_value: + ; Now append this Cons to the list + test r9,r9 + jnz .append + + ; First + mov r9, rax ; Start of the list + mov r10, rax ; End of the list + jmp .loop + +.append: + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r10, rax + jmp .loop + +.last: + ; Check that it's a list or vector + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_seq + + mov rsi, [rsi + Cons.car] ; Vector/list in RSI + mov al, BYTE [rsi] + and al, container_mask + cmp al, container_list + je .last_seq + cmp al, container_vector + jne .not_seq + +.last_seq: + ; Check if there were any previous args + test r9, r9 + jnz .last_append + + ; R9 is zero, so no previous args + mov r9, rsi + jmp .run + +.last_append: + ; Append RSI to the end of the list [R9]...[R10] + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rsi + +.run: + ; Have arguments list in R9 + mov rsi, r9 + ; Here have function in R8, args in RSI + ; Check whether the function is built-in or user + mov rax, [r8 + Cons.car] + cmp rax, apply_fn + je .user_function + + ; A built-in function + push r8 ; function + push r9 ; input list/vector + push r10 ; End of return list + push rsi + + call rax + ; Result in RAX + + pop rsi + pop r10 + pop r9 + pop r8 + + push rax + call release_object ; Release arguments + pop rax + + ret + +.user_function: + ; a user-defined function, so need to evaluate + ; RSI - Args + + mov rdi, r8 ; Function in RDI + mov rdx, rsi ; Release args after binding + + mov rsi, r15 ; Environment + call incref_object ; Released by eval + call incref_object ; also released from R13 + mov r13, r15 + + mov rsi, rdx + + push r8 + push r9 + push r10 + call apply_fn ; Result in RAX + pop r10 + pop r9 + pop r8 + + ret + +.not_function: + load_static core_apply_not_function + jmp core_throw_str + +.missing_args: + load_static core_apply_missing_args + jmp core_throw_str + +.not_seq: + load_static core_apply_not_seq + jmp core_throw_str + From b584079d06a53fdfc86f65243ec0281c03789a1d Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 8 Dec 2017 21:26:30 +0000 Subject: [PATCH 0312/1998] Fix swap! function Changes to how eval works mean the previous approach no longer works. Now uses the same method as apply and map functions, calling apply_fn for user-defined functions. --- nasm/core.asm | 129 +++++++++++++++++++++++++++++++++++--------------- 1 file changed, 92 insertions(+), 37 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 69b40c60a6..f24d656a15 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -80,6 +80,9 @@ section .data static core_reset_not_atom, db "Error: argument to reset is not an atom" static core_reset_no_value, db "Error: missing value argument to reset" + static core_swap_not_atom, db "Error: swap! expects atom as first argument" + static core_swap_no_function, db "Error: swap! expects function as second argument" + static core_cons_missing_arg, db "Error: missing argument to cons" static core_cons_not_vector, db "Error: cons expects a list or vector" @@ -1074,8 +1077,8 @@ core_swap: jne .not_atom ; Get the atom - mov r8, [rsi + Cons.car] ; Atom in R8 - mov bl, BYTE [r8] + mov r9, [rsi + Cons.car] ; Atom in R9 + mov bl, BYTE [r9] cmp bl, maltype_atom jne .not_atom @@ -1084,22 +1087,42 @@ core_swap: cmp bl, content_pointer jne .no_function - mov r9, [rsi + Cons.cdr] ; List with function first + mov rsi, [rsi + Cons.cdr] ; List with function first + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .no_function + + mov r8, [rsi + Cons.car] ; Function in R8 + mov al, BYTE [r8] + cmp al, maltype_function + jne .no_function - ; Get a new Cons to insert into the list + ; Get a new Cons ; containing the value in the atom call alloc_cons ; In RAX - ; Splice into the list - mov bl, BYTE [r9 + Cons.typecdr] - mov rcx, [r9 + Cons.cdr] + ; Prepend to the list + mov bl, BYTE [rsi + Cons.typecdr] mov [rax + Cons.typecdr], bl + cmp bl, content_pointer + jne .done_prepend + + ; A pointer to more args, + + mov rcx, [rsi + Cons.cdr] mov [rax + Cons.cdr], rcx - mov [r9 + Cons.typecdr], BYTE content_pointer - mov [r9 + Cons.cdr], rax + + ; increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_prepend: ; Now get the value in the atom - mov rdx, [r8 + Cons.car] ; The object pointed to + mov rdx, [r9 + Cons.car] ; The object pointed to ; Check what it is mov bl, BYTE [rdx] @@ -1113,10 +1136,11 @@ core_swap: ; Since the list will be released after eval ; we need to increment the reference count - mov rsi, rdx - call incref_object + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx - jmp .list_done + jmp .run .atom_value: ; Copy the value @@ -1126,44 +1150,75 @@ core_swap: or bl, container_list ; mark as part of a list mov [rax], BYTE bl -.list_done: - ; Now have a list with function followed by args - ; This is the same state as after a call to eval_ast - ; - ; Note: Because eval releases the environment in R15 - ; on return, this needs to have its references - ; incremented before the call - ; - ; The list passed in RAX will be released by eval - - mov rsi, r15 - call incref_object +.run: + mov rsi, rax + + ; Here have function in R8, args in RSI + ; Check whether the function is built-in or user + mov rax, [r8 + Cons.car] + cmp rax, apply_fn + je .user_function + + ; A built-in function + push r9 ; atom + push rsi ; Args + + call rax + ; Result in RAX - mov rax, r9 - push r8 ; The atom - call eval.list_exec ; Result in RAX - pop r8 + pop rsi + pop r9 + + push rax + call release_object ; Release arguments + pop rax + + jmp .got_return + +.user_function: + ; a user-defined function, so need to evaluate + ; RSI - Args + + mov rdi, r8 ; Function in RDI + mov rdx, rsi ; Release args after binding + + mov rsi, r15 ; Environment + call incref_object ; Released by eval + call incref_object ; also released from R13 + mov r13, r15 + + mov rsi, rdx + + push r9 + call apply_fn ; Result in RAX + pop r9 + +.got_return: + ; Have a return result in RAX ; release the current value of the atom push rax ; The result - mov rsi, [r8 + Cons.car] + mov rsi, [r9 + Cons.car] call release_object - pop rsi + pop rax ; Put into atom - mov [r8 + Cons.car], rsi + mov [r9 + Cons.car], rax ; Increase reference of new object ; because when it is returned it will be released - push rsi - call incref_object - pop rax + mov bx, WORD [rax + Cons.refcount] + inc bx + mov [rax + Cons.refcount], WORD bx + ret .not_atom: + load_static core_swap_not_atom + jmp core_throw_str .no_function: - xor rsi,rsi - jmp error_throw + load_static core_swap_no_function + jmp core_throw_str ;; Takes two arguments, and prepends the first argument onto the second From 7511108d0eb4efa3794a9ed55ce049ef009a8cbc Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 9 Dec 2017 11:05:53 +0000 Subject: [PATCH 0313/1998] Add get, sequential?, symbol, vector and hash-map functions hash-map currently doesn't check that the number of arguments is even, but just marks the list as a map. --- nasm/core.asm | 210 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 207 insertions(+), 3 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index f24d656a15..e7ef2acc2d 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -59,13 +59,19 @@ section .data static core_macrop_symbol, db "macro?" static core_containsp_symbol, db "contains?" + static core_get_symbol, db "get" static core_vectorp_symbol, db "vector?" static core_mapp_symbol, db "map?" - + static core_sequentialp_symbol, db "sequential?" + static core_throw_symbol, db "throw" static core_map_symbol, db "map" static core_apply_symbol, db "apply" + + static core_symbol_symbol, db "symbol" + static core_vector_symbol, db "vector" + static core_hashmap_symbol, db "hash-map" ;; Strings @@ -104,6 +110,9 @@ section .data static core_containsp_not_map, db "Error: contains? expects map as first argument" static core_containsp_no_key, db "Error: contains? missing key argument" + static core_get_not_map, db "Error: get expects map as first argument" + static core_get_no_key, db "Error: get missing key argument" + static core_map_missing_args, db "Error: map expects two arguments (function, list/vector)" static core_map_not_function, db "Error: map expects a ufunction for first argument" static core_map_not_seq, db "Error: map expects a list or vector as second argument" @@ -111,6 +120,8 @@ section .data static core_apply_not_function, db "Error: apply expects function as first argument" static core_apply_missing_args, db "Error: apply missing arguments" static core_apply_not_seq, db "Error: apply last argument must be list or vector" + + static core_symbol_not_string, db "Error: symbol expects a string argument" section .text ;; Add a native function to the core environment @@ -194,14 +205,20 @@ core_environment: core_env_native core_macrop_symbol, core_macrop core_env_native core_containsp_symbol, core_containsp - + core_env_native core_get_symbol, core_get + core_env_native core_vectorp_symbol, core_vectorp core_env_native core_mapp_symbol, core_mapp - + core_env_native core_sequentialp_symbol, core_sequentialp + core_env_native core_throw_symbol, core_throw core_env_native core_map_symbol, core_map core_env_native core_apply_symbol, core_apply + + core_env_native core_symbol_symbol, core_symbol + core_env_native core_vector_symbol, core_vector + core_env_native core_hashmap_symbol, core_hashmap ; ----------------- ; Put the environment in RAX @@ -463,6 +480,33 @@ core_container_p: mov [rax], BYTE maltype_false ret +;; Return true if vector or list +core_sequentialp: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .false ; Should be a pointer + + mov rax, [rsi + Cons.car] + mov al, BYTE [rax] + and al, (block_mask + container_mask) + cmp al, container_list + je .true + cmp al, container_vector + jne .false +.true: + ; Is a list or vector, return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + + + ;; Test if the given list, vector or map is empty core_emptyp: mov al, BYTE [rsi] @@ -616,6 +660,62 @@ core_containsp: .no_key: load_static core_containsp_no_key jmp core_throw_str + + +;; Given a map and a key, return the value in the map +;; or nil if not found +;; +core_get: + ; Check the type of the first argument + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_pointer + jne .not_map + + mov rcx, [rsi + Cons.car] ; Map in RCX + mov bl, BYTE [rcx] + and bl, (block_mask + container_mask) + cmp bl, container_map + jne .not_map + + ; Check second argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_key + mov rsi, [rsi + Cons.cdr] + mov dl, BYTE [rsi] + and dl, content_mask + cmp dl, content_pointer + jne .key_value + + ; Pointer, so put into RDI + mov rdi, [rsi + Cons.car] + jmp .find + +.key_value: + ; A value + mov [rsi], BYTE dl + mov rdi, rsi ; Value in RDI + +.find: + mov rsi, rcx ; Map + call map_get ; Value in RAX + je .found + + ; Not found + call alloc_cons + mov [rax], BYTE maltype_nil + ret +.found: + ret + +.not_map: + load_static core_get_not_map + jmp core_throw_str +.no_key: + load_static core_get_no_key + jmp core_throw_str + ;; Return arguments as a list ;; @@ -623,6 +723,89 @@ core_list: call incref_object mov rax, rsi ret + +;; Convert arguments into a vector +core_vector: + ; Copy first element and mark as vector + call alloc_cons ; in RAX + mov bl, BYTE [rsi] + and bl, content_mask + mov bh, bl ; store content for comparison + or bl, container_vector + mov [rax], BYTE bl ; Set type + + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx ; Set content + + ; Check if the first element is a pointer + cmp bh, content_pointer + jne .done_car + + ; A pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_car: + ; Copy the CDR type and content + mov bl, [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], bl + + mov rdx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rdx + + cmp bl, content_pointer + jne .done + + ; A pointer + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + +.done: + ret + + +;; Convert arguments into a map +core_hashmap: + ; Copy first element and mark as map + call alloc_cons ; in RAX + mov bl, BYTE [rsi] + and bl, content_mask + mov bh, bl ; store content for comparison + or bl, container_map + mov [rax], BYTE bl ; Set type + + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx ; Set content + + ; Check if the first element is a pointer + cmp bh, content_pointer + jne .done_car + + ; A pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_car: + ; Copy the CDR type and content + mov bl, [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], bl + + mov rdx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rdx + + cmp bl, content_pointer + jne .done + + ; A pointer + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + +.done: + ret ;; ------------------------------------------------ ;; String functions @@ -2175,4 +2358,25 @@ core_apply: .not_seq: load_static core_apply_not_seq jmp core_throw_str + +;; Converts a string to a symbol +core_symbol: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_string + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .not_string + + ; Copy the string + call string_copy ; result in RAX + + mov [rax], BYTE maltype_symbol + ret +.not_string: + load_static core_symbol_not_string + jmp core_throw_str From ff31757288ce0ea70b9d13092d25ad6d5493f76b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 9 Dec 2017 11:52:50 +0000 Subject: [PATCH 0314/1998] Add keyword and keyword? functions --- nasm/core.asm | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 71 insertions(+), 1 deletion(-) diff --git a/nasm/core.asm b/nasm/core.asm index e7ef2acc2d..3471a57d5d 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -57,6 +57,7 @@ section .data static core_stringp_symbol, db "string?" static core_fnp_symbol, db "fn?" static core_macrop_symbol, db "macro?" + static core_keywordp_symbol, db "keyword?" static core_containsp_symbol, db "contains?" static core_get_symbol, db "get" @@ -72,6 +73,7 @@ section .data static core_symbol_symbol, db "symbol" static core_vector_symbol, db "vector" static core_hashmap_symbol, db "hash-map" + static core_keyword_symbol, db "keyword" ;; Strings @@ -122,6 +124,8 @@ section .data static core_apply_not_seq, db "Error: apply last argument must be list or vector" static core_symbol_not_string, db "Error: symbol expects a string argument" + + static core_keyword_not_string, db "Error: keyword expects a string argument" section .text ;; Add a native function to the core environment @@ -203,7 +207,8 @@ core_environment: core_env_native core_stringp_symbol, core_stringp core_env_native core_fnp_symbol, core_fnp core_env_native core_macrop_symbol, core_macrop - + core_env_native core_keywordp_symbol, core_keywordp + core_env_native core_containsp_symbol, core_containsp core_env_native core_get_symbol, core_get @@ -219,6 +224,7 @@ core_environment: core_env_native core_symbol_symbol, core_symbol core_env_native core_vector_symbol, core_vector core_env_native core_hashmap_symbol, core_hashmap + core_env_native core_keyword_symbol, core_keyword ; ----------------- ; Put the environment in RAX @@ -668,7 +674,12 @@ core_containsp: core_get: ; Check the type of the first argument mov bl, BYTE [rsi] + and bl, content_mask + + cmp bl, content_nil + jmp .not_found + cmp bl, content_pointer jne .not_map @@ -702,6 +713,7 @@ core_get: call map_get ; Value in RAX je .found +.not_found: ; Not found call alloc_cons mov [rax], BYTE maltype_nil @@ -1145,6 +1157,34 @@ core_pointer_type_p: mov [rax], BYTE maltype_false ret +;; Tests if argument is a keyword +core_keywordp: + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .false + + mov rsi, [rsi + Cons.car] + mov bl, BYTE [rsi] + cmp bl, maltype_symbol + jne .false + + ; Check if first character is ':' + mov bl, BYTE [rsi + Array.data] + cmp bl, ':' + jne .false + + ; Return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + ;; Change the value of an atom core_reset: ; Check the type of the first argument @@ -2380,3 +2420,33 @@ core_symbol: .not_string: load_static core_symbol_not_string jmp core_throw_str + +;; Converts a string to a keyword +core_keyword: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_string + + mov r8, [rsi + Cons.car] ; String in R8 + mov al, BYTE [r8] + cmp al, maltype_string + jne .not_string + + call string_new ; String in RAX + mov rsi, rax + mov cl, ':' + call string_append_char ; Puts ':' first + + mov rdx, r8 + call string_append_string ; append + + ; Mark as keyword + mov [rsi], BYTE maltype_symbol + + mov rax, rsi + ret + +.not_string: + load_static core_keyword_not_string + jmp core_throw_str From a4e26fd0e64b80097061e478e6db19732be2b915 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 9 Dec 2017 16:14:12 +0000 Subject: [PATCH 0315/1998] Add try*/catch* 20 failing tests for step 9. Mainly assoc not yet implemented --- nasm/Makefile | 29 +- nasm/step9_try.asm | 2672 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 2673 insertions(+), 28 deletions(-) create mode 100644 nasm/step9_try.asm diff --git a/nasm/Makefile b/nasm/Makefile index b04192b7f6..d220cb58bc 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -1,34 +1,7 @@ -step0_repl: step0_repl.asm - nasm -felf64 step0_repl.asm - ld -o $@ step0_repl.o COMPONENTS=core.asm reader.asm printer.asm types.asm system.asm -step1_read_print: step1_read_print.asm $(COMPONENTS) - nasm -felf64 step1_read_print.asm - ld -o $@ step1_read_print.o - -step2_eval: step2_eval.asm $(COMPONENTS) - nasm -felf64 step2_eval.asm - ld -o $@ step2_eval.o - -step3_env: step3_env.asm $(COMPONENTS) - nasm -felf64 step3_env.asm - ld -o $@ step3_env.o - -step4_if_fn_do: step4_if_fn_do.asm $(COMPONENTS) - nasm -felf64 step4_if_fn_do.asm - ld -o $@ step4_if_fn_do.o - -step5_tco: step5_tco.asm $(COMPONENTS) - nasm -felf64 step5_tco.asm - ld -o $@ step5_tco.o - -step6_file: step6_file.asm $(COMPONENTS) - nasm -felf64 step6_file.asm - ld -o $@ step6_file.o - -%.o: %.asm +%.o: %.asm $(COMPONENTS) nasm -felf64 $< %: %.o diff --git a/nasm/step9_try.asm b/nasm/step9_try.asm new file mode 100644 index 0000000000..d251a81c87 --- /dev/null +++ b/nasm/step9_try.asm @@ -0,0 +1,2672 @@ +;; +;; nasm -felf64 step9_try.asm && ld step9_try.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static defmacro_expecting_function_string, db "defmacro expects function",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + + static try_missing_catch, db "try* missing catch*" + static catch_missing_symbol, db "catch* missing symbol" + static catch_missing_form, db "catch* missing form" + +;; Symbols used for comparison + + ; Special symbols + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + static_symbol defmacro_symbol, 'defmacro!' + static_symbol macroexpand_symbol, 'macroexpand' + static_symbol try_symbol, 'try*' + static_symbol catch_symbol, 'catch*' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + ; + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) )" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + ; Note: This can't use content_pointer or release + ; will try to release this memory address + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + ;call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + mov [rsi + Cons.typecdr], BYTE 0 + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + mov r11, rsi ; Symbol in R11 + + call string_new + mov rsi, rax ; New string in RSI + + mov cl, 39 ; quote ' + call string_append_char + + mov rdx, r11 ; symbol + call string_append_string + + mov cl, 39 + call string_append_char + + mov r11, rsi + + mov rsi, not_found_string + mov edx, not_found_string.len + call raw_to_string ; ' not found' + + mov r12, rax + + mov rdx, rax + mov rsi, r11 + call string_append_string + + mov r11, rsi + mov rsi, r12 + call release_array + mov rsi, r11 + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .return_nil + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Macro expand + pop rax ; Old AST, discard from stack + call macroexpand ; Replaces RSI + push rsi ; New AST + + ; Check if RSI is a list, and if + ; the first element is a symbol + mov al, BYTE [rsi] + + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list_still_list + + ; Not a list, so call eval_ast on it + mov rdi, r15 ; Environment + call eval_ast + jmp .return + +.list_still_list: + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + eval_cmp_symbol defmacro_symbol ; defmacro! + je .defmacro_symbol + + eval_cmp_symbol macroexpand_symbol ; macroexpand + je .macroexpand_symbol + + eval_cmp_symbol try_symbol ; try* + je .try_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.defmacro_symbol: + mov r9, 1 + jmp .def_common +.def_symbol: + xor r9, r9 ; Set R9 to 0 +.def_common: + ; Define a new symbol in current environment + ; If R9 is set to 1 then defmacro + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + + ; Test if this is defmacro! + test r9, r9 + jnz .defmacro_not_function + + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + push r9 + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r9 + + ; If this is defmacro, and the object in RSI is a function, + ; then change to a macro + test r9, r9 + jz .def_not_macro ; Not defmacro + + ; Check RSI + mov al, BYTE [rsi] + cmp al, maltype_function + jne .defmacro_not_function + + ; Got a function, change to macro + mov [rsi], BYTE maltype_macro + +.def_not_macro: + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.defmacro_not_function: + mov rsi, defmacro_expecting_function_string + mov rdx, defmacro_expecting_function_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + ; Uncomment these two lines to test quasiquote + ;call quasiquote + ;ret + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- +.macroexpand_symbol: + ; Check if we have a second list element + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .macroexpand_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.macroexpand_pointer: + mov rsi, [rsi + Cons.car] + call incref_object ; Since RSI will be released + + call macroexpand ; May release and replace RSI + + mov rax, rsi + jmp .return ; Releases original AST + + ; ----------------------------- + +.try_symbol: + ; Should have the form + ; + ; (try* A (catch* B C)) + ; + ; where B is a symbol, A and C are forms to evaluate + + ; Check first arg A + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .try_pointer + + ; RSI contains a value. Copy and return + mov cl, al + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + jmp .return + +.try_pointer: + + mov r8, [rsi + Cons.car] ; form A in R8 + + ; Check second arg B + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .try_missing_catch + + mov rsi, [rsi + Cons.cdr] + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .try_missing_catch + + mov r9, [rsi + Cons.car] ; (catch* B C) in R9 + + mov al, BYTE [r9] + cmp al, (container_list + content_pointer) + jne .try_missing_catch + + mov rsi, [r9 + Cons.car] ; Should be catch* symbol + mov al, BYTE [rsi] + cmp al, maltype_symbol + jne .try_missing_catch + + mov rdi, catch_symbol + call compare_char_array + test rax, rax ; ZF set if rax = 0 (equal) + jnz .try_missing_catch + + ; Check that B is a symbol + mov al, [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_symbol + + mov r9, [r9 + Cons.cdr] ; (B C) in R9 + + mov al, BYTE [r9] + and al, content_mask + cmp al, content_pointer + jne .catch_missing_symbol + + mov r10, [r9 + Cons.car] ; B in R10 + mov al, BYTE [r10] + cmp al, maltype_symbol + jne .catch_missing_symbol + + mov al, BYTE [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_form + mov r9, [r9 + Cons.cdr] ; C in R9 + + ; Now have extracted from (try* A (catch* B C)) + ; A in R8 + ; B in R10 + ; C in T9 + + push R9 + push R10 + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the form in R8 + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + + call eval + mov r8, rax ; Result in R8 + + ; Discard B and C + ;add rsi, 8 ; pop R10 and R9 + pop r10 + pop r9 + + ; Remove error handler + call error_handler_pop + mov rax, r8 + jmp .return + +.catch: + ; Jumps here on error + ; Value thrown in RSI + ; + + pop r12 ; B (symbol to bind) + pop r13 ; C (form to evaluate) + + ; Check if C is a value or pointer + + mov cl, BYTE [r13] + and cl, content_mask + cmp cl, content_pointer + je .catch_C_pointer + + ; A value, so copy and return + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [r13 + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + jmp .return + +.catch_C_pointer: + + mov r11, rsi ; Value thrown in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + + mov rsi, rax ; New environment in RSI + mov rdi, r12 ; key (symbol) + mov rcx, r11 ; value + call env_set + + mov rdi, rsi ; Env in RDI (will be released) + mov rsi, [r13 + Cons.car] ; Form to evaluate + call incref_object ; will be released + + call eval + + jmp .return + +.try_missing_catch: + load_static try_missing_catch + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_symbol: + load_static catch_missing_symbol + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_form: + load_static catch_missing_form + call raw_to_string + mov rsi, rax + jmp error_throw + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Set ZF if RSI is a non-empty list or vector +;; Modifies RAX, does not modify RSI +is_pair: + mov al, BYTE [rsi] + test al, block_mask + jnz .false ; Not a Cons + cmp al, maltype_empty_list + je .false ; Empty list + cmp al, maltype_empty_vector + je .false ; Empty vector + + ; Something non empty + and al, container_mask + cmp al, container_list + je .true + cmp al, container_vector + je .true + ; Not a list or vector -> false + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + ret + +;; Called by eval with AST in RSI [ modified ] +;; Returns new AST in RAX +quasiquote: + ; i. Check if AST is an empty list + call is_pair + jne .quote_ast + + ; ii. Check if the first element of RSI is the symbol + ; 'unquote' + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_unquote ; Not a pointer + + mov rdi, [rsi + Cons.car] ; Get the pointer + mov cl, BYTE [rdi] + cmp cl, maltype_symbol + jne .not_unquote + + ; Compare against 'unquote' + mov r8, rsi + mov r9, rax + + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + + mov rax, r9 + mov rsi, r8 + + je .unquote + +.not_unquote: + ; iii. Handle splice-unquote + ; RSI -> ( ( splice-unquote ? ) ? ) + + ; Test if RSI contains a pointer + + cmp al, content_pointer + jne .not_splice + + mov rbx, [rsi + Cons.car] ; Get the object pointer + + ; RBX -> ( splice-unquote ? ) + + xchg rbx, rsi + call is_pair + xchg rbx, rsi + jne .not_splice ; First element not a pair + + ; Check if this list in RBX starts with 'splice-unquote' symbol + mov al, BYTE [rbx] + and al, content_mask + cmp al, content_pointer + jne .not_splice + + + mov rdi, [rbx + Cons.car] ; Get the pointer + mov al, BYTE [rdi] + cmp al, maltype_symbol + jne .not_splice + + mov r8, rsi + mov r9, rbx + + ; Compare against 'splice-unquote' + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + + mov rbx, r9 + mov rsi, r8 + + je .splice_unquote + +.not_splice: + + ; iv. Cons first and rest of AST in RSI + + ; check if pointer or value + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .cons_pointer + + ; a value, so copy + call alloc_cons + or cl, container_list + mov [rax], BYTE cl ; List + Content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + mov rcx, rax + jmp .cons_first + +.cons_pointer: + ; Get the pointer and call quasiquote + push rsi + mov rsi, [rsi + Cons.car] + call quasiquote + mov rcx, rax + pop rsi + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx + mov rcx, rax + +.cons_first: + ; Have Cons with first object in RCX + + ; Call quasiquote on the rest of the AST + ; Check if this is the end of the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .cons_ast_end + + mov rsi, [rsi + Cons.cdr] ; Rest of the list + + call incref_object ; Will release after quasiquote call + + jmp .cons_quasiquote_ast + +.cons_ast_end: + ; End of the AST, so make an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax + +.cons_quasiquote_ast: + push rcx + push rsi + call quasiquote + mov rdx, rax ; List in RDX + + pop rsi + call release_object ; Release input + + pop rcx ; Value in RCX + + ; cons RCX and RDX + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + + ; Link to the RCX Cons + mov [rcx + Cons.typecdr], BYTE content_pointer + mov [rcx + Cons.cdr], rax + mov rdx, rcx + + call alloc_cons ; Cons for cons symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the cons symbol + mov rsi, cons_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.quote_ast: + ; Return (quote RSI) + + call incref_object ; RSI reference count + + ; Cons for RSI + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rsi, rax + + ; Cons for quote symbol + call alloc_cons + mov rbx, rax + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rsi + + ; Get a quote symbol, incrementing references + mov rsi, quote_symbol + call incref_object + + ; Put into the Cons in RBX + mov [rbx + Cons.car], rsi + mov [rbx], BYTE (block_cons + container_list + content_pointer) + mov rax, rbx + ret + ; ----------------------- + +.unquote: + + ; Got unquote symbol. Return second element of RSI + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; No second element + + mov rsi, [rsi + Cons.cdr] + + ; Check if it's a value or pointer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .unquote_pointer + + ; A value, so need a new Cons + call alloc_cons + mov [rax], BYTE cl ; content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Copy content + ret + +.unquote_pointer: + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + + ; ----------------------- +.splice_unquote: + ; RSI -> ( RBX->( splice-unquote A ) B ) + ; + ; RBX Car points to splice-unquote symbol + + ; Check if there is anything after the symbol + mov al, BYTE [rbx + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_empty + + ; Point to the second element of the splice-unquote list + mov rcx, [rbx + Cons.cdr] + + ; Check whether it's a value or pointer + mov al, BYTE [rcx] + and al, content_mask + cmp al, content_pointer + je .splice_unquote_pointer + + ; A value, so change the container to a value + mov [rcx], BYTE al + ; Remove pointer from RBX + mov [rbx + Cons.typecdr], BYTE 0 + jmp .splice_unquote_first ; Got the value in RCX + +.splice_unquote_pointer: + mov rcx, [rcx + Cons.car] ; Get the object pointed to + xchg rcx, rsi + call incref_object + xchg rcx, rsi ; Object in RCX + +.splice_unquote_first: ; Got the first object in RCX + + ; Check if RSI contains anything else + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_notail + + mov rsi, [rsi + Cons.cdr] + + ; Now have: + ; ( ( splice-unquote A ) B ) + ; RCX->A RSI->( B ) + ; Need to call quasiquote on the rest of the list + push rcx + call quasiquote + mov rdx, rax + pop rcx + ; Need to concat rcx and rdx + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + mov rdx, rax ; Push list into RDX + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx ; The splice-unquote object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + call alloc_cons ; Cons for concat symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the concat symbol + mov rsi, concat_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.splice_unquote_notail: + ; Just return the object in RCX + ; since nothing to concatenate with + mov rax, rcx + ret + +.splice_unquote_empty: + ; Nothing in the (splice-unquote) list, so ignore + ; Just call quasiquote on the rest of RSI + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; Nothing else + + mov rsi, [rsi + Cons.cdr] + jmp quasiquote ; Tail call + +.empty_list: + ; Return an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list +.return: + ret + + +;; Tests if an AST in RSI is a list containing +;; a macro defined in the ENV in R15 +;; +;; Inputs: AST in RSI (not modified) +;; ENV in R15 (not modified) +;; +;; Returns: Sets ZF if macro call. If set (true), +;; then the macro object is in RAX +;; +;; Modifies: +;; RAX +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +is_macro_call: + ; Test if RSI is a list which contains a pointer + mov al, BYTE [rsi] + cmp al, (block_cons + container_list + content_pointer) + jne .false + + ; Test if this is a symbol + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .false + + ; Look up symbol in Env + push rsi + push r15 + mov rdi, rbx ; symbol in RDI + mov rsi, r15 ; Environment in RSI + call env_get + pop r15 + pop rsi + jne .false ; Not in environment + + ; Object in RAX + ; If this is not a macro then needs to be released + mov dl, BYTE [rax] + + cmp dl, maltype_macro + je .true + + ; Not a macro, so release + mov r8, rsi + mov rsi, rax + call release_object + mov rsi, r8 + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + mov rbx, rax ; Returning Macro object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Expands macro calls +;; +;; Input: AST in RSI (released and replaced) +;; Env in R15 (not modified) +;; +;; Result: New AST in RSI +macroexpand: + push r15 + + call is_macro_call + jne .done + + mov r13, rsi + + mov rdi, rax ; Macro in RDI + + ; Check the rest of the args + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + je .got_args + + ; No arguments. Create an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rdx, rax + + mov rsi, rdx ; Arguments (empty list) + call incref_object + jmp .macro_call +.got_args: + mov rsi, [rsi + Cons.cdr] ; Rest of list + call incref_object + mov rdx, rsi ; Released +.macro_call: + ; Here have: + ; RSI - Arguments + ; RDI - Macro object + ; RDX - List to release + ; R15 - Environment + ; R13 - AST + + ; Increment reference for Environment + ; since this will be released by apply_fn + xchg rsi, r15 + call incref_object + xchg rsi, r15 + + call apply_fn + + mov rsi, rax ; Result in RSI + + pop r15 + jmp macroexpand +.done: + pop r15 + ret + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; The AST from read_str is released by eval + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call rep_seq + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval-Print "(load-file )" + call rep_seq + + jmp quit From 39ad52ec27d28672ae380c2885d8bc86ce1a0ac7 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 9 Dec 2017 19:19:13 +0000 Subject: [PATCH 0316/1998] Add assoc function, small fixes Step 9 now 3 failing, 9 soft fail missing vals and dissoc functions. --- nasm/core.asm | 200 ++++++++++++++++++++++++++++++++++++++++++++++++- nasm/types.asm | 87 ++++++++++++++++++++- 2 files changed, 284 insertions(+), 3 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 3471a57d5d..9bbcac927a 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -74,6 +74,8 @@ section .data static core_vector_symbol, db "vector" static core_hashmap_symbol, db "hash-map" static core_keyword_symbol, db "keyword" + + static core_assoc_symbol, db "assoc" ;; Strings @@ -126,6 +128,12 @@ section .data static core_symbol_not_string, db "Error: symbol expects a string argument" static core_keyword_not_string, db "Error: keyword expects a string argument" + + static core_list_not_seq, db "Error: list expects a list or vector" + + static core_assoc_not_map, db "Error: assoc expects a map as first argument" + static core_assoc_missing_value, db "Error: assoc missing value" + section .text ;; Add a native function to the core environment @@ -225,6 +233,8 @@ core_environment: core_env_native core_vector_symbol, core_vector core_env_native core_hashmap_symbol, core_hashmap core_env_native core_keyword_symbol, core_keyword + + core_env_native core_assoc_symbol, core_assoc ; ----------------- ; Put the environment in RAX @@ -678,7 +688,7 @@ core_get: and bl, content_mask cmp bl, content_nil - jmp .not_found + je .not_found cmp bl, content_pointer jne .not_map @@ -694,6 +704,7 @@ core_get: cmp bl, content_pointer jne .no_key mov rsi, [rsi + Cons.cdr] + mov dl, BYTE [rsi] and dl, content_mask cmp dl, content_pointer @@ -736,6 +747,10 @@ core_list: mov rax, rsi ret +.not_seq: + load_static core_list_not_seq + jmp core_throw_str + ;; Convert arguments into a vector core_vector: ; Copy first element and mark as vector @@ -1147,7 +1162,16 @@ core_pointer_type_p: cmp bl, al jne .false - ; Got an atom, return true + ; Check for keyword (not symbol) + cmp al, maltype_symbol + jne .true + + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .false ; a keyword + +.true: + ; Return true call alloc_cons mov [rax], BYTE maltype_true ret @@ -2326,7 +2350,54 @@ core_apply: jnz .last_append ; R9 is zero, so no previous args + + ; check that this is a list + ; and convert vector to list + mov r9, rsi + + ; Check if R9 is a list + mov al, BYTE [r9] + mov cl, al + and al, container_mask + cmp al, container_list + je .run + + ; Convert vector to list by copying first element + + call alloc_cons + and cl, content_mask + or cl, container_list + mov [rax], BYTE cl + mov rdx, [r9 + Cons.car] + mov [rax + Cons.car], rdx + + ; check if contains a pointer + cmp cl, (container_list + content_pointer) + jne .copy_cdr + + ; A pointer, so increment reference + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + +.copy_cdr: + mov bl, BYTE [r9 + Cons.typecdr] + mov rcx, [r9 + Cons.cdr] + mov [rax + Cons.typecdr], BYTE bl + mov [rax + Cons.cdr], rcx + + ; Replace R9 with this new element + mov r9, rax + + cmp bl, content_pointer + jne .run + + ; A pointer, so increment reference + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + jmp .run .last_append: @@ -2450,3 +2521,128 @@ core_keyword: .not_string: load_static core_keyword_not_string jmp core_throw_str + +;; Sets values in a map +core_assoc: + ; check first arg + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov r8, [rsi + Cons.car] ; map in R8 + mov al, BYTE [r8] + and al, container_mask + cmp al, container_map + jne .not_map + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + je .start + + ; No keys to set, so just increment and return + mov rsi, r8 + call incref_object + mov rax, rsi + ret + +.start: + mov r11, [rsi + Cons.cdr] ; List of keys/values in R11 + + ; Copy the original list + mov rsi, r8 + call map_copy + mov rsi, rax ; new map in RSI + +.loop: + ; Get key then value from R11 list + + mov cl, BYTE [r11] + and cl, content_mask + cmp cl, content_pointer + je .key_pointer + + ; Key is a value, so copy into a Cons + call alloc_cons + mov [rax], BYTE cl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + mov rdi, rax ; Key in RDI + jmp .get_value + +.key_pointer: + mov rdi, [r11 + Cons.car] + ; increment reference count because the key will be + ; released after setting (to allow value Cons to be + ; freed) + + mov bx, WORD [rdi + Cons.refcount] + inc bx + mov [rdi + Cons.refcount], WORD bx + +.get_value: + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .missing_value + + mov r11, [r11 + Cons.cdr] + + ; Check if value is a pointer + mov cl, BYTE [r11] + and cl, content_mask + cmp cl, content_pointer + je .value_pointer + + ; Value is a value, so copy into a Cons + call alloc_cons + mov [rax], BYTE cl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + mov rcx, rax ; Key in RCX + jmp .set_pair + +.value_pointer: + mov rcx, [r11 + Cons.car] + ; increment reference count because the value will be + ; released after setting (to allow value Cons to be + ; freed) + + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.set_pair: + ; Here have: + ; map in RSI + ; key in RDI + ; value in RCX + + call map_set + + mov r8, rsi ; map + mov rsi, rdi ; key + call release_object + mov rsi, rcx ; value + call release_object + mov rsi, r8 ; map + + ; Check if there's another pair + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; got another pair + mov r11, [r11 + Cons.cdr] + jmp .loop + +.done: + mov rax, rsi ; new map + ret + +.not_map: + load_static core_assoc_not_map + jmp core_throw_str + +.missing_value: + load_static core_assoc_missing_value + jmp core_throw_str diff --git a/nasm/types.asm b/nasm/types.asm index 7352c7499e..2b8eed6a7d 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -155,7 +155,7 @@ section .data ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 1000 ; Number of cons objects which can be created +%define heap_cons_limit 2000 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list @@ -1010,6 +1010,9 @@ compare_objects: mov cl, BYTE [rsi] ; Type of RSI mov bl, BYTE [rdi] ; Type of RDI + mov ch, cl + mov bh, bl + ; Don't care about container type and cl, block_mask + content_mask and bl, block_mask + content_mask @@ -1019,6 +1022,19 @@ compare_objects: ; Here the same block, content type ; May be different container (value/list, string/symbol) + + ; Need to distinguish between map and vector/list + and ch, container_mask + and bh, container_mask + cmp ch, bh + je .same_container + ; if either is a map, then different types + cmp ch, container_map + je .different_types + cmp bh, container_map + je .different_types + +.same_container: cmp bl, block_cons + content_nil je .objects_equal ; nil @@ -1077,6 +1093,22 @@ compare_objects_rec: cmp ah, bh jne .false + + ; Need to distinguish between map and vector/list + mov ah, al + mov bh, bl + + and ah, container_mask + and bh, container_mask + cmp ah, bh + je .same_container + ; if either is a map, then different types + cmp ah, container_map + je .false + cmp bh, container_map + je .false + +.same_container: ; Check the container type and bh, block_mask @@ -1224,6 +1256,59 @@ map_new: mov [rax], BYTE (block_cons + container_map + content_empty) mov [rax + Cons.typecdr], BYTE content_nil ret + +;; Copy map +;; +;; Input: RSI - map +;; +;; Returns: new map in RAX +;; +;; Modifies: +;; RAX, RBX, RCX, R13, R14, R15 +;; +map_copy: + mov r14, rsi + + call alloc_cons + mov r15, rax ; start of new map + xor r13, r13 +.loop: + mov bl, BYTE [rsi] + mov rcx, [rsi + Cons.car] + mov [rax], BYTE bl ; copy type + mov [rax + Cons.car], rcx ; copy value + + and bl, content_mask + cmp bl, content_pointer + jne .set_cdr + + ; A pointer in CAR. Increase reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.set_cdr: + test r13,r13 + jz .next + + ; R13 contains last Cons + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax +.next: + mov r13, rax + + ; Check if there's another Cons + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .done ; no more + + mov rsi, [rsi + Cons.cdr] ; next + call alloc_cons + jmp .loop +.done: + mov rax, r15 + mov rsi, r14 + ret ;; Add to map. Input is a list with an even number of values From 13b2edea4ca27bb990c9040848a9de8d268c335e Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 11 Dec 2017 22:39:42 +0000 Subject: [PATCH 0317/1998] Add vals and dissoc functions step 9 now only 3 soft-fail tests. All comparisons of maps, where the order of keys shouldn't matter but does. --- nasm/core.asm | 215 ++++++++++++++++++++++++++++++++++++++++++++++++- nasm/types.asm | 87 +++++++++++++++++++- 2 files changed, 299 insertions(+), 3 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 9bbcac927a..a2a7988429 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -23,6 +23,7 @@ section .data static core_count_symbol, db "count" static core_keys_symbol, db "keys" + static core_vals_symbol, db "vals" static core_list_symbol, db "list" @@ -76,6 +77,7 @@ section .data static core_keyword_symbol, db "keyword" static core_assoc_symbol, db "assoc" + static core_dissoc_symbol, db "dissoc" ;; Strings @@ -84,6 +86,10 @@ section .data static core_emptyp_error_string, db "empty? expects a list, vector or map",10 static core_count_error_string, db "count expects a list or vector",10 + + static core_keys_not_map, db "keys expects a map as first argument" + static core_vals_not_map, db "vals expects a map as first argument" + static core_numeric_expect_ints, db "comparison operator expected two numbers",10 static core_deref_not_atom, db "Error: argument to deref is not an atom" @@ -133,6 +139,9 @@ section .data static core_assoc_not_map, db "Error: assoc expects a map as first argument" static core_assoc_missing_value, db "Error: assoc missing value" + + static core_dissoc_not_map, db "dissoc expects a map as first argument" + static core_dissoc_missing_value, db "Missing value in map passed to dissoc" section .text @@ -182,6 +191,8 @@ core_environment: core_env_native core_le_symbol, core_le core_env_native core_keys_symbol, core_keys + core_env_native core_vals_symbol, core_vals + core_env_native core_list_symbol, core_list core_env_native core_pr_str_symbol, core_pr_str @@ -235,6 +246,7 @@ core_environment: core_env_native core_keyword_symbol, core_keyword core_env_native core_assoc_symbol, core_assoc + core_env_native core_dissoc_symbol, core_dissoc ; ----------------- ; Put the environment in RAX @@ -618,10 +630,32 @@ core_count: ;; Input: List in RSI with one Map element ;; Returns: List in RAX core_keys: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + mov rsi, [rsi + Cons.car] call map_keys ret - +.not_map: + load_static core_keys_not_map + jmp core_throw_str + +;; Get a list of values from a map +core_vals: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov rsi, [rsi + Cons.car] + call map_vals + ret +.not_map: + load_static core_vals_not_map + jmp core_throw_str + ;; Given a map and a key, return true if the key is in the map ;; core_containsp: @@ -2646,3 +2680,182 @@ core_assoc: .missing_value: load_static core_assoc_missing_value jmp core_throw_str + + +;; Removes keys from a map by making +;; a copy of a map without the given keys +core_dissoc: + ; Check that the first argument is a map + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov r8, [rsi + Cons.car] ; Map in R8 + mov al, BYTE [r8] + mov ah, al + and al, container_mask + cmp al, container_map + jne .not_map + + ; Check if the map is empty + cmp ah, maltype_empty_map + je .inc_and_return + + ; Now check if there are other arguments + + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + je .start + +.inc_and_return: + ; No keys to remove + ; just increment the map reference count and return + mov rsi, r8 + call incref_object + mov rax, rsi + ret + +.start: + ; Some keys to remove + mov r9, [rsi + Cons.cdr] + + ; R9 now contains a list of keys + ; R8 contains the map to copy + + xor r11, r11 ; Head of list to return + ; R12 contains tail + +.loop: + ; Check the key in R8 against the list in R9 + mov r10, r9 ; point in list being searched + + ; loop through the list in R10 + ; comparing each element against R8 +.search_loop: + mov rsi, r8 + mov rdi, r10 + call compare_objects + test rax, rax + jz .found ; objects are equal + + ; Not found so check next in list + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .not_found ; End of list + + mov r10, [r10 + Cons.cdr] ; next + jmp .search_loop + +.found: + ; Removing this key, so skip + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .missing_value + + mov r8, [r8 + Cons.cdr] ; now a value + jmp .next + +.not_found: + ; Key not in list, so keeping + ; Create a Cons to copy + call alloc_cons + mov bl, [r8] + mov rcx, [r8 + Cons.car] + + mov [rax], BYTE bl + mov [rax + Cons.car], rcx + + ; Check if a pointer or value + and bl, content_mask + cmp bl, content_pointer + jne .done_key ; A value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_key: + ; append to list + + test r11, r11 + jnz .key_append + + ; First one + mov r11, rax + mov r12, rax + jmp .copy_value +.key_append: + + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + mov r12, rax + +.copy_value: + + ; Check there is a value + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .missing_value + + mov r8, [r8 + Cons.cdr] ; Value + + ; Same as for key; create a Cons and copy + call alloc_cons + mov bl, [r8] + mov rcx, [r8 + Cons.car] + + mov [rax], BYTE bl + mov [rax + Cons.car], rcx + + ; Check if a pointer or value + and bl, content_mask + cmp bl, content_pointer + jne .done_value ; A value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_value: + ; append to list + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + mov r12, rax + +.next: + ; Here R8 contains a value + + ; Check if there's another key + mov al, [r8 + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; Still more + + mov r8, [r8 + Cons.cdr] + jmp .loop + +.done: + ; Check if the map is empty + test r11, r11 + jz .return_empty + + ; not empty, so return + mov rax, r11 + ret + +.return_empty: + call alloc_cons + mov [rax], BYTE maltype_empty_map + ret + +.not_map: + load_static core_dissoc_not_map + jmp core_throw_str + +.missing_value: + load_static core_dissoc_missing_value + jmp core_throw_str diff --git a/nasm/types.asm b/nasm/types.asm index 2b8eed6a7d..445bfabc31 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -994,8 +994,8 @@ compare_get_value: ;; but will just compare the first element ;; ;; Modifies registers -;; RCX -;; RBX +;; RAX, RBX, RCX, RDX +;; compare_objects: ; Get the value that RSI points to call compare_get_value @@ -1823,7 +1823,90 @@ map_keys: call alloc_cons mov [rax], BYTE maltype_empty_list ret + +;; Get a list of values +;; +;; Input: Map in RSI +;; +;; Returns: List in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; R8 +;; R9 +map_vals: + ; check type + mov al, BYTE [rsi] + cmp al, maltype_empty_map + je .empty_map + + and al, container_mask + cmp al, container_map + jne .empty_map ; error + + xor r8, r8 ; Return list + +.loop: + ; Here should have a key in RSI + + ; First get the value + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done ; error. Should be a value + + mov rsi, [rsi + Cons.cdr] ; Now have value in RSI + ; Create a new Cons for this value + call alloc_cons + mov cl, BYTE [rsi] + and cl, content_mask + add cl, block_cons + container_list + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + and cl, content_mask + cmp cl, content_pointer + jne .append + + ; A pointer, so increment reference count + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.append: + cmp r8, 0 + je .first + + ; appending + mov [r9 + Cons.typecdr], BYTE content_pointer + mov [r9 + Cons.cdr], rax + mov r9, rax + jmp .next +.first: + ; First key, so put into r8 + mov r8, rax + mov r9, rax +.next: + ; Get the next key + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + mov rsi, [rsi + Cons.cdr] + jmp .loop +.done: + ; Finished, return the list + mov rax, r8 + ret + +.empty_map: + ; return empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + ;; ------------------------------------------------------------ ;; Function type From 4f9baa2bc4520aca5b3d54a4ddbb35464c797b87 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 11 Dec 2017 23:21:48 +0000 Subject: [PATCH 0318/1998] Start step A, add readline prints header string, readline working. --- nasm/core.asm | 43 + nasm/stepA_mal.asm | 2689 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 2732 insertions(+) create mode 100644 nasm/stepA_mal.asm diff --git a/nasm/core.asm b/nasm/core.asm index a2a7988429..5c8eb564e4 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -78,6 +78,8 @@ section .data static core_assoc_symbol, db "assoc" static core_dissoc_symbol, db "dissoc" + + static core_readline_symbol, db "readline" ;; Strings @@ -247,6 +249,8 @@ core_environment: core_env_native core_assoc_symbol, core_assoc core_env_native core_dissoc_symbol, core_dissoc + + core_env_native core_readline_symbol, core_readline ; ----------------- ; Put the environment in RAX @@ -2859,3 +2863,42 @@ core_dissoc: .missing_value: load_static core_dissoc_missing_value jmp core_throw_str + + +;; Takes a string prompt for the user, and returns +;; a string or nil +core_readline: + ; Check the input + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .no_prompt + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .no_prompt + + ; Got a string in RSI + call print_string + +.no_prompt: + + ; Get string from user + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .return_nil + + ; return the string in RAX + ret + +.return_nil: + ; release string in RAX + mov rsi, rax + call release_array + + call alloc_cons + mov [rax], BYTE maltype_nil + ret diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm new file mode 100644 index 0000000000..0d0d9bb8ef --- /dev/null +++ b/nasm/stepA_mal.asm @@ -0,0 +1,2689 @@ +;; +;; nasm -felf64 stepA_mal.asm && ld stepA_mal.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +;; Error handler list +error_handler: resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static defmacro_expecting_function_string, db "defmacro expects function",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + + static try_missing_catch, db "try* missing catch*" + static catch_missing_symbol, db "catch* missing symbol" + static catch_missing_form, db "catch* missing form" + +;; Symbols used for comparison + + ; Special symbols + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + static_symbol defmacro_symbol, 'defmacro!' + static_symbol macroexpand_symbol, 'macroexpand' + static_symbol try_symbol, 'try*' + static_symbol catch_symbol, 'catch*' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + ; + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) (def! *host-language* ",34,"nasm",34,") )" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 + +;; Command to run at start of REPL + static mal_startup_header, db "(println (str ",34,"Mal [",34," *host-language* ",34,"]",34,"))" +section .text + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + ; Note: This can't use content_pointer or release + ; will try to release this memory address + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + ;call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + mov [rsi + Cons.typecdr], BYTE 0 + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + mov r11, rsi ; Symbol in R11 + + call string_new + mov rsi, rax ; New string in RSI + + mov cl, 39 ; quote ' + call string_append_char + + mov rdx, r11 ; symbol + call string_append_string + + mov cl, 39 + call string_append_char + + mov r11, rsi + + mov rsi, not_found_string + mov edx, not_found_string.len + call raw_to_string ; ' not found' + + mov r12, rax + + mov rdx, rax + mov rsi, r11 + call string_append_string + + mov r11, rsi + mov rsi, r12 + call release_array + mov rsi, r11 + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .return_nil + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Macro expand + pop rax ; Old AST, discard from stack + call macroexpand ; Replaces RSI + push rsi ; New AST + + ; Check if RSI is a list, and if + ; the first element is a symbol + mov al, BYTE [rsi] + + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list_still_list + + ; Not a list, so call eval_ast on it + mov rdi, r15 ; Environment + call eval_ast + jmp .return + +.list_still_list: + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + eval_cmp_symbol defmacro_symbol ; defmacro! + je .defmacro_symbol + + eval_cmp_symbol macroexpand_symbol ; macroexpand + je .macroexpand_symbol + + eval_cmp_symbol try_symbol ; try* + je .try_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.defmacro_symbol: + mov r9, 1 + jmp .def_common +.def_symbol: + xor r9, r9 ; Set R9 to 0 +.def_common: + ; Define a new symbol in current environment + ; If R9 is set to 1 then defmacro + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + + ; Test if this is defmacro! + test r9, r9 + jnz .defmacro_not_function + + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + push r9 + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r9 + + ; If this is defmacro, and the object in RSI is a function, + ; then change to a macro + test r9, r9 + jz .def_not_macro ; Not defmacro + + ; Check RSI + mov al, BYTE [rsi] + cmp al, maltype_function + jne .defmacro_not_function + + ; Got a function, change to macro + mov [rsi], BYTE maltype_macro + +.def_not_macro: + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.defmacro_not_function: + mov rsi, defmacro_expecting_function_string + mov rdx, defmacro_expecting_function_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + ; Uncomment these two lines to test quasiquote + ;call quasiquote + ;ret + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- +.macroexpand_symbol: + ; Check if we have a second list element + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .macroexpand_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.macroexpand_pointer: + mov rsi, [rsi + Cons.car] + call incref_object ; Since RSI will be released + + call macroexpand ; May release and replace RSI + + mov rax, rsi + jmp .return ; Releases original AST + + ; ----------------------------- + +.try_symbol: + ; Should have the form + ; + ; (try* A (catch* B C)) + ; + ; where B is a symbol, A and C are forms to evaluate + + ; Check first arg A + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .try_pointer + + ; RSI contains a value. Copy and return + mov cl, al + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + jmp .return + +.try_pointer: + + mov r8, [rsi + Cons.car] ; form A in R8 + + ; Check second arg B + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .try_missing_catch + + mov rsi, [rsi + Cons.cdr] + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .try_missing_catch + + mov r9, [rsi + Cons.car] ; (catch* B C) in R9 + + mov al, BYTE [r9] + cmp al, (container_list + content_pointer) + jne .try_missing_catch + + mov rsi, [r9 + Cons.car] ; Should be catch* symbol + mov al, BYTE [rsi] + cmp al, maltype_symbol + jne .try_missing_catch + + mov rdi, catch_symbol + call compare_char_array + test rax, rax ; ZF set if rax = 0 (equal) + jnz .try_missing_catch + + ; Check that B is a symbol + mov al, [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_symbol + + mov r9, [r9 + Cons.cdr] ; (B C) in R9 + + mov al, BYTE [r9] + and al, content_mask + cmp al, content_pointer + jne .catch_missing_symbol + + mov r10, [r9 + Cons.car] ; B in R10 + mov al, BYTE [r10] + cmp al, maltype_symbol + jne .catch_missing_symbol + + mov al, BYTE [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_form + mov r9, [r9 + Cons.cdr] ; C in R9 + + ; Now have extracted from (try* A (catch* B C)) + ; A in R8 + ; B in R10 + ; C in T9 + + push R9 + push R10 + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the form in R8 + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + + call eval + mov r8, rax ; Result in R8 + + ; Discard B and C + ;add rsi, 8 ; pop R10 and R9 + pop r10 + pop r9 + + ; Remove error handler + call error_handler_pop + mov rax, r8 + jmp .return + +.catch: + ; Jumps here on error + ; Value thrown in RSI + ; + + pop r12 ; B (symbol to bind) + pop r13 ; C (form to evaluate) + + ; Check if C is a value or pointer + + mov cl, BYTE [r13] + and cl, content_mask + cmp cl, content_pointer + je .catch_C_pointer + + ; A value, so copy and return + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [r13 + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + jmp .return + +.catch_C_pointer: + + mov r11, rsi ; Value thrown in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + + mov rsi, rax ; New environment in RSI + mov rdi, r12 ; key (symbol) + mov rcx, r11 ; value + call env_set + + mov rdi, rsi ; Env in RDI (will be released) + mov rsi, [r13 + Cons.car] ; Form to evaluate + call incref_object ; will be released + + call eval + + jmp .return + +.try_missing_catch: + load_static try_missing_catch + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_symbol: + load_static catch_missing_symbol + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_form: + load_static catch_missing_form + call raw_to_string + mov rsi, rax + jmp error_throw + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Set ZF if RSI is a non-empty list or vector +;; Modifies RAX, does not modify RSI +is_pair: + mov al, BYTE [rsi] + test al, block_mask + jnz .false ; Not a Cons + cmp al, maltype_empty_list + je .false ; Empty list + cmp al, maltype_empty_vector + je .false ; Empty vector + + ; Something non empty + and al, container_mask + cmp al, container_list + je .true + cmp al, container_vector + je .true + ; Not a list or vector -> false + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + ret + +;; Called by eval with AST in RSI [ modified ] +;; Returns new AST in RAX +quasiquote: + ; i. Check if AST is an empty list + call is_pair + jne .quote_ast + + ; ii. Check if the first element of RSI is the symbol + ; 'unquote' + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_unquote ; Not a pointer + + mov rdi, [rsi + Cons.car] ; Get the pointer + mov cl, BYTE [rdi] + cmp cl, maltype_symbol + jne .not_unquote + + ; Compare against 'unquote' + mov r8, rsi + mov r9, rax + + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + + mov rax, r9 + mov rsi, r8 + + je .unquote + +.not_unquote: + ; iii. Handle splice-unquote + ; RSI -> ( ( splice-unquote ? ) ? ) + + ; Test if RSI contains a pointer + + cmp al, content_pointer + jne .not_splice + + mov rbx, [rsi + Cons.car] ; Get the object pointer + + ; RBX -> ( splice-unquote ? ) + + xchg rbx, rsi + call is_pair + xchg rbx, rsi + jne .not_splice ; First element not a pair + + ; Check if this list in RBX starts with 'splice-unquote' symbol + mov al, BYTE [rbx] + and al, content_mask + cmp al, content_pointer + jne .not_splice + + + mov rdi, [rbx + Cons.car] ; Get the pointer + mov al, BYTE [rdi] + cmp al, maltype_symbol + jne .not_splice + + mov r8, rsi + mov r9, rbx + + ; Compare against 'splice-unquote' + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + + mov rbx, r9 + mov rsi, r8 + + je .splice_unquote + +.not_splice: + + ; iv. Cons first and rest of AST in RSI + + ; check if pointer or value + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .cons_pointer + + ; a value, so copy + call alloc_cons + or cl, container_list + mov [rax], BYTE cl ; List + Content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + mov rcx, rax + jmp .cons_first + +.cons_pointer: + ; Get the pointer and call quasiquote + push rsi + mov rsi, [rsi + Cons.car] + call quasiquote + mov rcx, rax + pop rsi + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx + mov rcx, rax + +.cons_first: + ; Have Cons with first object in RCX + + ; Call quasiquote on the rest of the AST + ; Check if this is the end of the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .cons_ast_end + + mov rsi, [rsi + Cons.cdr] ; Rest of the list + + call incref_object ; Will release after quasiquote call + + jmp .cons_quasiquote_ast + +.cons_ast_end: + ; End of the AST, so make an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax + +.cons_quasiquote_ast: + push rcx + push rsi + call quasiquote + mov rdx, rax ; List in RDX + + pop rsi + call release_object ; Release input + + pop rcx ; Value in RCX + + ; cons RCX and RDX + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + + ; Link to the RCX Cons + mov [rcx + Cons.typecdr], BYTE content_pointer + mov [rcx + Cons.cdr], rax + mov rdx, rcx + + call alloc_cons ; Cons for cons symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the cons symbol + mov rsi, cons_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.quote_ast: + ; Return (quote RSI) + + call incref_object ; RSI reference count + + ; Cons for RSI + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rsi, rax + + ; Cons for quote symbol + call alloc_cons + mov rbx, rax + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rsi + + ; Get a quote symbol, incrementing references + mov rsi, quote_symbol + call incref_object + + ; Put into the Cons in RBX + mov [rbx + Cons.car], rsi + mov [rbx], BYTE (block_cons + container_list + content_pointer) + mov rax, rbx + ret + ; ----------------------- + +.unquote: + + ; Got unquote symbol. Return second element of RSI + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; No second element + + mov rsi, [rsi + Cons.cdr] + + ; Check if it's a value or pointer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .unquote_pointer + + ; A value, so need a new Cons + call alloc_cons + mov [rax], BYTE cl ; content + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Copy content + ret + +.unquote_pointer: + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + + ; ----------------------- +.splice_unquote: + ; RSI -> ( RBX->( splice-unquote A ) B ) + ; + ; RBX Car points to splice-unquote symbol + + ; Check if there is anything after the symbol + mov al, BYTE [rbx + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_empty + + ; Point to the second element of the splice-unquote list + mov rcx, [rbx + Cons.cdr] + + ; Check whether it's a value or pointer + mov al, BYTE [rcx] + and al, content_mask + cmp al, content_pointer + je .splice_unquote_pointer + + ; A value, so change the container to a value + mov [rcx], BYTE al + ; Remove pointer from RBX + mov [rbx + Cons.typecdr], BYTE 0 + jmp .splice_unquote_first ; Got the value in RCX + +.splice_unquote_pointer: + mov rcx, [rcx + Cons.car] ; Get the object pointed to + xchg rcx, rsi + call incref_object + xchg rcx, rsi ; Object in RCX + +.splice_unquote_first: ; Got the first object in RCX + + ; Check if RSI contains anything else + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .splice_unquote_notail + + mov rsi, [rsi + Cons.cdr] + + ; Now have: + ; ( ( splice-unquote A ) B ) + ; RCX->A RSI->( B ) + ; Need to call quasiquote on the rest of the list + push rcx + call quasiquote + mov rdx, rax + pop rcx + ; Need to concat rcx and rdx + ; Work from the end of the list to the front + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rdx ; The rest of AST + mov rdx, rax ; Push list into RDX + + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx ; The splice-unquote object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + call alloc_cons ; Cons for concat symbol + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rdx + mov rdx, rax + + ; Get the concat symbol + mov rsi, concat_symbol + call incref_object + + mov [rdx], BYTE (container_list + content_pointer) + mov [rdx + Cons.car], rsi + + mov rax, rdx + ret + +.splice_unquote_notail: + ; Just return the object in RCX + ; since nothing to concatenate with + mov rax, rcx + ret + +.splice_unquote_empty: + ; Nothing in the (splice-unquote) list, so ignore + ; Just call quasiquote on the rest of RSI + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .empty_list ; Nothing else + + mov rsi, [rsi + Cons.cdr] + jmp quasiquote ; Tail call + +.empty_list: + ; Return an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list +.return: + ret + + +;; Tests if an AST in RSI is a list containing +;; a macro defined in the ENV in R15 +;; +;; Inputs: AST in RSI (not modified) +;; ENV in R15 (not modified) +;; +;; Returns: Sets ZF if macro call. If set (true), +;; then the macro object is in RAX +;; +;; Modifies: +;; RAX +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +is_macro_call: + ; Test if RSI is a list which contains a pointer + mov al, BYTE [rsi] + cmp al, (block_cons + container_list + content_pointer) + jne .false + + ; Test if this is a symbol + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .false + + ; Look up symbol in Env + push rsi + push r15 + mov rdi, rbx ; symbol in RDI + mov rsi, r15 ; Environment in RSI + call env_get + pop r15 + pop rsi + jne .false ; Not in environment + + ; Object in RAX + ; If this is not a macro then needs to be released + mov dl, BYTE [rax] + + cmp dl, maltype_macro + je .true + + ; Not a macro, so release + mov r8, rsi + mov rsi, rax + call release_object + mov rsi, r8 + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + mov rbx, rax ; Returning Macro object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Expands macro calls +;; +;; Input: AST in RSI (released and replaced) +;; Env in R15 (not modified) +;; +;; Result: New AST in RSI +macroexpand: + push r15 + + call is_macro_call + jne .done + + mov r13, rsi + + mov rdi, rax ; Macro in RDI + + ; Check the rest of the args + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + je .got_args + + ; No arguments. Create an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rdx, rax + + mov rsi, rdx ; Arguments (empty list) + call incref_object + jmp .macro_call +.got_args: + mov rsi, [rsi + Cons.cdr] ; Rest of list + call incref_object + mov rdx, rsi ; Released +.macro_call: + ; Here have: + ; RSI - Arguments + ; RDI - Macro object + ; RDX - List to release + ; R15 - Environment + ; R13 - AST + + ; Increment reference for Environment + ; since this will be released by apply_fn + xchg rsi, r15 + call incref_object + xchg rsi, r15 + + call apply_fn + + mov rsi, rax ; Result in RSI + + pop r15 + jmp macroexpand +.done: + pop r15 + ret + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably + call pr_str + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; The AST from read_str is released by eval + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Header + + load_static mal_startup_header + call raw_to_string + push rax + + mov rsi, rax + call rep_seq + + ; Release the input string + pop rsi + call release_array + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the input string + + ; Put into read_str + mov rsi, rax + call rep_seq + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval-Print "(load-file )" + call rep_seq + + jmp quit From 1f254872a3db1ee2944f1efff8a2ee7f8ffaabd7 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 12 Dec 2017 23:49:07 +0000 Subject: [PATCH 0319/1998] Add meta, with-meta and ^ reader Native and user-defined functions now have metadata, which can be set using with-data, and retrieved using meta. The ^ reader converts "^ A B" into (with-meta B A) --- nasm/core.asm | 151 +++++++++++++++++++++++++++++++++++++++++++++ nasm/reader.asm | 62 ++++++++++++++++++- nasm/stepA_mal.asm | 16 ++++- nasm/types.asm | 21 +++++-- 4 files changed, 241 insertions(+), 9 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 5c8eb564e4..1132b775ff 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -80,6 +80,9 @@ section .data static core_dissoc_symbol, db "dissoc" static core_readline_symbol, db "readline" + + static core_meta_symbol, db "meta" + static core_with_meta_symbol, db "with-meta" ;; Strings @@ -144,6 +147,9 @@ section .data static core_dissoc_not_map, db "dissoc expects a map as first argument" static core_dissoc_missing_value, db "Missing value in map passed to dissoc" + + static core_with_meta_no_function, db "with-meta expects a function as first argument" + static core_with_meta_no_value, db "with-meta expects a value as second argument" section .text @@ -251,6 +257,9 @@ core_environment: core_env_native core_dissoc_symbol, core_dissoc core_env_native core_readline_symbol, core_readline + + core_env_native core_meta_symbol, core_meta + core_env_native core_with_meta_symbol, core_with_meta ; ----------------- ; Put the environment in RAX @@ -2902,3 +2911,145 @@ core_readline: call alloc_cons mov [rax], BYTE maltype_nil ret + + +;; Return the meta data associated with a given function +core_meta: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .return_nil + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, (block_cons + container_function + content_function) + jne .return_nil + + ; Here got a function + mov rsi, [rsi + Cons.cdr] + + ; RSI should now contain the meta data + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .pointer + + ; A value, so copy + call alloc_cons + mov [rax], BYTE cl + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + ret + +.pointer: + ; A pointer, so increment reference count and return + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + +;; Associates a value with a function (native or user) +core_with_meta: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .no_function + + mov r8, [rsi + Cons.car] ; Function in R8 + mov al, BYTE [r8] + cmp al, (block_cons + container_function + content_function) + jne .no_function + + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_value + + mov rsi, [rsi + Cons.cdr] + + ; Function in R8, new value in RSI + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) ; Type + mov rbx, [r8 + Cons.car] + mov [rax + Cons.car], rbx ; Function address + + mov r10, rax ; Return address + + ; Copy the meta data + + mov r8, [r8 + Cons.cdr] ; R8 now old meta data (not used) + + call alloc_cons + + mov cl, BYTE [rsi] + and cl, content_mask + mov ch, cl + or cl, container_function + mov [rax], BYTE cl ; Set type + + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Copy value + + ; append to function + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r11, rax + + ; Check if meta is a value or pointer + cmp ch, content_pointer + jne .copy_rest + + ; increment reference count of meta + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.copy_rest: + ; Copy remainder of function (if any) + ; If a user function, has (env binds body) + mov al, [r8 + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; Still more to copy + mov r8, [r8 + Cons.cdr] + + call alloc_cons + mov bl, BYTE [r8] + mov [rax], BYTE bl ; Copy type + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx ; Copy value + + ; append + mov [r11 + Cons.typecdr], BYTE content_pointer + mov [r11 + Cons.cdr], rax + mov r11, rax + + ; Check if it's a pointer + and bl, content_mask + cmp bl, content_pointer + jne .copy_rest + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + jmp .copy_rest + +.done: + mov rax, r10 + ret + +.no_function: + load_static core_with_meta_no_function + jmp core_throw_str + +.no_value: + load_static core_with_meta_no_value + jmp core_throw_str diff --git a/nasm/reader.asm b/nasm/reader.asm index 57c8aa92d2..8c040b5418 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -9,7 +9,7 @@ section .data static unquote_symbol_string, db "unquote" static splice_unquote_symbol_string, db "splice-unquote" static deref_symbol_string, db "deref" - + static with_meta_symbol_string, db "with-meta" ;; Error message strings @@ -113,6 +113,9 @@ read_str: cmp cl, '@' je .handle_deref + cmp cl, '^' + je .handle_with_meta + ; Unknown jmp .return_nil @@ -523,7 +526,7 @@ read_str: pop r9 pop r8 jmp .wrap_next_object ; From there the same as handle_quote - + ; -------------------------------- .handle_deref: @@ -541,6 +544,61 @@ read_str: pop r9 pop r8 jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- + +.handle_with_meta: + ; Turn ^ a b into (with-meta b a) + + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "with-meta" + push r8 + push r9 + mov rsi, with_meta_symbol_string + mov edx, with_meta_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + + mov [rax], BYTE maltype_symbol + mov [r12], BYTE (block_cons + container_list + content_pointer) + mov [r12 + Cons.car], rax + + ; Get the next two objects + push r12 + call .read_loop ; object in rax + pop r12 + push rax + push r12 + call .read_loop ; in RAX + pop r12 + + mov r13, rax + + call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r13 + + ; Cons object in rax. Append to object in r12 + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + + mov r13, rax + + call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_pointer) + + pop rdi ; First object + mov [rax + Cons.car], rdi + + ; Append to object in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + + mov rax, r12 + ret ; -------------------------------- .symbol: diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index 0d0d9bb8ef..fff7f55972 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -1471,19 +1471,32 @@ eval: mov [rax + Cons.typecdr], BYTE content_pointer mov r13, rax ; Return list in R13 + + ; Meta + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append + mov r14, rax + + ; Env call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) mov [rax + Cons.car], r15 ; Environment mov [rax + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax ; Append to list + mov [r14 + Cons.cdr], rax ; Append to list mov r14, rax push rax mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) @@ -1909,6 +1922,7 @@ apply_fn: push rsi ; Extract values from the list in RDI mov rax, [rdi + Cons.cdr] + mov rax, [rax + Cons.cdr] ; Meta (don't need) mov rsi, [rax + Cons.car] ; Env mov rax, [rax + Cons.cdr] mov rdi, [rax + Cons.car] ; Binds diff --git a/nasm/types.asm b/nasm/types.asm index 445bfabc31..bd6a682766 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -1913,18 +1913,27 @@ map_vals: ;; ;; Functions are consist of a list ;; - First car is the function address to call -;; - Second is the environment -;; - Third is the binds list -;; - Fourth is the body of the function +;; - Second is the Meta data (nil by default) +;; - Third is the environment +;; - Fourth is the binds list +;; - Fifth is the body of the function ;; -;; ( addr env binds body ) +;; ( addr meta env binds body ) ;; ;; ;; Address of native function in RSI ;; returns Function object in RAX -native_function: - call alloc_cons +native_function: + call alloc_cons ; for meta + mov [rax], BYTE maltype_nil + push rax + + call alloc_cons ; For function address mov [rax], BYTE (block_cons + container_function + content_function) mov [rax + Cons.car], rsi + + mov [rax + Cons.typecdr], BYTE content_pointer + pop rbx ; meta + mov [rax + Cons.cdr], rbx ret From 0119b269f2be6b921d6e15cce1257bbdbdbb23d2 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 12 Dec 2017 23:50:34 +0000 Subject: [PATCH 0320/1998] Adding gensym, clean or macro Replacement for earlier macro, now using gensym --- nasm/stepA_mal.asm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index fff7f55972..39ca481fc3 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -80,7 +80,7 @@ section .data ; ;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) (def! *host-language* ",34,"nasm",34,") )" + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (def! *gensym-counter* (atom 0)) (def! gensym (fn* [] (symbol (str ",34,"G__",34," (swap! *gensym-counter* (fn* [x] (+ 1 x))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs))))))))) (def! *host-language* ",34,"nasm",34,") )" ;; Command to run, appending the name of the script to run static run_script_string, db "(load-file ",34 From a22fcc1b0df51046d839deaabd3c0bae7695e514 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 13 Dec 2017 00:06:17 +0000 Subject: [PATCH 0321/1998] Fix small bug in comparison Comparing maps clobbered the block type, needed when comparing array types --- nasm/types.asm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/nasm/types.asm b/nasm/types.asm index bd6a682766..e86e88a4f1 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -1024,8 +1024,8 @@ compare_objects: ; May be different container (value/list, string/symbol) ; Need to distinguish between map and vector/list - and ch, container_mask - and bh, container_mask + and ch, (block_mask + container_mask) + and bh, (block_mask + container_mask) cmp ch, bh je .same_container ; if either is a map, then different types @@ -1098,8 +1098,8 @@ compare_objects_rec: mov ah, al mov bh, bl - and ah, container_mask - and bh, container_mask + and ah, (block_mask + container_mask) + and bh, (block_mask + container_mask) cmp ah, bh je .same_container ; if either is a map, then different types @@ -1131,7 +1131,7 @@ compare_objects_rec: .array: ; Comparing arrays - + ; Container type (symbol/string) does matter cmp al, bl jne .false From 6b47dc878fbcbedd858bb6b4aec43c7f0449c1b3 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 13 Dec 2017 23:45:50 +0000 Subject: [PATCH 0322/1998] Fix bug in concat. MAL step 2 now passes Wasn't incrementing reference count when copying content of a vector single argument. --- nasm/core.asm | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index 1132b775ff..f01bd89c8b 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1648,6 +1648,16 @@ core_concat: mov rbx, [rsi + Cons.car] mov [rax + Cons.car], rbx ; Set content + ; Check if CAR is a pointer + cmp cl, (container_list + content_pointer) + jne .single_done_car + + ; a pointer, so increment reference count + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.single_done_car: mov dl, BYTE [rsi + Cons.typecdr] mov [rax + Cons.typecdr], BYTE dl ; CDR type From 524c684990e4d6c14c087e99d697c4fed47dfe53 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 14 Dec 2017 23:06:19 +0000 Subject: [PATCH 0323/1998] Fix bug in rest and println * rest wasn't incrementing reference count of CAR pointer since cl was overwritten by a write to RCX * println wasn't putting a space separator between items MAL self-hosting now runs to step 6. Fails since (time-ms) not defined. --- nasm/core.asm | 38 ++++++++++++++++++++++++-------------- nasm/printer.asm | 6 +++--- 2 files changed, 27 insertions(+), 17 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index f01bd89c8b..279ef95656 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -887,10 +887,14 @@ core_hashmap: ;; Convert arguments to a readable string, separated by a space ;; core_pr_str: - mov rdi, 1 ; print_readably + mov rdi, 3 ; print_readably & separator jmp core_str_functions core_str: xor rdi, rdi + jmp core_str_functions +core_str_sep: + mov rdi, 2 ; separator + core_str_functions: mov al, BYTE [rsi] mov ah, al @@ -972,8 +976,8 @@ core_str_functions: ; More inputs mov rsi, [rsi + Cons.cdr] ; pointer - cmp rdi, 0 ; print_readably - je .end_append_char ; No separator if not printing readably + test rdi, 2 ; print_readably + jz .end_append_char ; No separator ; Add separator push r8 @@ -1005,7 +1009,7 @@ core_prn: call core_pr_str jmp core_prn_functions core_println: - call core_str + call core_str_sep core_prn_functions: mov rsi, rax @@ -1865,7 +1869,7 @@ core_rest: ; Get the list mov rsi, [rsi + Cons.car] - + mov al, BYTE [rsi] ; Check for nil @@ -1880,7 +1884,7 @@ core_rest: jne .not_list ; Not a list or vector .got_list: - ; Check if list is empty + ; Check if list or vector is empty and al, content_mask cmp al, content_empty je .empty_list @@ -1897,9 +1901,11 @@ core_rest: ret .return_rest: - + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a list or a vector mov cl, BYTE [rsi] mov ch, cl @@ -1917,25 +1923,29 @@ core_rest: mov dl, BYTE [rsi + Cons.typecdr] ; CDR type in DL mov [rax + Cons.typecdr], BYTE dl - ; Copy content of CAR and CDR + ; Copy content of CAR mov rbx, [rsi + Cons.car] mov [rax + Cons.car], rbx - - mov rcx, [rsi + Cons.cdr] - mov [rax + Cons.cdr], rcx ; Note: Might be pointer - + ; Check if car contains a pointer cmp ch, content_pointer jne .check_cdr - + ; CAR contains a pointer, so increment reference count mov r8, rax ; Save return Cons + mov r9, rsi ; Save input list mov rsi, rbx ; Content of CAR call incref_object mov rax, r8 ; Restore return Cons + mov rsi, r9 ; Restore input list + +.check_cdr: + ; Copy content of CDR + + mov rcx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rcx ; Note: Might be pointer -.check_cdr: ; Check if cdr contains a pointer cmp dl, content_pointer jne .return ; Not a pointer, so just return diff --git a/nasm/printer.asm b/nasm/printer.asm index 21e72ee7a8..8973f908b3 100644 --- a/nasm/printer.asm +++ b/nasm/printer.asm @@ -18,7 +18,7 @@ section .data section .text ;; Input: Address of object in RSI -;; print_readably in RDI. Set to zero for false +;; print_readably in RDI. First bit set to zero for false ;; ;; Output: Address of string in RAX ;; @@ -44,8 +44,8 @@ pr_str: ; --------------------------- ; Handle string - cmp rdi, 0 - je .string_not_readable + test rdi, 1 + jz .string_not_readable ; printing readably, so escape characters From dfefe35bd9b6bc6ff1acd17abaa3cd524acdd0ad Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 15 Dec 2017 23:11:20 +0000 Subject: [PATCH 0324/1998] Add time-ms function Uses clock_gettime (syscall 228) to get time in seconds and nanoseconds, then converts to ms. --- nasm/core.asm | 16 ++++++++++++++++ nasm/system.asm | 27 +++++++++++++++++++++++++++ 2 files changed, 43 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index 279ef95656..2a3401829a 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -83,6 +83,8 @@ section .data static core_meta_symbol, db "meta" static core_with_meta_symbol, db "with-meta" + + static core_time_ms_symbol, db "time-ms" ;; Strings @@ -260,6 +262,8 @@ core_environment: core_env_native core_meta_symbol, core_meta core_env_native core_with_meta_symbol, core_with_meta + + core_env_native core_time_ms_symbol, core_time_ms ; ----------------- ; Put the environment in RAX @@ -3073,3 +3077,15 @@ core_with_meta: .no_value: load_static core_with_meta_no_value jmp core_throw_str + + +;; Returns the current time in ms +core_time_ms: + call clock_time_ms + mov rsi, rax + + call alloc_cons + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rsi + ret + diff --git a/nasm/system.asm b/nasm/system.asm index de4d793bef..e22ae13750 100644 --- a/nasm/system.asm +++ b/nasm/system.asm @@ -6,6 +6,10 @@ section .data static error_open_file_string, db "Error opening file " static error_read_file_string, db "Error reading file " + +section .bss + +timespec: RESQ 2 section .text @@ -204,3 +208,26 @@ read_file: call raw_to_string mov rsi, rax jmp error_throw + + + +;; Returns the time in ms in RAX +clock_time_ms: + mov rax, 228 ; clock_gettime + mov rdi, 0 ; CLOCK_REALTIME + mov rsi, timespec + syscall + + mov rax, [timespec + 8] ; nanoseconds + cqo ; Sign extend RAX into RDX + mov rcx, 1000000 + idiv rcx ; Divide RAX by 1e6 -> ms + mov rbx, rax + ; -> ms in RBX + + mov rax, [timespec] ; Seconds + mov rcx, 1000 + imul rcx ; Convert to ms + add rax, rbx ; Add RBX + + ret From ccd081039ea19d4745868aed265bcc6b42c4e636 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 15 Dec 2017 23:56:49 +0000 Subject: [PATCH 0325/1998] Fix list and repl output * (list) wasn't always incrementing reference counts when needed * The value from eval of a file shouldn't be printed, so defined a small routine read_eval which doesn't print the final value. Self-hosting now runs to step8, where two tests of the -> macro fail. --- nasm/core.asm | 12 +++++++----- nasm/stepA_mal.asm | 28 ++++++++++++++++++++++++---- 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 2a3401829a..66b3cb1934 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -797,10 +797,6 @@ core_list: call incref_object mov rax, rsi ret - -.not_seq: - load_static core_list_not_seq - jmp core_throw_str ;; Convert arguments into a vector core_vector: @@ -2432,8 +2428,14 @@ core_apply: mov cl, al and al, container_mask cmp al, container_list - je .run + jne .last_convert_to_list + + ; Already a list, just increment reference count + mov rsi, r9 + call incref_object + jmp .run +.last_convert_to_list: ; Convert vector to list by copying first element call alloc_cons diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index 39ca481fc3..b742f96134 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -80,7 +80,7 @@ section .data ; ;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (def! *gensym-counter* (atom 0)) (def! gensym (fn* [] (symbol (str ",34,"G__",34," (swap! *gensym-counter* (fn* [x] (+ 1 x))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs))))))))) (def! *host-language* ",34,"nasm",34,") )" + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (def! *gensym-counter* (atom 0)) (def! gensym (fn* [] (symbol (str ",34,"G__",34," (swap! *gensym-counter* (fn* [x] (+ 1 x))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs))))))))) (def! *host-language* ",34,"nasm",34,") (def! conj nil) (def! seq nil) )" ;; Command to run, appending the name of the script to run static run_script_string, db "(load-file ",34 @@ -2471,6 +2471,24 @@ macroexpand: .done: pop r15 ret + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + ;; Read-Eval-Print in sequence ;; @@ -2577,7 +2595,9 @@ _start: push rax mov rsi, rax - call rep_seq + call read_eval ; no print ('nil') + mov rsi, rax + call release_object ; Release result of eval ; Release the input string pop rsi @@ -2697,7 +2717,7 @@ run_script: mov cl, ')' call string_append_char ; closing brace - ; Read-Eval-Print "(load-file )" - call rep_seq + ; Read-Eval "(load-file )" + call read_eval jmp quit From ef2d054491729b5f8546d00d05bee426a0761e10 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 16 Dec 2017 23:52:59 +0000 Subject: [PATCH 0326/1998] Fix bug in concat, add test to step 7 Concatenating multiple empty lists resulted in a return which should be empty but was not checked. (concat (list) (list)) -> () Test added to step 7 to catch, since this appeared in self-hosting step 8 in the -> macro expansion. --- nasm/core.asm | 9 +++++++++ tests/step7_quote.mal | 2 ++ 2 files changed, 11 insertions(+) diff --git a/nasm/core.asm b/nasm/core.asm index 66b3cb1934..92e3aa0670 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1754,6 +1754,10 @@ core_concat: mov [r11 + Cons.cdr], rsi mov [r11 + Cons.typecdr], BYTE content_pointer .done: + ; Check there is anything to return + test r11, r11 + jz .empty_list + ; Make sure that return is a list mov bl, BYTE [r12] and bl, content_mask @@ -1762,6 +1766,11 @@ core_concat: mov rax, r12 ; output list ret + +.empty_list: + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret .missing_args: ; Return empty list diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index 973acbc743..4f3e3569ba 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -25,6 +25,8 @@ a ;=>(1 2 3 4 5 6) (concat (concat)) ;=>() +(concat (list) (list)) +;=>() (def! a (list 1 2)) (def! b (list 3 4)) From 7eb930db461bb3382361350471feccf94e669485 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 18 Dec 2017 23:25:59 +0000 Subject: [PATCH 0327/1998] Fix bugs in try*/catch* Wasn't pushing Env, so wasn't releasing correctly. Resulted in errors when in nested expressions. Catch was also not popping the exception handler, so repeated exceptions would not be handled correctly. --- nasm/stepA_mal.asm | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index b742f96134..41fdcdc44b 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -1732,7 +1732,8 @@ eval: push R9 push R10 - + push r15 ; Env + ; Set the error handler mov rsi, rsp ; Stack pointer mov rdi, .catch ; Address to jump to @@ -1747,12 +1748,14 @@ eval: mov rsi, r8 ; The form to evaluate (A) call incref_object ; AST released by eval - + call eval + mov r8, rax ; Result in R8 + pop r15 ; Environment ; Discard B and C - ;add rsi, 8 ; pop R10 and R9 + ;add rsi, 8 ; pop R10 and R9 pop r10 pop r9 @@ -1765,7 +1768,12 @@ eval: ; Jumps here on error ; Value thrown in RSI ; - + + push rsi + call error_handler_pop + pop rsi + + pop r15 ; Env pop r12 ; B (symbol to bind) pop r13 ; C (form to evaluate) @@ -1799,9 +1807,11 @@ eval: mov rdi, rsi ; Env in RDI (will be released) mov rsi, [r13 + Cons.car] ; Form to evaluate call incref_object ; will be released - - call eval + push r15 + call eval + pop r15 + jmp .return .try_missing_catch: From 7f5572b0a60d4c3a81ee57be57d46f86d52ac27b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 20 Dec 2017 23:02:02 +0000 Subject: [PATCH 0328/1998] Fix bug in apply, tests for double-free errors * Apply didn't increment reference count when appending a list to the end of the arguments list * Added checks in release_cons and release_array, to ensure that objects are not released more than once. --- nasm/core.asm | 5 ++++- nasm/types.asm | 33 +++++++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 92e3aa0670..d7c80428f4 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1802,7 +1802,7 @@ core_first: cmp al, content_pointer jne .not_list - + ; Get the list mov rsi, [rsi + Cons.car] @@ -2272,7 +2272,9 @@ core_map: push r8 push r9 push r10 + push r15 call apply_fn ; Result in RAX + pop r15 pop r10 pop r9 pop r8 @@ -2486,6 +2488,7 @@ core_apply: ; Append RSI to the end of the list [R9]...[R10] mov [r10 + Cons.typecdr], BYTE content_pointer mov [r10 + Cons.cdr], rsi + call incref_object .run: ; Have arguments list in R9 diff --git a/nasm/types.asm b/nasm/types.asm index e86e88a4f1..1bd6bda624 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -144,6 +144,9 @@ section .data static error_msg_print_string, db "Error in print string",10 static error_array_memory_limit, db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 static error_cons_memory_limit, db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 + + static error_cons_double_free, db "Error: double free error releasing Cons" + static error_array_double_free, db "Error: double free error releasing Array" ;; ------------------------------------------ ;; Memory management @@ -155,12 +158,12 @@ section .data ;; is free'd it is pushed onto the heap_x_free list. -%define heap_cons_limit 2000 ; Number of cons objects which can be created +%define heap_cons_limit 5000 ; Number of cons objects which can be created heap_cons_next: dd heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list -%define heap_array_limit 1000 ; Number of array objects which can be created +%define heap_array_limit 2000 ; Number of array objects which can be created heap_array_next: dd heap_array_store heap_array_free: dq 0 @@ -229,6 +232,10 @@ alloc_array: ;; onto the free list release_array: mov ax, WORD [rsi + Array.refcount] + + ; Check if reference count is already zero + test ax,ax + jz .double_free dec ax mov WORD [rsi + Array.refcount], ax @@ -254,6 +261,11 @@ release_array: call release_array ret +.double_free: + load_static error_cons_double_free + call print_rawstring + jmp error_throw + ;; ------------------------------------------ ;; Cons alloc_cons() ;; @@ -314,6 +326,11 @@ alloc_cons: ;; release_cons: mov ax, WORD [rsi + Cons.refcount] + + ; Check if already released + test ax,ax + jz .double_free + dec ax mov WORD [rsi + Cons.refcount], ax jz .free ; If the count reaches zero then put on free list @@ -354,6 +371,10 @@ release_cons: .done: ret +.double_free: ; Already released + load_static error_cons_double_free + call print_rawstring + jmp error_throw ;; Releases either a Cons or Array ;; Address of object in RSI @@ -367,12 +388,8 @@ release_object: mov al, BYTE [rsi] ; Get first byte and al, block_mask ; Test block type cmp al, block_array ; Test if it's an array - je .array - call release_cons - ret -.array: - call release_array - ret + je release_array + jmp release_cons ;; Increment reference count of Cons or Array ;; Address of object in RSI From e2ada64e741d640df9034633de1bca59a4e1c658 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 21 Dec 2017 10:56:14 +0000 Subject: [PATCH 0329/1998] Fix bug in map: should pass args as list This appeared only for variadic function which is used in EVAL. Added a test to step 9 to catch this earlier. --- nasm/core.asm | 6 ++++-- tests/step9_try.mal | 3 +++ 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index d7c80428f4..541fa5377a 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -2211,14 +2211,16 @@ core_map: mov cl, BYTE [r9] and cl, content_mask - + mov ch, cl + or cl, container_list + call alloc_cons mov [rax], BYTE cl ; set content type mov rbx, [r9 + Cons.car] mov [rax + Cons.car], rbx ; Copy content mov rsi, rax - cmp cl, content_pointer + cmp ch, content_pointer jne .run ; A pointer, so increment ref count diff --git a/tests/step9_try.mal b/tests/step9_try.mal index 17cfae240e..d50250ecca 100644 --- a/tests/step9_try.mal +++ b/tests/step9_try.mal @@ -139,6 +139,9 @@ (map (fn* (a) (* 2 a)) [1 2 3]) ;=>(2 4 6) +(map (fn* [& args] (list? args)) [1 2]) +;=>(true true) + ;; Testing vector functions (vector? [10 11]) From 0b92f020345aaf91894bdfe6d9bf1bf50bc4a214 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 21 Dec 2017 11:53:03 +0000 Subject: [PATCH 0330/1998] Add seq core function. Self-hosting tests pass (!) Only soft failures, mainly from: * conj function not yet defined * map comparison depends on the order in which keys appear (since it's treated like a list) * meta data only for functions Some odd/concerning soft fails: Expected : '(= (gensym) (gensym))\r\nfalse' Got : '(= (gensym) (gensym))\r\nUncaught exception: non-integer argument to integer arithmetic' Expected : '(let* [or_FIXME 23] (or false (+ or_FIXME 100)))\r\n123' Got : '(let* [or_FIXME 23] (or false (+ or_FIXME 100)))\r\nUncaught exception: non-integer argument to integer arithmetic' Expected : '(dissoc {:cde 345 :fgh 456} :cde)\r\n{:fgh 456}' Got : '(dissoc {:cde 345 :fgh 456} :cde)\r\n[:fgh 456]' --- nasm/core.asm | 163 +++++++++++++++++++++++++++++++++++++++++++++ nasm/stepA_mal.asm | 2 +- 2 files changed, 164 insertions(+), 1 deletion(-) diff --git a/nasm/core.asm b/nasm/core.asm index 541fa5377a..0cebe05fb8 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -85,6 +85,8 @@ section .data static core_with_meta_symbol, db "with-meta" static core_time_ms_symbol, db "time-ms" + + static core_seq_symbol, db "seq" ;; Strings @@ -152,6 +154,9 @@ section .data static core_with_meta_no_function, db "with-meta expects a function as first argument" static core_with_meta_no_value, db "with-meta expects a value as second argument" + + static core_seq_missing_arg, db "seq missing argument" + static core_seq_wrong_type, db "seq expects a list, vector, string or nil" section .text @@ -264,6 +269,8 @@ core_environment: core_env_native core_with_meta_symbol, core_with_meta core_env_native core_time_ms_symbol, core_time_ms + + core_env_native core_seq_symbol, core_seq ; ----------------- ; Put the environment in RAX @@ -3104,4 +3111,160 @@ core_time_ms: mov [rax], BYTE maltype_integer mov [rax + Cons.car], rsi ret + +;; Convert sequences, including strings, into lists +core_seq: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + je .pointer + + cmp al, content_empty + je .missing_arg + + cmp al, content_nil + jne .wrong_type + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.pointer: + mov r8, [rsi + Cons.car] + mov al, BYTE [r8] + + cmp al, maltype_string + je .string + + mov ah, al + and ah, (block_mask + content_mask) + cmp ah, (block_cons + content_empty) + je .return_nil + + and al, (block_mask + container_mask) + + cmp al, (block_cons + container_list) + je .list + + cmp al, (block_cons + container_vector) + jne .wrong_type + + ; Convert vector to list by replacing the first Cons + call alloc_cons + mov bl, BYTE [r8] + and bl, content_mask + or bl, container_list + mov [rax], BYTE bl ; Set type + + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx + + ; Check if it's a pointer + cmp bl, (container_list + content_pointer) + jne .copy_cdr + + ; Increment reference count + mov bx, WORD [rcx + Cons.refcount] ; Same for Array + inc bx + mov [rcx + Cons.refcount], WORD bx + +.copy_cdr: + mov rcx, [r8 + Cons.cdr] + mov [rax + Cons.cdr], rcx + + mov bl, [r8 + Cons.typecdr] + mov [rax + Cons.typecdr], bl + + cmp bl, content_pointer + jne .return + + ; Increment reference count + mov bx, WORD [rcx + Cons.refcount] ; Same for Array + inc bx + mov [rcx + Cons.refcount], WORD bx + +.return: + ret + +.list: + ; Return list unchanged + mov rsi, r8 + call incref_object + mov rax, r8 + ret + +.string: + ; Split a string into characters + ; Input string in R8 + + mov ebx, DWORD [r8 + Array.length] + test ebx,ebx + jz .return_nil ; empty string + + ; Not empty, so allocate first Cons + call alloc_cons + mov r9, rax ; Return Cons in R9 + mov r10, rax ; End of list in R10 + +.loop: + mov ebx, DWORD [r8 + Array.length] + mov r11, r8 + add r11, Array.data ; Start of string data in R11 + mov r12, r11 + add r12, rbx ; End of string data in R12 + +.inner_loop: + ; Get a new string + call string_new ; in RAX + mov bl, BYTE [r11] ; Get the next character + mov [rax + Array.data], BYTE bl + mov [rax + Array.length], DWORD 1 + + ; Put string into Cons at end of list + mov [r10 + Cons.car], rax + + ; Set type + mov [r10], BYTE (container_list + content_pointer) + + inc r11 + cmp r11, r12 + je .inner_done + + ; more characters, so allocate another Cons + call alloc_cons + + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r10, rax + jmp .inner_loop + +.inner_done: + ; No more characters in this Array + ; check if there are more + mov r8, QWORD [r8 + Array.next] ; Get the next Array address + test r8, r8 ; Test if it's null + jz .string_finished + + ; Another chunk in the string + + call alloc_cons + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r10, rax + jmp .loop + +.string_finished: + mov rax, r9 + ret + +.missing_arg: + ; No arguments + load_static core_seq_missing_arg + jmp core_throw_str + +.wrong_type: + ; Not a list, vector, string or nil + load_static core_seq_wrong_type + jmp core_throw_str diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index 41fdcdc44b..fe244353ce 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -80,7 +80,7 @@ section .data ; ;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (def! *gensym-counter* (atom 0)) (def! gensym (fn* [] (symbol (str ",34,"G__",34," (swap! *gensym-counter* (fn* [x] (+ 1 x))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs))))))))) (def! *host-language* ",34,"nasm",34,") (def! conj nil) (def! seq nil) )" + static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (def! *gensym-counter* (atom 0)) (def! gensym (fn* [] (symbol (str ",34,"G__",34," (swap! *gensym-counter* (fn* [x] (+ 1 x))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs))))))))) (def! *host-language* ",34,"nasm",34,") (def! conj nil) )" ;; Command to run, appending the name of the script to run static run_script_string, db "(load-file ",34 From fb52de99c37597604175614d0ade773218bfafb4 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 22 Dec 2017 22:58:06 +0000 Subject: [PATCH 0331/1998] Fix bug in map, modifying function return values map was modifying the container type to list, to avoid having to copy values. Now checks if there are multiple references, and if so makes a copy. Fixes (= (gensym) (gensym)) error self-host test. --- nasm/core.asm | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index 0cebe05fb8..c4c8eb6ca7 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -1428,7 +1428,7 @@ core_swap: ; Now get the value in the atom mov rdx, [r9 + Cons.car] ; The object pointed to - + ; Check what it is mov bl, BYTE [rdx] mov bh, bl @@ -1506,7 +1506,7 @@ core_swap: mov rsi, [r9 + Cons.car] call release_object pop rax - + ; Put into atom mov [r9 + Cons.car], rax @@ -2290,6 +2290,7 @@ core_map: .got_return: ; Have a return result in RAX + ; Check if it's a value type mov bl, BYTE [rax] mov bh, bl @@ -2304,10 +2305,40 @@ core_map: jmp .update_return .return_value: + ; Check if this value is shared (e.g. in an atom) + mov cx, WORD [rax + Cons.refcount] + dec cx + jz .return_value_modify ; If reference count is 1 + + ; Need to copy to avoid modifying + push rsi + mov rsi, rax ; Original in RSI + + mov cl, bh ; Type + call alloc_cons + and cl, content_mask + or cl, container_list + mov [rax], BYTE cl ; mark as a list + + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy content + + ; Release original + push rax + call release_object + pop rax + pop rsi + + jmp .update_return + +.return_value_modify: + ; Only one reference, + ; so can change the container type to list. + ; Original type in bh mov bl, bh and bl, content_mask or bl, container_list - mov [rax], BYTE bl ; mark as a list + mov [rax], BYTE bl .update_return: ; Now append to result list From e8915efe8eb6c026d21713e309cd994bec17618b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 26 Dec 2017 23:31:16 +0000 Subject: [PATCH 0332/1998] Fix bugs, performance test now runs * Functions with an empty argument list resulted in a leak of a single Cons object. This caused the performance test to fail. * The heap 'next' pointers were dwords, rather than qwords. This doesn't seem to have made a difference, but could if the heap was made very large * Double free errors now throw a string rather than printing --- nasm/stepA_mal.asm | 9 ++++++++- nasm/types.asm | 10 ++++++---- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index fe244353ce..bf76e7f81e 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -1866,9 +1866,16 @@ eval: je .list_got_args ; No arguments - push rbx + + push rbx ; Function object + + mov rsi, rax ; List with function first + call release_object ; Can be freed now + + ; Create an empty list for the arguments call alloc_cons mov [rax], BYTE maltype_empty_list + pop rbx mov rsi, rax jmp .list_function_call diff --git a/nasm/types.asm b/nasm/types.asm index 1bd6bda624..97b9634c0d 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -160,12 +160,12 @@ section .data %define heap_cons_limit 5000 ; Number of cons objects which can be created -heap_cons_next: dd heap_cons_store ; Address of next cons in memory +heap_cons_next: dq heap_cons_store ; Address of next cons in memory heap_cons_free: dq 0 ; Address of start of free list %define heap_array_limit 2000 ; Number of array objects which can be created -heap_array_next: dd heap_array_store +heap_array_next: dq heap_array_store heap_array_free: dq 0 section .bss @@ -263,7 +263,8 @@ release_array: .double_free: load_static error_cons_double_free - call print_rawstring + call raw_to_string + mov rsi, rax jmp error_throw ;; ------------------------------------------ @@ -373,7 +374,8 @@ release_cons: .double_free: ; Already released load_static error_cons_double_free - call print_rawstring + call raw_to_string + mov rsi, rax jmp error_throw ;; Releases either a Cons or Array From e64592a1da0a281659e640f5097dc715363cd6e9 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 26 Dec 2017 23:41:15 +0000 Subject: [PATCH 0333/1998] Moving error handler into exceptions.asm Needed by core routines, so will need to add to earlier steps. --- nasm/exceptions.asm | 138 ++++++++++++++++++++++++++++++++++++++ nasm/stepA_mal.asm | 160 +++++++------------------------------------- 2 files changed, 163 insertions(+), 135 deletions(-) create mode 100644 nasm/exceptions.asm diff --git a/nasm/exceptions.asm b/nasm/exceptions.asm new file mode 100644 index 0000000000..8630761c11 --- /dev/null +++ b/nasm/exceptions.asm @@ -0,0 +1,138 @@ + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + +section .bss + +;; Error handler list +error_handler: resq 1 + +section .text + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + ; Note: This can't use content_pointer or release + ; will try to release this memory address + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + ;call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + mov [rsi + Cons.typecdr], BYTE 0 + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index bf76e7f81e..3aace8bc04 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -13,15 +13,13 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 -;; Error handler list -error_handler: resq 1 - section .data ;; ------------------------------------------ @@ -87,139 +85,9 @@ section .data ;; Command to run at start of REPL static mal_startup_header, db "(println (str ",34,"Mal [",34," *host-language* ",34,"]",34,"))" -section .text - -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - ; Note: This can't use content_pointer or release - ; will try to release this memory address - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - ;call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - mov [rsi + Cons.typecdr], BYTE 0 - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error +section .text + ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -1946,6 +1814,28 @@ apply_fn: mov rax, [rax + Cons.cdr] mov rax, [rax + Cons.car] ; Body pop rcx ; Exprs + +;;; + ; push rax + ; push rcx + ; push rsi + ; push rdi + ; push rdx + ; push r15 + ; push r13 + + ; mov rsi, rcx + ; call core_println + + ; pop r13 + ; pop r15 + ; pop rdx + ; pop rdi + ; pop rsi + ; pop rcx + ; pop rax + +;;; ; Check the type of the body mov bl, BYTE [rax] From 90fb8655146cea0d5a22b04cdf6905f8e9e53cd7 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 26 Dec 2017 23:51:58 +0000 Subject: [PATCH 0334/1998] Step 9 passes again 3 soft failures, due to hash-map comparisons --- nasm/step9_try.asm | 157 ++++++--------------------------------------- nasm/stepA_mal.asm | 21 ------ 2 files changed, 18 insertions(+), 160 deletions(-) diff --git a/nasm/step9_try.asm b/nasm/step9_try.asm index d251a81c87..4faeecf9e6 100644 --- a/nasm/step9_try.asm +++ b/nasm/step9_try.asm @@ -13,14 +13,12 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 - -;; Error handler list -error_handler: resq 1 section .data @@ -86,137 +84,6 @@ section .data static run_script_string, db "(load-file ",34 section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - ; Note: This can't use content_pointer or release - ; will try to release this memory address - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - ;call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - mov [rsi + Cons.typecdr], BYTE 0 - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -1481,6 +1348,8 @@ eval: mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) @@ -1716,7 +1585,8 @@ eval: push R9 push R10 - + push r15 ; Env + ; Set the error handler mov rsi, rsp ; Stack pointer mov rdi, .catch ; Address to jump to @@ -1731,10 +1601,12 @@ eval: mov rsi, r8 ; The form to evaluate (A) call incref_object ; AST released by eval - + call eval + mov r8, rax ; Result in R8 + pop r15 ; Environment ; Discard B and C ;add rsi, 8 ; pop R10 and R9 pop r10 @@ -1749,7 +1621,12 @@ eval: ; Jumps here on error ; Value thrown in RSI ; - + + push rsi + call error_handler_pop + pop rsi + + pop r15 ; Env pop r12 ; B (symbol to bind) pop r13 ; C (form to evaluate) @@ -1783,9 +1660,11 @@ eval: mov rdi, rsi ; Env in RDI (will be released) mov rsi, [r13 + Cons.car] ; Form to evaluate call incref_object ; will be released - - call eval + push r15 + call eval + pop r15 + jmp .return .try_missing_catch: diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index 3aace8bc04..c1e3d7a233 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -1815,27 +1815,6 @@ apply_fn: mov rax, [rax + Cons.car] ; Body pop rcx ; Exprs -;;; - ; push rax - ; push rcx - ; push rsi - ; push rdi - ; push rdx - ; push r15 - ; push r13 - - ; mov rsi, rcx - ; call core_println - - ; pop r13 - ; pop r15 - ; pop rdx - ; pop rdi - ; pop rsi - ; pop rcx - ; pop rax - -;;; ; Check the type of the body mov bl, BYTE [rax] From 7f8ae811e1070ea21eb61a787422131bc8fbf24c Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 26 Dec 2017 23:55:18 +0000 Subject: [PATCH 0335/1998] Step 8 passes --- nasm/step8_macros.asm | 134 +----------------------------------------- 1 file changed, 3 insertions(+), 131 deletions(-) diff --git a/nasm/step8_macros.asm b/nasm/step8_macros.asm index 60973781f6..3b6d7d5f14 100644 --- a/nasm/step8_macros.asm +++ b/nasm/step8_macros.asm @@ -13,14 +13,12 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 - -;; Error handler list -error_handler: resq 1 section .data @@ -80,134 +78,6 @@ section .data static run_script_string, db "(load-file ",34 section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -1450,6 +1320,8 @@ eval: mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) From 0a96ee8abe5fd21081980771e6b1874614e6e702 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 27 Dec 2017 17:32:01 +0000 Subject: [PATCH 0336/1998] All tests pass Some modifications needed to earlier steps so they compile with the new core functions. Need to disable double free error checks in types, because step2 fails otherwise. --- nasm/step1_read_print.asm | 4 +- nasm/step2_eval.asm | 14 +- nasm/step3_env.asm | 132 +------------- nasm/step4_if_fn_do.asm | 131 +------------- nasm/step5_tco.asm | 372 +++++++++++++++++--------------------- nasm/step6_file.asm | 323 +++++++++++++++------------------ nasm/types.asm | 2 + 7 files changed, 337 insertions(+), 641 deletions(-) diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index a651e86b2d..5aa2fe5504 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -11,7 +11,8 @@ global _start %include "system.asm" ; System calls %include "reader.asm" ; String -> Data structures %include "printer.asm" ; Data structures -> String - +%include "exceptions.asm" ; Error handling + section .data test_string1: db 10, "test1", 10 @@ -94,6 +95,7 @@ _start: ; Put into pr_str mov rsi, rax + mov rdi, 1 ; print readably call pr_str push rax diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 98025a0208..2a495c62be 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -1,5 +1,5 @@ ;; -;; nasm -felf64 step1_read_print.asm && ld step1_read_print.o && ./a.out +;; nasm -felf64 step2_eval.asm && ld step2_eval.o && ./a.out ;; Calling convention: Address of input is in RSI ;; Address of return value is in RAX @@ -13,6 +13,7 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss @@ -27,6 +28,8 @@ section .data prompt_string: db 10,"user> " ; The string to print at the prompt .len: equ $ - prompt_string +error_string: db 27,'[31m',"Error",27,'[0m',": " +.len: equ $ - error_string def_symbol: ISTRUC Array AT Array.type, db maltype_symbol @@ -40,8 +43,12 @@ AT Array.length, dd 4 AT Array.data, db 'let*' IEND -section .text - +section .text + +;; This is a dummy function so that core routines compile +apply_fn: + jmp quit + ;; Evaluates a form in RSI eval_ast: ; Check the type @@ -537,6 +544,7 @@ _start: ; Put into pr_str mov rsi, rax + mov rdi, 1 ; print readably call pr_str push rax ; Save output string diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index bdc9e017b4..132f72529e 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -13,14 +13,12 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 - -;; Error handler list -error_handler: resq 1 section .data @@ -55,133 +53,11 @@ section .data section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure +;; This is a dummy function so that core routines compile +apply_fn: + jmp quit - ; Reset stack - mov rsp, rbx - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index 852192c403..110cc2d66c 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -13,14 +13,12 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 - -;; Error handler list -error_handler: resq 1 section .data @@ -63,134 +61,7 @@ section .data section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; diff --git a/nasm/step5_tco.asm b/nasm/step5_tco.asm index d861773f62..af5525f425 100644 --- a/nasm/step5_tco.asm +++ b/nasm/step5_tco.asm @@ -13,14 +13,12 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 - -;; Error handler list -error_handler: resq 1 section .data @@ -64,134 +62,7 @@ section .data section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -297,12 +168,13 @@ eval_ast: push r8 push r9 push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 - xchg rsi, rdi call incref_object ; Environment increment refs - xchg rsi, rdi + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs call eval ; Evaluate it, result in rax pop r15 @@ -466,6 +338,8 @@ eval_ast: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi + + call incref_object call eval ; Evaluate it, result in rax pop r15 @@ -554,6 +428,8 @@ eval_ast: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi + + call incref_object call eval ; Evaluate it, result in rax pop r15 @@ -643,22 +519,25 @@ eval_ast: call compare_char_array pop rbx pop rsi - cmp rax, 0 + test rax, rax ; ZF set if rax = 0 (equal) %endmacro ;; ---------------------------------------------------- ;; Evaluates a form ;; -;; Input: RSI Form to evaluate -;; RDI Environment +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] ;; ;; Returns: Result in RAX ;; -;; Note: The environment in RDI will have its reference count -;; reduced by one (released). This is to make tail call optimisation easier +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) ;; eval: mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return ; Check type mov al, BYTE [rsi] @@ -774,9 +653,12 @@ eval: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs call eval mov rsi, rax + pop r15 pop r8 @@ -899,8 +781,15 @@ eval: push r12 ; Position in bindings list push r13 ; symbol to bind push r14 ; new environment - mov rsi, [r12 + Cons.car] ; Get the address + + mov rsi, r14 + call incref_object mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + call eval ; Evaluate it, result in rax pop r14 pop r13 @@ -952,6 +841,13 @@ eval: ; Evaluate using new environment mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + mov rdi, r14 ; New environment jmp eval ; Tail call @@ -963,6 +859,12 @@ eval: mov rsi, r14 call release_object pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax ret ; already released env .let_error_missing_bindings: @@ -1045,6 +947,8 @@ eval: ; since eval will release Env mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + mov rdi, r15 ; Env call eval ; Result in RAX @@ -1087,6 +991,13 @@ eval: mov [rax], BYTE bl mov rbx, [r11 + Cons.car] mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + ret .do_body_expr_return: @@ -1094,7 +1005,14 @@ eval: ; Tail call optimise, jumping to eval ; Don't increment Env reference count - mov rsi, [r11 + Cons.car] ; Form + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + mov rdi, r15 ; Env jmp eval ; Tail call @@ -1103,6 +1021,10 @@ eval: mov rsi, r15 call release_object ; Release Env + + ; release the AST + pop rsi + call release_object call alloc_cons mov [rax], BYTE maltype_nil @@ -1136,6 +1058,8 @@ eval: call incref_object ; Increase Env reference mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + mov rdi, r15 ; Env call eval ; Result in RAX pop r11 @@ -1203,6 +1127,13 @@ eval: .if_got_pointer: mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + mov rdi, r15 ; Env jmp eval ; Tail call @@ -1223,12 +1154,16 @@ eval: mov [rax + Cons.typecdr], BYTE content_nil .return: - push rax ; Release environment mov rsi, r15 + mov r15, rax ; Save RAX (return value) call release_object - pop rax - + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value ret ; ----------------------------- @@ -1305,6 +1240,8 @@ eval: mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) @@ -1351,6 +1288,13 @@ eval: pop r15 pop rsi +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; ; Check that the first element of the return is a function mov bl, BYTE [rax] and bl, content_mask @@ -1384,7 +1328,7 @@ eval: mov rbx, [rbx + Cons.car] ; Call function cmp rbx, apply_fn - je apply_fn ; Jump to user function apply + je apply_fn_jmp ; Jump to user function apply ; A built-in function, so call (no recursion) push rax @@ -1395,11 +1339,10 @@ eval: ; Result in rax pop r15 pop rsi ; eval'ed list - + push rax call release_cons - pop rax - + pop rax jmp .return ; Releases Env .list_not_function: @@ -1421,8 +1364,16 @@ eval: ;; RDI - Function object ;; RDX - list to release after binding ;; R15 - Env (will be released) +;; R13 - AST released before return +;; ;; ;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 apply_fn: push rsi ; Extract values from the list in RDI @@ -1440,7 +1391,8 @@ apply_fn: jnz .bind ; Just a value (in RAX). No eval needed - push rax + mov r14, rax ; Save return value in R14 + mov rsi, rax call incref_object @@ -1451,12 +1403,18 @@ apply_fn: ; Release the environment mov rsi, r15 call release_object + + ; Release the AST + mov rsi, r13 + call release_object - pop rax + mov rax, r14 ret .bind: ; Create a new environment, binding arguments - push rax + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind push rdx call env_new_bind @@ -1464,29 +1422,75 @@ apply_fn: mov rdi, rax ; New environment in RDI + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + ; Release the list passed in RDX -.release: mov rsi, rdx call release_cons ; Release the environment mov rsi, r15 call release_object - - pop rsi ; Body + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body jmp eval ; Tail call ; The new environment (in RDI) will be released by eval ;; Read-Eval-Print in sequence +;; +;; Input string in RSI rep_seq: + ; ------------- + ; Read call read_str - mov rsi, rax ; Output of read into input of eval - call eval - mov rsi, rax ; Output of eval into input of print + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + ; Put into pr_str + mov rsi, rax + mov rdi, 1 ; print_readably call pr_str - mov rsi, rax ; Return value + push rax ; Save output string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from pr_str + pop rsi + call release_array + + ; Release result of eval + pop rsi + call release_object + + ; The AST from read_str is released by eval + ret @@ -1515,21 +1519,16 @@ _start: push rax ; AST call release_array ; string - pop rsi ; AST - - push rsi - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval + xchg rsi, rdi ; Env in RDI, AST in RSI call eval - pop rsi - push rax - call release_object ; AST - pop rsi + mov rsi, rax call release_object ; Return from eval ; ----------------------------- @@ -1549,40 +1548,7 @@ _start: ; Put into read_str mov rsi, rax - call read_str - push rax ; Save AST - - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval - push rax ; Save result - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from pr_str - pop rsi - call release_array - - ; Release result of eval - pop rsi - call release_object - - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array + call rep_seq ; Release the input string pop rsi diff --git a/nasm/step6_file.asm b/nasm/step6_file.asm index c18e58ed6c..0020d559bc 100644 --- a/nasm/step6_file.asm +++ b/nasm/step6_file.asm @@ -13,14 +13,12 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 - -;; Error handler list -error_handler: resq 1 section .data @@ -67,134 +65,6 @@ section .data static run_script_string, db "(load-file ",34 section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -300,12 +170,13 @@ eval_ast: push r8 push r9 push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 - xchg rsi, rdi call incref_object ; Environment increment refs - xchg rsi, rdi + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs call eval ; Evaluate it, result in rax pop r15 @@ -469,6 +340,8 @@ eval_ast: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi + + call incref_object call eval ; Evaluate it, result in rax pop r15 @@ -557,6 +430,8 @@ eval_ast: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi + + call incref_object call eval ; Evaluate it, result in rax pop r15 @@ -646,22 +521,25 @@ eval_ast: call compare_char_array pop rbx pop rsi - cmp rax, 0 + test rax, rax ; ZF set if rax = 0 (equal) %endmacro ;; ---------------------------------------------------- ;; Evaluates a form ;; -;; Input: RSI Form to evaluate -;; RDI Environment +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] ;; ;; Returns: Result in RAX ;; -;; Note: The environment in RDI will have its reference count -;; reduced by one (released). This is to make tail call optimisation easier +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) ;; eval: mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return ; Check type mov al, BYTE [rsi] @@ -777,9 +655,12 @@ eval: xchg rsi, rdi call incref_object ; Environment increment refs xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs call eval mov rsi, rax + pop r15 pop r8 @@ -902,8 +783,15 @@ eval: push r12 ; Position in bindings list push r13 ; symbol to bind push r14 ; new environment - mov rsi, [r12 + Cons.car] ; Get the address + + mov rsi, r14 + call incref_object mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + call eval ; Evaluate it, result in rax pop r14 pop r13 @@ -955,6 +843,13 @@ eval: ; Evaluate using new environment mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + mov rdi, r14 ; New environment jmp eval ; Tail call @@ -966,6 +861,12 @@ eval: mov rsi, r14 call release_object pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax ret ; already released env .let_error_missing_bindings: @@ -1048,6 +949,8 @@ eval: ; since eval will release Env mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + mov rdi, r15 ; Env call eval ; Result in RAX @@ -1090,6 +993,13 @@ eval: mov [rax], BYTE bl mov rbx, [r11 + Cons.car] mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + ret .do_body_expr_return: @@ -1097,7 +1007,14 @@ eval: ; Tail call optimise, jumping to eval ; Don't increment Env reference count - mov rsi, [r11 + Cons.car] ; Form + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + mov rdi, r15 ; Env jmp eval ; Tail call @@ -1106,6 +1023,10 @@ eval: mov rsi, r15 call release_object ; Release Env + + ; release the AST + pop rsi + call release_object call alloc_cons mov [rax], BYTE maltype_nil @@ -1139,6 +1060,8 @@ eval: call incref_object ; Increase Env reference mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + mov rdi, r15 ; Env call eval ; Result in RAX pop r11 @@ -1206,6 +1129,13 @@ eval: .if_got_pointer: mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + mov rdi, r15 ; Env jmp eval ; Tail call @@ -1226,12 +1156,16 @@ eval: mov [rax + Cons.typecdr], BYTE content_nil .return: - push rax ; Release environment mov rsi, r15 + mov r15, rax ; Save RAX (return value) call release_object - pop rax - + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value ret ; ----------------------------- @@ -1308,6 +1242,8 @@ eval: mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) @@ -1353,8 +1289,7 @@ eval: call eval_ast ; List of evaluated forms in RAX pop r15 pop rsi - - + .list_exec: ; This point can be called to run a function ; used by swap! @@ -1395,7 +1330,7 @@ eval: mov rbx, [rbx + Cons.car] ; Call function cmp rbx, apply_fn - je apply_fn ; Jump to user function apply + je apply_fn_jmp ; Jump to user function apply ; A built-in function, so call (no recursion) push rax @@ -1406,11 +1341,10 @@ eval: ; Result in rax pop r15 pop rsi ; eval'ed list - + push rax call release_cons - pop rax - + pop rax jmp .return ; Releases Env .list_not_function: @@ -1432,8 +1366,16 @@ eval: ;; RDI - Function object ;; RDX - list to release after binding ;; R15 - Env (will be released) +;; R13 - AST released before return +;; ;; ;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 apply_fn: push rsi ; Extract values from the list in RDI @@ -1451,7 +1393,8 @@ apply_fn: jnz .bind ; Just a value (in RAX). No eval needed - push rax + mov r14, rax ; Save return value in R14 + mov rsi, rax call incref_object @@ -1462,12 +1405,18 @@ apply_fn: ; Release the environment mov rsi, r15 call release_object + + ; Release the AST + mov rsi, r13 + call release_object - pop rax + mov rax, r14 ret .bind: ; Create a new environment, binding arguments - push rax + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind push rdx call env_new_bind @@ -1475,21 +1424,50 @@ apply_fn: mov rdi, rax ; New environment in RDI + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + ; Release the list passed in RDX -.release: mov rsi, rdx call release_cons ; Release the environment mov rsi, r15 call release_object - - pop rsi ; Body + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body jmp eval ; Tail call ; The new environment (in RDI) will be released by eval +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + + ;; Read-Eval-Print in sequence ;; ;; Input string in RSI @@ -1497,8 +1475,7 @@ rep_seq: ; ------------- ; Read call read_str - push rax ; Save AST - + ; ------------- ; Eval mov rsi, rax ; Form to evaluate @@ -1508,7 +1485,7 @@ rep_seq: call incref_object ; Environment increment refs xchg rsi, rdi ; since it will be decremented by eval - call eval + call eval ; This releases Env and Form/AST push rax ; Save result of eval ; ------------- @@ -1531,9 +1508,8 @@ rep_seq: pop rsi call release_object - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array + ; The AST from read_str is released by eval + ret @@ -1562,21 +1538,16 @@ _start: push rax ; AST call release_array ; string - pop rsi ; AST - - push rsi - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval + xchg rsi, rdi ; Env in RDI, AST in RSI call eval - pop rsi - push rax - call release_object ; AST - pop rsi + mov rsi, rax call release_object ; Return from eval ; ----------------------------- @@ -1708,7 +1679,7 @@ run_script: mov cl, ')' call string_append_char ; closing brace - ; Read-Eval-Print "(load-file )" - call rep_seq + ; Read-Eval "(load-file )" + call read_eval jmp quit diff --git a/nasm/types.asm b/nasm/types.asm index 97b9634c0d..c29d8fa3e0 100644 --- a/nasm/types.asm +++ b/nasm/types.asm @@ -262,6 +262,7 @@ release_array: ret .double_free: + ret load_static error_cons_double_free call raw_to_string mov rsi, rax @@ -373,6 +374,7 @@ release_cons: ret .double_free: ; Already released + ret load_static error_cons_double_free call raw_to_string mov rsi, rax From 331ddfed79851142aea3b6380d9c8540f5183329 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 27 Dec 2017 23:33:03 +0000 Subject: [PATCH 0337/1998] Adding README.md file and Make all target * README.md in nasm/ directory lists some features and limitations * Added NASM entry to root directory README.md * Added an 'all' target to the nasm Makefile --- README.md | 14 ++++++++++++++ nasm/Makefile | 4 ++++ nasm/README.md | 30 ++++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+) create mode 100644 nasm/README.md diff --git a/README.md b/README.md index 8e9c9433da..c423c24607 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,7 @@ Mal is implemented in 71 languages: * mal itself * Matlab (GNU Octave and MATLAB) * [miniMAL](https://github.com/kanaka/miniMAL) +* NASM * Nim * Object Pascal * Objective C @@ -617,6 +618,19 @@ cd make make -f stepX_YYY.mk ``` +### NASM + +*The NASM implementation was created by [Ben Dudson](https://github.com/bendudson)* + +The NASM implementation of mal is written for x86-64 Linux, and has been tested +with Linux 3.16.0-4-amd64 and NASM version 2.11.05. + +``` +cd nasm +make +./stepX_YYY +``` + ### Nim 0.17.0 *The Nim implementation was created by [Dennis Felsing (def-)](https://github.com/def-)* diff --git a/nasm/Makefile b/nasm/Makefile index d220cb58bc..98028e93a2 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -1,6 +1,10 @@ +STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal + COMPONENTS=core.asm reader.asm printer.asm types.asm system.asm +all: $(STEPS) + %.o: %.asm $(COMPONENTS) nasm -felf64 $< diff --git a/nasm/README.md b/nasm/README.md new file mode 100644 index 0000000000..170a7c2c58 --- /dev/null +++ b/nasm/README.md @@ -0,0 +1,30 @@ +# x86_64 NASM implementation + +Notes and known issues: + +* No library dependencies, only Linux system calls + +* Simple readline implemented, just supporting backspace for editing + +* Reference counting used for memory management. No attempt is made + to find circular references, so leaks are possible. In particular + defining a function with def! creates a circular reference loop. + +* The exception/error handling just resets the stack and jumps to a handler, + so does not release memory + +* Memory is allocated by two fixed-size allocators (`Cons` and `Array` objects) + which have limits specified in types.asm. If more memory is needed + then this must currently be done at compile-time, but adding sys_brk + calls could be done. + +* The hash map implementation is just a list of key-value pairs. + Moving symbols around in the core environment makes a significant difference + (20-30%) to the performance test. A simple optimisation could be to + move items when found to the start of the list so that frequently + searched keys are nearer the front. + +* `conj` function not yet implemented + +* `*env*` symbol evaluates to current Environment. + From 860f35aae5a75ab51d508ee21c852c541f72daa0 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 27 Dec 2017 23:34:30 +0000 Subject: [PATCH 0338/1998] Moved macro-related functions to start of core Env Changes the performance test 3 from ~ 3500/s to ~4300/s Probably indicates that Env lookups are a big part of the runtime. --- nasm/core.asm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/nasm/core.asm b/nasm/core.asm index c4c8eb6ca7..8282b1ba9a 100644 --- a/nasm/core.asm +++ b/nasm/core.asm @@ -189,6 +189,13 @@ core_environment: xor rsi, rsi ; Set outer to nil call env_new mov rsi, rax ; Environment in RSI + + core_env_native core_cons_symbol, core_cons + core_env_native core_concat_symbol, core_concat + + core_env_native core_first_symbol, core_first + core_env_native core_rest_symbol, core_rest + core_env_native core_nth_symbol, core_nth core_env_native core_add_symbol, core_add core_env_native core_sub_symbol, core_sub @@ -224,13 +231,6 @@ core_environment: core_env_native core_atomp_symbol, core_atomp core_env_native core_reset_symbol, core_reset core_env_native core_swap_symbol, core_swap - - core_env_native core_cons_symbol, core_cons - core_env_native core_concat_symbol, core_concat - - core_env_native core_first_symbol, core_first - core_env_native core_rest_symbol, core_rest - core_env_native core_nth_symbol, core_nth core_env_native core_nilp_symbol, core_nilp core_env_native core_truep_symbol, core_truep From 990c7b5ee664191e4b419b0246c21f42844d1f46 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 27 Dec 2017 23:57:34 +0000 Subject: [PATCH 0339/1998] Add docker file. Docker tests pass Tested with: ``` docker build -t kanaka/mal-test-nasm" . make DOCKERIZE=1 "test^nasm" make DOCKERIZE=1 MAL_IMPL=nasm "test^mal" ``` Docker image not pushed to server, so Travis script fails. --- nasm/Dockerfile | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 nasm/Dockerfile diff --git a/nasm/Dockerfile b/nasm/Dockerfile new file mode 100644 index 0000000000..53bcd32624 --- /dev/null +++ b/nasm/Dockerfile @@ -0,0 +1,26 @@ +FROM ubuntu +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install nasm +RUN apt-get -y install nasm + From 265041fa76d5847aef87e1d5a749124d367abd57 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Fri, 29 Dec 2017 22:44:22 +0000 Subject: [PATCH 0340/1998] Removing new tests from step7 and step9 These will be separated into another branch. --- tests/step7_quote.mal | 5 +---- tests/step9_try.mal | 3 --- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index 4f3e3569ba..bd5b22fe6f 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -25,8 +25,6 @@ a ;=>(1 2 3 4 5 6) (concat (concat)) ;=>() -(concat (list) (list)) -;=>() (def! a (list 1 2)) (def! b (list 3 4)) @@ -74,8 +72,7 @@ b ;=>(1 b 3) (quasiquote (1 (unquote b) 3)) ;=>(1 (1 "b" "d") 3) -(quasiquote ((unquote 1) (unquote 2))) -;=>(1 2) + ;; Testing splice-unquote (def! c (quote (1 "b" "d"))) diff --git a/tests/step9_try.mal b/tests/step9_try.mal index d50250ecca..17cfae240e 100644 --- a/tests/step9_try.mal +++ b/tests/step9_try.mal @@ -139,9 +139,6 @@ (map (fn* (a) (* 2 a)) [1 2 3]) ;=>(2 4 6) -(map (fn* [& args] (list? args)) [1 2]) -;=>(true true) - ;; Testing vector functions (vector? [10 11]) From 89f7cef6dcc8e85e6db31063bf1d0b10f08c0d18 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Mon, 27 Nov 2017 14:07:00 +0000 Subject: [PATCH 0341/1998] Adding test to step7 for quasiquote Handling of the last element of the AST is tested by having an unquote as the last element. --- tests/step7_quote.mal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index bd5b22fe6f..973acbc743 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -72,7 +72,8 @@ b ;=>(1 b 3) (quasiquote (1 (unquote b) 3)) ;=>(1 (1 "b" "d") 3) - +(quasiquote ((unquote 1) (unquote 2))) +;=>(1 2) ;; Testing splice-unquote (def! c (quote (1 "b" "d"))) From 40eb57d65c5f95890edfd9d149853c7358a3d481 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 16 Dec 2017 23:52:59 +0000 Subject: [PATCH 0342/1998] Fix bug in concat, add test to step 7 Concatenating multiple empty lists resulted in a return which should be empty but was not checked. (concat (list) (list)) -> () Test added to step 7 to catch, since this appeared in self-hosting step 8 in the -> macro expansion. --- tests/step7_quote.mal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index 973acbc743..4f3e3569ba 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -25,6 +25,8 @@ a ;=>(1 2 3 4 5 6) (concat (concat)) ;=>() +(concat (list) (list)) +;=>() (def! a (list 1 2)) (def! b (list 3 4)) From f86d275f081f65e1aa54c0d2d96185fe173ebb76 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 21 Dec 2017 10:56:14 +0000 Subject: [PATCH 0343/1998] Fix bug in map: should pass args as list This appeared only for variadic function which is used in EVAL. Added a test to step 9 to catch this earlier. --- tests/step9_try.mal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/step9_try.mal b/tests/step9_try.mal index 17cfae240e..d50250ecca 100644 --- a/tests/step9_try.mal +++ b/tests/step9_try.mal @@ -139,6 +139,9 @@ (map (fn* (a) (* 2 a)) [1 2 3]) ;=>(2 4 6) +(map (fn* [& args] (list? args)) [1 2]) +;=>(true true) + ;; Testing vector functions (vector? [10 11]) From bebce74bf5177f51657c0552fea3a20875748649 Mon Sep 17 00:00:00 2001 From: Jonas Lundberg Date: Sat, 30 Dec 2017 19:18:20 +0100 Subject: [PATCH 0344/1998] Update guide with note on reader macro with-meta Guide was missing the deferrable step of having a reader macro for ^ (which is included in the tests for step A) which caused some confusion as to what it was. It's included in the tests/step1_read_print.mal but not mentioned in the docs. --- process/guide.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/process/guide.md b/process/guide.md index 455a76e3f1..025995db4c 100644 --- a/process/guide.md +++ b/process/guide.md @@ -1527,6 +1527,11 @@ diff -urp ../process/step9_try.txt ../process/stepA_mal.txt returned that has its `meta` attribute set to the second argument. Note that it is important that the environment and macro attribute of mal function are retained when it is copied. + * Add a reader-macro that expands the token "^" to + return a new list that contains the symbol "with-meta" and the + result of reading the next next form (2nd argument) (`read_form`) and the + next form (1st argument) in that order + (metadata comes first with the ^ macro and the function second). * Add a new "\*host-language\*" (symbol) entry to your REPL environment. The value of this entry should be a mal string From 3ea9bb9493d43465e516cc1b75e414e5dfd6cd78 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 30 Dec 2017 13:18:34 -0600 Subject: [PATCH 0345/1998] Swift: try forcing Travis to xcode version 7.3 --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 2f641cb216..c189898bc9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -81,7 +81,7 @@ matrix: - {env: IMPL=scheme scheme_MODE=cyclone, services: [docker]} # - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} - {env: IMPL=skew, services: [docker]} - - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7} + - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7.3} - {env: IMPL=swift3, services: [docker]} - {env: IMPL=swift3 NO_DOCKER=1, os: osx, osx_image: xcode8} - {env: IMPL=tcl, services: [docker]} From 3e30ec9aa1afedf8c465750c2f963cf34ea86894 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 2 Jan 2018 23:37:42 +0000 Subject: [PATCH 0346/1998] Dockerfile xenial and binutils install * Changed from generic ubuntu to ubuntu:xenial * Now requires binutils to be installed for `ld` --- nasm/Dockerfile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/nasm/Dockerfile b/nasm/Dockerfile index 53bcd32624..29008471ee 100644 --- a/nasm/Dockerfile +++ b/nasm/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu +FROM ubuntu:xenial MAINTAINER Joel Martin ########################################################## @@ -21,6 +21,6 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -# Install nasm -RUN apt-get -y install nasm +# Install nasm and ld +RUN apt-get -y install nasm binutils From 918f2bee967f88ee1b5ff17620c0a1e97cc26f1b Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 2 Jan 2018 23:39:01 +0000 Subject: [PATCH 0347/1998] Bump language count in README Updated to 72 languages --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index c423c24607..cc88deb97d 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 71 languages: +Mal is implemented in 72 languages: * Ada * GNU awk From c4152b5fc2de09fb00c907caacbce6f427a9b2f1 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Tue, 2 Jan 2018 23:48:51 +0000 Subject: [PATCH 0348/1998] Add stats and stats-lisp targets Updated list of source files, added targets with `;` as the comment character --- nasm/Makefile | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/nasm/Makefile b/nasm/Makefile index 98028e93a2..9ec65de2f1 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -1,7 +1,7 @@ STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal -COMPONENTS=core.asm reader.asm printer.asm types.asm system.asm +COMPONENTS = env.asm core.asm reader.asm printer.asm types.asm system.asm exceptions.asm all: $(STEPS) @@ -11,3 +11,17 @@ all: $(STEPS) %: %.o ld -o $@ $< +###################### + +SOURCES_BASE = reader.asm printer.asm types.asm system.asm exceptions.asm +SOURCES_LISP = env.asm core.asm stepA_mal.asm +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +.PHONY: stats stats-lisp + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" From 20e02704c4974071894528c59ea84af82ffc4b76 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 3 Jan 2018 15:43:22 +0000 Subject: [PATCH 0349/1998] Add clean target Deletes executables and object files --- nasm/Makefile | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/nasm/Makefile b/nasm/Makefile index 9ec65de2f1..bb690ea120 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -3,6 +3,7 @@ STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tc COMPONENTS = env.asm core.asm reader.asm printer.asm types.asm system.asm exceptions.asm + all: $(STEPS) %.o: %.asm $(COMPONENTS) @@ -11,6 +12,10 @@ all: $(STEPS) %: %.o ld -o $@ $< +.PHONY: clean +clean: + rm -f $(STEPS) $(STEPS:%=%.o) + ###################### SOURCES_BASE = reader.asm printer.asm types.asm system.asm exceptions.asm From 39b031b7b83be6140b604ca5adc2144444314eea Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 3 Jan 2018 15:47:05 +0000 Subject: [PATCH 0350/1998] Adding nasm to Travis yml file Enables testing of NASM implementation --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 2f641cb216..7a040ee48a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -51,6 +51,7 @@ matrix: - {env: IMPL=mal BUILD_IMPL=js NO_PERF=1, services: [docker]} - {env: IMPL=matlab, services: [docker]} # Uses Octave - {env: IMPL=miniMAL, services: [docker]} + - {env: IMPL=nasm, services: [docker]} - {env: IMPL=nim, services: [docker]} - {env: IMPL=objpascal, services: [docker]} - {env: IMPL=objc NO_DOCKER=1, os: osx, osx_image: xcode7} From 2f61f4a8d300085e8389817d81e776a1ec84a49a Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Wed, 3 Jan 2018 23:50:34 +0000 Subject: [PATCH 0351/1998] Tidying up steps 0-3 (in progress) Trying to remove common code, and minimise differences between steps. --- nasm/step0_repl.asm | 275 ++------------------------------------ nasm/step1_read_print.asm | 81 ++++------- nasm/step2_eval.asm | 100 +++++++------- nasm/step3_env.asm | 69 +++++----- 4 files changed, 122 insertions(+), 403 deletions(-) diff --git a/nasm/step0_repl.asm b/nasm/step0_repl.asm index decdf4de2e..eece4e8161 100644 --- a/nasm/step0_repl.asm +++ b/nasm/step0_repl.asm @@ -1,209 +1,25 @@ -;; nasm -felf64 mal.asm && ld mal.o && ./a.out +;; +;; nasm -felf64 step0_repl.asm && ld step0_repl.o && ./a.out ;; Calling convention: Address of input is in RSI ;; Address of return value is in RAX ;; -;; Data structures -;; Memory management is done by having two fixed-size datatypes, -;; Cons and Array. -;; -;; Both Cons and Array have the following in common: -;; a type field at the start, a reference count, followed by data -;; [ type (8) | (8) | refs (16) | data ] - +global _start -;; -STRUC Cons -.typecar: RESB 1 ; Type information for car (8 bit) -.typecdr: RESB 1 ; Type information for cdr (8 bits) -.refcount: RESW 1 ; Number of references to this Cons (16 bit) -.car: RESQ 1 ; First value (64 bit) -.cdr: RESQ 1 ; Second value (64 bit) -.size: ; Total size of struc -ENDSTRUC - - -%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk - -STRUC Array -.type: RESB 1 ; Type information (8 bits) -.control: RESB 1 ; Control data (8 bits) -.refcount: RESW 1 ; Number of references to this Array (16 bit) -.length: RESD 1 ; Number of elements in array (32 bit) -.next RESQ 1 ; Pointer to the next chunk (64 bit) -.data: RESQ array_chunk_len ; Data storage -.size: ; Total size of struc -ENDSTRUC - -;; Type information -%define type_char 1 ; Character type -%define type_integer 2 ; Integer type -%define type_float 3 ; Floating point number -%define type_array 128 ; Last bit tests if array or cons - - - - global _start +%include "types.asm" ; Data types, memory +%include "system.asm" ; System calls +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .data -str: ISTRUC Array -AT Array.type, db type_char + type_array -AT Array.length, dd 6 -AT Array.data, db 'hello',10 -IEND - -prompt_string: db 10,"user> " ; The string to print at the prompt -.len: equ $ - prompt_string - -error_msg_print_string: db "Error in print string",10 -.len: equ $ - error_msg_print_string - -section .bss - -section .text - ;; ------------------------------------------ -;; Array alloc_array() -;; -;; Returns the address of an Array object in RAX -alloc_array: - mov rax, str - ret - -;; ------------------------------------------- -;; Prints a raw string to stdout -;; String address in rsi, string length in rdx -print_rawstring: - push rax - push rdi +;; Fixed strings for printing - ; write(1, string, length) - mov rax, 1 ; system call 1 is write - mov rdi, 1 ; file handle 1 is stdout - syscall - - pop rdi - pop rax - - ret + static prompt_string, db 10,"user> " ; The string to print at the prompt -;; ------------------------------------------ -;; void print_string(char array) -;; Address of the char Array should be in RSI -print_string: - ; Push registers we're going to use - push rax - push rdi - push rdx - push rsi - - ; Check that we have a char array - mov al, [rsi] - cmp al, type_char + type_array - jne .error - - ; write(1, string, length) - mov edx, [rsi + Array.length] ; number of bytes - add rsi, Array.data ; address of raw string to output - call print_rawstring - - ; Restore registers - pop rsi - pop rdx - pop rdi - pop rax - - ret -.error: - ; An error occurred - mov rdx, error_msg_print_string.len ; number of bytes - mov rsi, error_msg_print_string ; address of raw string to output - call print_rawstring - ; exit - jmp quit_error - -;; ------------------------------------------ -;; String itostring(Integer number) -;; -;; Converts an integer to a string (array of chars) -;; -;; Input in RAX -;; Return string address in RAX -itostring: - ; Save registers to restore afterwards - push rcx - push rdx - push rsi - push rdi - - mov rcx, 0 ; counter of how many bytes we need to print in the end - -.divideLoop: - inc rcx ; count each byte to print - number of characters - xor rdx, rdx - mov rsi, 10 - idiv rsi ; divide rax by rsi - add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction - ; Character is now in DL - dec rsp - mov BYTE [rsp], dl ; Put onto stack - - cmp rax, 0 ; can the integer be divided anymore? - jnz .divideLoop ; jump if not zero to the label divideLoop - - ; Get an Array object to put the string into - call alloc_array ; Address in RAX - - ; put length into string - mov [rax + Array.length], ecx - - ; copy data from stack into string - ; Note: Currently this does not handle long strings - mov rdi, rax - add rdi, Array.data ; Address where raw string will go -.copyLoop: - mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient - mov [rdi], BYTE dl - inc rsp - inc rdi - dec rcx - cmp rcx, 0 - jnz .copyLoop - - ; Restore registers - pop rdi - pop rsi - pop rdx - pop rcx - - ret - -;; ---------------------------- -;; int stringtoi(String) -;; -;; Convert a string (char array) to an integer -;; -;; Address of input string is in RSI -;; Output integer in RAX -stringtoi: - - ret - -;------------------------------------------ -; void exit() -; Exit program and restore resources -quit: - mov eax, 60 ; system call 60 is exit - xor rdi, rdi ; exit code 0 - syscall ; invoke operating system to exit - -quit_error: - mov eax, 60 ; system call 60 is exit - mov rdi, 1 ; exit code 1 - syscall - +section .text ;; Takes a string as input and processes it into a form read: @@ -230,65 +46,7 @@ rep_seq: mov rsi, rax ; Return value ret -;; Read a line from stdin -;; Gets a new string array, fills it until a newline or EOF is reached -;; Returns pointer to string in RAX -read_line: - ; Get an array to put the string into - ; Address in rax - call alloc_array - ; Mark it as a character array (string) - mov BYTE [rax + Array.type], type_char + type_array - - push rax ; Save pointer to string - - ; Read character by character until either newline or end of input - mov ebx, 0 ; Count how many characters read - mov rsi, rax - add rsi, Array.data ; Point to the data -.readLoop: - mov rax, 0 ; sys_read - mov rdi, 0 ; stdin - mov rdx, 1 ; count - syscall - - ; Characters read in RAX - cmp rax, 0 ; end loop if read <= 0 - jle .readLoopEnd - - mov cl, BYTE [rsi] - - cmp cl, 10 ; End if we read a newline - je .readLoopEnd - - cmp cl, 8 ; Backspace? - je .handleBackspace - - cmp cl, 31 ; Below space - jle .readLoop ; Ignore, keep going - - cmp cl, 127 ; DEL or above - jge .readLoop ; Ignore, keep going - - inc ebx - inc rsi ; Move to next point in the array - jmp .readLoop ; Get another character - -.handleBackspace: - ; Check if we've read any characters - cmp ebx, 0 - je .readLoop ; If not, carry on the loop - ; Characters have been read. Remove one - dec ebx - dec rsi - jmp .readLoop -.readLoopEnd: - pop rax ; Restore pointer to string - mov DWORD [rax + Array.length], ebx ; Set string length - ret - - _start: ; ----------------------------- @@ -296,8 +54,7 @@ _start: .mainLoop: ; print the prompt - mov rdx, prompt_string.len ; number of bytes - mov rsi, prompt_string ; address of raw string to output + load_static prompt_string ; Into RSI and EDX call print_rawstring call read_line @@ -312,15 +69,5 @@ _start: jmp .mainLoop .mainLoopEnd: - ;mov rdx, 1 - ;mov rsi, - ;call print_rawstring - ;inc rsp - - ;mov rax, 1223 - ;call itostring - ;mov rsi, rax - ;call print_string - jmp quit diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index 5aa2fe5504..f64d321561 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -15,57 +15,43 @@ global _start section .data -test_string1: db 10, "test1", 10 -.len: equ $ - test_string1 - -test_string2: db 10, "test2", 10 -.len: equ $ - test_string2 - -;str: ISTRUC Array -;AT Array.type, db maltype_string -;AT Array.length, dd 6 -;AT Array.data, db 'hello',10 -;IEND - -test_cons: ISTRUC Cons -AT Cons.typecar, db ( maltype_integer + 2 ) -AT Cons.typecdr, db 0 -AT Cons.car, dq 123 -IEND - -test_cons2: ISTRUC Cons -AT Cons.typecar, db ( maltype_integer + 2 ) -AT Cons.typecdr, db content_pointer -AT Cons.car, dq 456 -AT Cons.cdr, dq test_cons -IEND - ;; ------------------------------------------ ;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt -prompt_string: db 10,"user> " ; The string to print at the prompt -.len: equ $ - prompt_string - -section .text +section .text + +;; Takes a string as input and processes it into a form +read: + jmp read_str ; In reader.asm -;; Evaluates a form +;; Evaluates a form in RSI eval: mov rax, rsi ; Return the input ret ;; Prints the result print: - mov rax, rsi ; Return the input - ret + mov rdi, 1 ; print readably + jmp pr_str ;; Read-Eval-Print in sequence rep_seq: - call read_str + call read + push rax ; Save form + mov rsi, rax ; Output of read into input of eval call eval - mov rsi, rax ; Output of eval into input of print - call print - mov rsi, rax ; Return value + + mov rsi, rax ; Output of eval into input of print + call print ; String in RAX + + mov r8, rax ; Save output + pop rsi ; Form returned by read + call release_object + mov rax, r8 + ret @@ -76,8 +62,7 @@ _start: .mainLoop: ; print the prompt - mov rdx, prompt_string.len ; number of bytes - mov rsi, prompt_string ; address of raw string to output + load_static prompt_string ; Into RSI and EDX call print_rawstring call read_line @@ -88,29 +73,19 @@ _start: push rax ; Save address of the string - ; Put into read_str - mov rsi, rax - call read_str - push rax - - ; Put into pr_str mov rsi, rax - mov rdi, 1 ; print readably - call pr_str - push rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string mov rsi, rax ; Put into input of print_string call print_string - ; Release string from pr_str + ; Release string from rep_seq pop rsi call release_array - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array - - ; Release the string + ; Release the input string pop rsi call release_array diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 2a495c62be..592fbb0fa8 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -19,37 +19,38 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ ;; Fixed strings for printing -prompt_string: db 10,"user> " ; The string to print at the prompt -.len: equ $ - prompt_string + static prompt_string, db 10,"user> " ; The string to print at the prompt -error_string: db 27,'[31m',"Error",27,'[0m',": " -.len: equ $ - error_string + static error_string, db 27,'[31m',"Error",27,'[0m',": " -def_symbol: ISTRUC Array -AT Array.type, db maltype_symbol -AT Array.length, dd 4 -AT Array.data, db 'def!' -IEND - -let_symbol: ISTRUC Array -AT Array.type, db maltype_symbol -AT Array.length, dd 4 -AT Array.data, db 'let*' -IEND + +;; Symbols used for comparison + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + section .text +;; Takes a string as input and processes it into a form +read: + jmp read_str ; In reader.asm + ;; This is a dummy function so that core routines compile apply_fn: jmp quit + +;; ---------------------------------------------- ;; Evaluates a form in RSI +;; +;; Inputs: RSI Form to evaluate +;; eval_ast: ; Check the type mov al, BYTE [rsi] @@ -104,7 +105,8 @@ eval_ast: cmp ah, content_pointer je .list_pointer - ; A value, so copy + ; A value in RSI, so copy + call alloc_cons mov bl, BYTE [rsi] and bl, content_mask @@ -393,7 +395,13 @@ eval_ast: .done: ret -;; Evaluates a form in RSI +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI Form to evaluate +;; +;; Returns: Result in RAX +;; eval: ; Check type mov al, BYTE [rsi] @@ -489,17 +497,29 @@ eval: ;; Prints the result print: - mov rax, rsi ; Return the input - ret + mov rdi, 1 ; print readably + jmp pr_str ;; Read-Eval-Print in sequence rep_seq: - call read_str + call read + push rax ; Save form + mov rsi, rax ; Output of read into input of eval call eval - mov rsi, rax ; Output of eval into input of print - call print - mov rsi, rax ; Return value + push rax ; Save result + + mov rsi, rax ; Output of eval into input of print + call print ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + pop rsi ; Form returned by read + call release_object + mov rax, r8 + ret @@ -520,8 +540,7 @@ _start: .mainLoop: ; print the prompt - mov rdx, prompt_string.len ; number of bytes - mov rsi, prompt_string ; address of raw string to output + load_static prompt_string ; Into RSI and EDX call print_rawstring call read_line @@ -530,38 +549,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str - mov rsi, rax - call read_str - push rax ; Save AST + push rax ; Save address of the string - ; Eval mov rsi, rax - call eval - push rax ; Save result - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print readably - call pr_str - push rax ; Save output string + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string mov rsi, rax ; Put into input of print_string call print_string - ; Release string from pr_str + ; Release string from rep_seq pop rsi call release_array - - ; Release result of eval - pop rsi - call release_object - - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array ; Release the input string pop rsi diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index 132f72529e..e75da577d8 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -19,7 +19,7 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ @@ -50,8 +50,12 @@ section .data static_symbol def_symbol, 'def!' static_symbol let_symbol, 'let*' - -section .text + +section .text + +;; Takes a string as input and processes it into a form +read: + jmp read_str ; In reader.asm ;; This is a dummy function so that core routines compile apply_fn: @@ -59,7 +63,7 @@ apply_fn: ;; ---------------------------------------------- -;; Evaluates a form +;; Evaluates a form in RSI ;; ;; Inputs: RSI Form to evaluate ;; RDI Environment @@ -869,17 +873,30 @@ eval: ;; Prints the result print: - mov rax, rsi ; Return the input - ret + mov rdi, 1 ; print readably + jmp pr_str ;; Read-Eval-Print in sequence rep_seq: - call read_str + call read + push rax ; Save form + mov rsi, rax ; Output of read into input of eval + mov rdi, [repl_env] ; Environment call eval - mov rsi, rax ; Output of eval into input of print - call print - mov rsi, rax ; Return value + push rax ; Save result + + mov rsi, rax ; Output of eval into input of print + call print ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + pop rsi ; Form returned by read + call release_object + mov rax, r8 + ret @@ -900,8 +917,7 @@ _start: .mainLoop: ; print the prompt - mov rdx, prompt_string.len ; number of bytes - mov rsi, prompt_string ; address of raw string to output + load_static prompt_string ; Into RSI and EDX call print_rawstring call read_line @@ -910,38 +926,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call read_str - push rax ; Save AST + call rep_seq ; Read-Eval-Print - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - call eval - push rax ; Save result - - ; Put into pr_str - mov rsi, rax - call pr_str - push rax ; Save output string + push rax ; Save returned string mov rsi, rax ; Put into input of print_string call print_string - ; Release string from pr_str + ; Release string from rep_seq pop rsi call release_array - - ; Release result of eval - pop rsi - call release_object - - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array ; Release the input string pop rsi From 16ca3eee57bb1be320618b2c822d1c4a4425c642 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 4 Jan 2018 14:36:53 +0000 Subject: [PATCH 0352/1998] Removing env and core from step2 Changed Env to Map. Need to define arithmetic operators in step2 rather than core for this step. --- nasm/step2_eval.asm | 135 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 119 insertions(+), 16 deletions(-) diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 592fbb0fa8..83504df9d8 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -8,10 +8,8 @@ global _start %include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type %include "system.asm" ; System calls %include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String %include "exceptions.asm" ; Error handling @@ -34,18 +32,121 @@ section .data static_symbol def_symbol, 'def!' static_symbol let_symbol, 'let*' - + + static core_add_symbol, db "+" + static core_sub_symbol, db "-" + static core_mul_symbol, db "*" + static core_div_symbol, db "/" + section .text +;; Integer arithmetic operations +;; +;; Adds a list of numbers, address in RSI +;; Returns the sum as a number object with address in RAX +;; Since most of the code is common to all operators, +;; RBX is used to jump to the required instruction +core_add: + mov rbx, core_arithmetic.do_addition + jmp core_arithmetic +core_sub: + mov rbx, core_arithmetic.do_subtraction + jmp core_arithmetic +core_mul: + mov rbx, core_arithmetic.do_multiply + jmp core_arithmetic +core_div: + mov rbx, core_arithmetic.do_division + ; Fall through to core_arithmetic +core_arithmetic: + ; Check that the first object is a number + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + cmp ch, block_cons + jne .missing_args + + mov ch, cl + and ch, content_mask + cmp ch, content_empty + je .missing_args + + cmp ch, content_int + jne .not_int + + ; Put the starting value in rax + mov rax, [rsi + Cons.car] + +.add_loop: + ; Fetch the next value + mov cl, [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .finished ; Nothing let + + mov rsi, [rsi + Cons.cdr] ; Get next cons + + ; Check that it is an integer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_int + jne .not_int + + ; Jump to the required operation, address in RBX + jmp rbx + +.do_addition: + add rax, [rsi + Cons.car] + jmp .add_loop +.do_subtraction: + sub rax, [rsi + Cons.car] + jmp .add_loop +.do_multiply: + imul rax, [rsi + Cons.car] + jmp .add_loop +.do_division: + cqo ; Sign extend RAX into RDX + mov rcx, [rsi + Cons.car] + idiv rcx + jmp .add_loop + +.finished: + ; Value in rbx + push rax + ; Get a Cons object to put the result into + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.missing_args: +.not_int: + jmp quit + +;; Add a native function to the core environment +;; This is used in core_environment +%macro core_env_native 2 + push rsi ; environment + mov rsi, %1 + mov edx, %1.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, %2 + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call map_set +%endmacro + + + ;; Takes a string as input and processes it into a form read: jmp read_str ; In reader.asm -;; This is a dummy function so that core routines compile -apply_fn: - jmp quit - - ;; ---------------------------------------------- ;; Evaluates a form in RSI ;; @@ -81,7 +182,7 @@ eval_ast: ; look in environment mov rdi, rsi ; symbol is the key mov rsi, [repl_env] ; Environment - call env_get + call map_get je .done ; result in RAX ; Not found, should raise an error @@ -525,16 +626,18 @@ rep_seq: _start: ; Create and print the core environment - call core_environment ; Environment in RAX + call map_new ; Environment in RAX mov [repl_env], rax ; store in memory - - mov rsi, rax - call pr_str - - mov rsi, rax ; Put into input of print_string - call print_string + mov rsi, rax ; Environment + + ; Add +,-,*,/ to environment + core_env_native core_add_symbol, core_add + core_env_native core_sub_symbol, core_sub + core_env_native core_mul_symbol, core_mul + core_env_native core_div_symbol, core_div + ; ----------------------------- ; Main loop From 9cb95668977bf7948bf3e5dd7d7a304e75a9c0f1 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Thu, 4 Jan 2018 16:05:03 +0000 Subject: [PATCH 0353/1998] Tidying, minimising differences between steps Merging fixes in stepA into earlier steps, and removing differences in comments and spacing --- nasm/step0_repl.asm | 19 ++- nasm/step1_read_print.asm | 24 +++- nasm/step2_eval.asm | 26 ++-- nasm/step3_env.asm | 213 +++++++++++++++++++++++------- nasm/step4_if_fn_do.asm | 88 +++++++------ nasm/step5_tco.asm | 56 ++++---- nasm/step6_file.asm | 56 ++++---- nasm/step7_quote.asm | 264 +++++++++++++------------------------- nasm/step8_macros.asm | 82 +++++++----- nasm/step9_try.asm | 80 +++++++----- nasm/stepA_mal.asm | 50 +++----- 11 files changed, 530 insertions(+), 428 deletions(-) diff --git a/nasm/step0_repl.asm b/nasm/step0_repl.asm index eece4e8161..850f69ee81 100644 --- a/nasm/step0_repl.asm +++ b/nasm/step0_repl.asm @@ -16,7 +16,7 @@ section .data ;; ------------------------------------------ ;; Fixed strings for printing - + static prompt_string, db 10,"user> " ; The string to print at the prompt section .text @@ -25,7 +25,8 @@ section .text read: mov rax, rsi ; Return the input ret - + +;; ---------------------------------------------- ;; Evaluates a form eval: mov rax, rsi ; Return the input @@ -38,12 +39,21 @@ print: ;; Read-Eval-Print in sequence rep_seq: + ; ------------- + ; Read call read + + ; ------------- + ; Eval mov rsi, rax ; Output of read into input of eval call eval + + ; ------------- + ; Print + mov rsi, rax ; Output of eval into input of print call print - mov rsi, rax ; Return value + ret @@ -54,8 +64,7 @@ _start: .mainLoop: ; print the prompt - load_static prompt_string ; Into RSI and EDX - call print_rawstring + print_str_mac prompt_string call read_line diff --git a/nasm/step1_read_print.asm b/nasm/step1_read_print.asm index f64d321561..e02ebee968 100644 --- a/nasm/step1_read_print.asm +++ b/nasm/step1_read_print.asm @@ -17,7 +17,7 @@ section .data ;; ------------------------------------------ ;; Fixed strings for printing - + static prompt_string, db 10,"user> " ; The string to print at the prompt section .text @@ -25,8 +25,12 @@ section .text ;; Takes a string as input and processes it into a form read: jmp read_str ; In reader.asm - -;; Evaluates a form in RSI + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; eval: mov rax, rsi ; Return the input ret @@ -38,13 +42,20 @@ print: ;; Read-Eval-Print in sequence rep_seq: + ; ------------- + ; Read call read push rax ; Save form - + + ; ------------- + ; Eval mov rsi, rax ; Output of read into input of eval call eval + + ; ------------- + ; Print - mov rsi, rax ; Output of eval into input of print + mov rsi, rax ; Output of eval into input of print call print ; String in RAX mov r8, rax ; Save output @@ -62,8 +73,7 @@ _start: .mainLoop: ; print the prompt - load_static prompt_string ; Into RSI and EDX - call print_rawstring + print_str_mac prompt_string call read_line diff --git a/nasm/step2_eval.asm b/nasm/step2_eval.asm index 83504df9d8..119871bbaa 100644 --- a/nasm/step2_eval.asm +++ b/nasm/step2_eval.asm @@ -148,7 +148,7 @@ read: jmp read_str ; In reader.asm ;; ---------------------------------------------- -;; Evaluates a form in RSI +;; Evaluates a form ;; ;; Inputs: RSI Form to evaluate ;; @@ -499,7 +499,7 @@ eval_ast: ;; ---------------------------------------------------- ;; Evaluates a form ;; -;; Input: RSI Form to evaluate +;; Input: RSI AST to evaluate ;; ;; Returns: Result in RAX ;; @@ -520,18 +520,18 @@ eval: ; -------------------- .list: ; A list - + ; Check if the first element is a symbol mov al, BYTE [rsi] - and bl, content_mask - cmp bl, content_pointer + and al, content_mask + cmp al, content_pointer jne .list_eval mov rbx, [rsi + Cons.car] mov al, BYTE [rbx] cmp al, maltype_symbol jne .list_eval - + ; Is a symbol, address in RBX push rsi @@ -542,7 +542,7 @@ eval: pop rsi cmp rax, 0 je .def_symbol - + push rsi mov rdi, let_symbol call compare_char_array @@ -603,13 +603,20 @@ print: ;; Read-Eval-Print in sequence rep_seq: + ; ------------- + ; Read call read push rax ; Save form - + + ; ------------- + ; Eval mov rsi, rax ; Output of read into input of eval call eval push rax ; Save result + ; ------------- + ; Print + mov rsi, rax ; Output of eval into input of print call print ; String in RAX @@ -643,8 +650,7 @@ _start: .mainLoop: ; print the prompt - load_static prompt_string ; Into RSI and EDX - call print_rawstring + print_str_mac prompt_string call read_line diff --git a/nasm/step3_env.asm b/nasm/step3_env.asm index e75da577d8..70460bafae 100644 --- a/nasm/step3_env.asm +++ b/nasm/step3_env.asm @@ -11,7 +11,6 @@ global _start %include "env.asm" ; Environment type %include "system.asm" ; System calls %include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String %include "exceptions.asm" ; Error handling @@ -29,7 +28,7 @@ section .data static error_string, db 27,'[31m',"Error",27,'[0m',": " - static not_found_string, db " not found.",10 + static not_found_string, db " not found" static def_missing_arg_string, db "missing argument to def!",10 @@ -50,20 +49,123 @@ section .data static_symbol def_symbol, 'def!' static_symbol let_symbol, 'let*' - + + static core_add_symbol, db "+" + static core_sub_symbol, db "-" + static core_mul_symbol, db "*" + static core_div_symbol, db "/" + section .text +;; Integer arithmetic operations +;; +;; Adds a list of numbers, address in RSI +;; Returns the sum as a number object with address in RAX +;; Since most of the code is common to all operators, +;; RBX is used to jump to the required instruction +core_add: + mov rbx, core_arithmetic.do_addition + jmp core_arithmetic +core_sub: + mov rbx, core_arithmetic.do_subtraction + jmp core_arithmetic +core_mul: + mov rbx, core_arithmetic.do_multiply + jmp core_arithmetic +core_div: + mov rbx, core_arithmetic.do_division + ; Fall through to core_arithmetic +core_arithmetic: + ; Check that the first object is a number + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + cmp ch, block_cons + jne .missing_args + + mov ch, cl + and ch, content_mask + cmp ch, content_empty + je .missing_args + + cmp ch, content_int + jne .not_int + + ; Put the starting value in rax + mov rax, [rsi + Cons.car] + +.add_loop: + ; Fetch the next value + mov cl, [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .finished ; Nothing let + + mov rsi, [rsi + Cons.cdr] ; Get next cons + + ; Check that it is an integer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_int + jne .not_int + + ; Jump to the required operation, address in RBX + jmp rbx + +.do_addition: + add rax, [rsi + Cons.car] + jmp .add_loop +.do_subtraction: + sub rax, [rsi + Cons.car] + jmp .add_loop +.do_multiply: + imul rax, [rsi + Cons.car] + jmp .add_loop +.do_division: + cqo ; Sign extend RAX into RDX + mov rcx, [rsi + Cons.car] + idiv rcx + jmp .add_loop + +.finished: + ; Value in rbx + push rax + ; Get a Cons object to put the result into + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.missing_args: +.not_int: + jmp quit + +;; Add a native function to the core environment +;; This is used in core_environment +%macro core_env_native 2 + push rsi ; environment + mov rsi, %1 + mov edx, %1.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, %2 + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set +%endmacro + + + ;; Takes a string as input and processes it into a form read: jmp read_str ; In reader.asm -;; This is a dummy function so that core routines compile -apply_fn: - jmp quit - - ;; ---------------------------------------------- -;; Evaluates a form in RSI +;; Evaluates a form ;; ;; Inputs: RSI Form to evaluate ;; RDI Environment @@ -108,19 +210,15 @@ eval_ast: ; Not found, throw an error push rsi - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' - + print_str_mac error_string ; print 'Error: ' + pop rsi push rsi mov edx, [rsi + Array.length] add rsi, Array.data call print_rawstring ; print symbol - - mov rsi, not_found_string - mov rdx, not_found_string.len - call print_rawstring ; print ' not found' + + print_str_mac not_found_string ; print ' not found' pop rsi jmp error_throw @@ -475,10 +573,27 @@ eval_ast: .done: ret + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + ;; ---------------------------------------------------- ;; Evaluates a form ;; -;; Input: RSI Form to evaluate +;; Input: RSI AST to evaluate ;; RDI Environment ;; ;; Returns: Result in RAX @@ -515,26 +630,13 @@ eval: jne .list_eval ; Is a symbol, address in RBX - push rsi - push rbx - ; Compare against def! - mov rsi, rbx - mov rdi, def_symbol - call compare_char_array - pop rbx - pop rsi - cmp rax, 0 + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! je .def_symbol - push rsi - push rbx - mov rsi, rbx - mov rdi, let_symbol - call compare_char_array - pop rbx - pop rsi - cmp rax, 0 + eval_cmp_symbol let_symbol ; let* je .let_symbol ; Unrecognised @@ -627,9 +729,7 @@ eval: .def_handle_error: push rsi push rdx - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' + print_str_mac error_string ; print 'Error: ' pop rdx pop rsi @@ -645,7 +745,7 @@ eval: mov r11, rsi ; Let form in R11 mov rsi, r15 ; Outer env - call env_new + call env_new ; Increments R15's ref count mov r14, rax ; New environment in R14 ; Second element should be the bindings @@ -818,9 +918,8 @@ eval: push rsi push rdx - mov rsi, error_string - mov rdx, error_string.len - call print_rawstring ; print 'Error: ' + + print_str_mac error_string ; print 'Error: ' pop rdx pop rsi @@ -832,11 +931,12 @@ eval: ; ----------------------------- .list_eval: - + push rsi mov rdi, r15 ; Environment push r15 - call eval_ast + call eval_ast ; List of evaluated forms in RAX pop r15 + pop rsi ; Check that the first element of the return is a function mov bl, BYTE [rax] @@ -878,14 +978,21 @@ print: ;; Read-Eval-Print in sequence rep_seq: + ; ------------- + ; Read call read push rax ; Save form - - mov rsi, rax ; Output of read into input of eval + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate mov rdi, [repl_env] ; Environment call eval push rax ; Save result + ; ------------- + ; Print + mov rsi, rax ; Output of eval into input of print call print ; String in RAX @@ -902,10 +1009,18 @@ rep_seq: _start: ; Create and print the core environment - call core_environment ; Environment in RAX + call env_new ; Environment in RAX mov [repl_env], rax ; store in memory + mov rsi, rax ; Environment + + ; Add +,-,*,/ to environment + core_env_native core_add_symbol, core_add + core_env_native core_sub_symbol, core_sub + core_env_native core_mul_symbol, core_mul + core_env_native core_div_symbol, core_div + ; Set the error handler mov rsi, rsp ; Stack pointer mov rdi, .catch ; Address to jump to @@ -917,8 +1032,7 @@ _start: .mainLoop: ; print the prompt - load_static prompt_string ; Into RSI and EDX - call print_rawstring + print_str_mac prompt_string call read_line @@ -955,6 +1069,7 @@ _start: ; Check if an object was thrown cmp rsi, 0 je .catch_done_print ; nothing to print + mov rdi, 1 call pr_str mov rsi, rax call print_string diff --git a/nasm/step4_if_fn_do.asm b/nasm/step4_if_fn_do.asm index 110cc2d66c..27343a0ed7 100644 --- a/nasm/step4_if_fn_do.asm +++ b/nasm/step4_if_fn_do.asm @@ -19,7 +19,7 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ @@ -29,7 +29,7 @@ section .data static error_string, db 27,'[31m',"Error",27,'[0m',": " - static not_found_string, db " not found.",10 + static not_found_string, db " not found" static def_missing_arg_string, db "missing argument to def!",10 @@ -498,13 +498,13 @@ eval_ast: call compare_char_array pop rbx pop rsi - cmp rax, 0 + test rax, rax ; ZF set if rax = 0 (equal) %endmacro ;; ---------------------------------------------------- ;; Evaluates a form ;; -;; Input: RSI Form to evaluate +;; Input: RSI AST to evaluate ;; RDI Environment ;; ;; Returns: Result in RAX @@ -531,7 +531,6 @@ eval: ; Check if the first element is a symbol mov al, BYTE [rsi] - and al, content_mask cmp al, content_pointer jne .list_eval @@ -562,6 +561,9 @@ eval: ; Unrecognised jmp .list_eval + + + ; ----------------------------- .def_symbol: ; Define a new symbol in current environment @@ -617,13 +619,13 @@ eval: ; This may throw an error, so define a handler - push r8 ; the symbol push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer mov rdi, r15 call eval mov rsi, rax + pop r15 pop r8 @@ -666,7 +668,7 @@ eval: mov r11, rsi ; Let form in R11 mov rsi, r15 ; Outer env - call env_new + call env_new ; Increments R15's ref count mov r14, rax ; New environment in R14 ; Second element should be the bindings @@ -885,7 +887,6 @@ eval: mov rsi, rax call release_object .do_next: - mov r11, [r11 + Cons.cdr] ; Next in list jmp .do_symbol_loop @@ -954,7 +955,7 @@ eval: pop r11 pop r15 - ; Get type + ; Get type of result mov bl, BYTE [rax] ; release value @@ -1105,6 +1106,8 @@ eval: mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) @@ -1147,7 +1150,7 @@ eval: push rsi mov rdi, r15 ; Environment push r15 - call eval_ast + call eval_ast ; List of evaluated forms in RAX pop r15 pop rsi @@ -1208,7 +1211,9 @@ eval: ;; Input: RSI - Arguments to bind ;; RDI - Function object ;; +;; ;; Output: Result in RAX +;; apply_fn: push rsi ; Extract values from the list in RDI @@ -1252,13 +1257,36 @@ apply_fn: ;; Read-Eval-Print in sequence +;; +;; Input string in RSI rep_seq: + ; ------------- + ; Read call read_str - mov rsi, rax ; Output of read into input of eval + push rax ; Save form + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment call eval - mov rsi, rax ; Output of eval into input of print - call pr_str - mov rsi, rax ; Return value + push rax ; Save result + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + pop rsi ; Form returned by read + call release_object + mov rax, r8 + ret @@ -1279,7 +1307,7 @@ _start: mov rsi, mal_startup_string mov edx, mal_startup_string.len call raw_to_string ; String in RAX - + push rax mov rsi, rax call read_str ; AST in RAX @@ -1312,39 +1340,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str - mov rsi, rax - call read_str - push rax ; Save AST + push rax ; Save address of the string - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - call eval - push rax ; Save result - - ; Put into pr_str mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string mov rsi, rax ; Put into input of print_string call print_string - ; Release string from pr_str + ; Release string from rep_seq pop rsi call release_array - - ; Release result of eval - pop rsi - call release_object - - ; Release the object from read_str - pop rsi - call release_object ; Could be Cons or Array ; Release the input string pop rsi diff --git a/nasm/step5_tco.asm b/nasm/step5_tco.asm index af5525f425..76aaea2483 100644 --- a/nasm/step5_tco.asm +++ b/nasm/step5_tco.asm @@ -19,7 +19,7 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ @@ -29,7 +29,7 @@ section .data static error_string, db 27,'[31m',"Error",27,'[0m',": " - static not_found_string, db " not found.",10 + static not_found_string, db " not found" static def_missing_arg_string, db "missing argument to def!",10 @@ -589,6 +589,9 @@ eval: ; Unrecognised jmp .list_eval + + + ; ----------------------------- .def_symbol: ; Define a new symbol in current environment @@ -644,7 +647,6 @@ eval: ; This may throw an error, so define a handler - push r8 ; the symbol push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer @@ -1312,9 +1314,16 @@ eval: je .list_got_args ; No arguments - push rbx + + push rbx ; Function object + + mov rsi, rax ; List with function first + call release_object ; Can be freed now + + ; Create an empty list for the arguments call alloc_cons mov [rax], BYTE maltype_empty_list + pop rbx mov rsi, rax jmp .list_function_call @@ -1471,25 +1480,16 @@ rep_seq: ; ------------- ; Print - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - ; Release string from pr_str - pop rsi - call release_array + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX - ; Release result of eval - pop rsi + mov r8, rax ; Save output + + pop rsi ; Result from eval call release_object - - ; The AST from read_str is released by eval + mov rax, r8 ret @@ -1544,11 +1544,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call rep_seq + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array ; Release the input string pop rsi diff --git a/nasm/step6_file.asm b/nasm/step6_file.asm index 0020d559bc..d6e7c3f9e1 100644 --- a/nasm/step6_file.asm +++ b/nasm/step6_file.asm @@ -19,7 +19,7 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ @@ -29,7 +29,7 @@ section .data static error_string, db 27,'[31m',"Error",27,'[0m',": " - static not_found_string, db " not found.",10 + static not_found_string, db " not found" static def_missing_arg_string, db "missing argument to def!",10 @@ -591,6 +591,9 @@ eval: ; Unrecognised jmp .list_eval + + + ; ----------------------------- .def_symbol: ; Define a new symbol in current environment @@ -646,7 +649,6 @@ eval: ; This may throw an error, so define a handler - push r8 ; the symbol push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer @@ -1314,9 +1316,16 @@ eval: je .list_got_args ; No arguments - push rbx + + push rbx ; Function object + + mov rsi, rax ; List with function first + call release_object ; Can be freed now + + ; Create an empty list for the arguments call alloc_cons mov [rax], BYTE maltype_empty_list + pop rbx mov rsi, rax jmp .list_function_call @@ -1490,25 +1499,16 @@ rep_seq: ; ------------- ; Print - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - ; Release string from pr_str - pop rsi - call release_array + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX - ; Release result of eval - pop rsi + mov r8, rax ; Save output + + pop rsi ; Result from eval call release_object - - ; The AST from read_str is released by eval + mov rax, r8 ret @@ -1578,11 +1578,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call rep_seq + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array ; Release the input string pop rsi diff --git a/nasm/step7_quote.asm b/nasm/step7_quote.asm index 2b71b70aa4..493d04b1d6 100644 --- a/nasm/step7_quote.asm +++ b/nasm/step7_quote.asm @@ -13,15 +13,13 @@ global _start %include "reader.asm" ; String -> Data structures %include "core.asm" ; Core functions %include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling section .bss ;; Top-level (REPL) environment repl_env:resq 1 -;; Error handler list -error_handler: resq 1 - section .data ;; ------------------------------------------ @@ -31,7 +29,7 @@ section .data static error_string, db 27,'[31m',"Error",27,'[0m',": " - static not_found_string, db " not found.",10 + static not_found_string, db " not found" static def_missing_arg_string, db "missing argument to def!",10 @@ -69,141 +67,11 @@ section .data ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) )" - - ;static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) )" - + ;; Command to run, appending the name of the script to run static run_script_string, db "(load-file ",34 section .text -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - ;; ---------------------------------------------- ;; Evaluates a form ;; @@ -736,6 +604,9 @@ eval: ; Unrecognised jmp .list_eval + + + ; ----------------------------- .def_symbol: ; Define a new symbol in current environment @@ -791,7 +662,6 @@ eval: ; This may throw an error, so define a handler - push r8 ; the symbol push r15 ; Env mov rsi, [rsi + Cons.car] ; Pointer @@ -805,6 +675,7 @@ eval: call eval mov rsi, rax + pop r15 pop r8 @@ -927,11 +798,15 @@ eval: push r12 ; Position in bindings list push r13 ; symbol to bind push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + mov rsi, [r12 + Cons.car] ; Get the address call incref_object ; Increment ref count of AST - mov rdi, r14 call eval ; Evaluate it, result in rax pop r14 pop r13 @@ -1146,7 +1021,6 @@ eval: ; An expression to evaluate as the last form ; Tail call optimise, jumping to eval ; Don't increment Env reference count - mov rsi, [r11 + Cons.car] ; new AST form call incref_object ; This will be released by eval @@ -1383,6 +1257,8 @@ eval: mov rsi, r15 call incref_object pop rax + + ; Binds call alloc_cons mov [rax], BYTE (block_cons + container_function + content_pointer) @@ -1476,9 +1352,6 @@ eval: .quasiquote_pointer: ; RSI contains a pointer, so get the object pointed to mov rsi, [rsi + Cons.car] - - ;call quasiquote - ;ret push r15 ; Environment ; Original AST already on stack @@ -1503,8 +1376,7 @@ eval: call eval_ast ; List of evaluated forms in RAX pop r15 pop rsi - - + .list_exec: ; This point can be called to run a function ; used by swap! @@ -1529,9 +1401,16 @@ eval: je .list_got_args ; No arguments - push rbx + + push rbx ; Function object + + mov rsi, rax ; List with function first + call release_object ; Can be freed now + + ; Create an empty list for the arguments call alloc_cons mov [rax], BYTE maltype_empty_list + pop rbx mov rsi, rax jmp .list_function_call @@ -1545,7 +1424,7 @@ eval: mov rbx, [rbx + Cons.car] ; Call function cmp rbx, apply_fn - je apply_fn ; Jump to user function apply + je apply_fn_jmp ; Jump to user function apply ; A built-in function, so call (no recursion) push rax @@ -1556,11 +1435,10 @@ eval: ; Result in rax pop r15 pop rsi ; eval'ed list - + push rax call release_cons - pop rax - + pop rax jmp .return ; Releases Env .list_not_function: @@ -1582,11 +1460,16 @@ eval: ;; RDI - Function object ;; RDX - list to release after binding ;; R15 - Env (will be released) +;; R13 - AST released before return +;; ;; ;; Output: Result in RAX ;; ;; This is jumped to from eval, so if it returns ;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 apply_fn: push rsi ; Extract values from the list in RDI @@ -1617,8 +1500,8 @@ apply_fn: mov rsi, r15 call release_object - ; Release the AST, pushed at start of eval - pop rsi + ; Release the AST + mov rsi, r13 call release_object mov rax, r14 @@ -1627,23 +1510,36 @@ apply_fn: ; Create a new environment, binding arguments push rax ; Body + mov r14, r13 ; Old AST. R13 used by env_new_bind + push rdx call env_new_bind pop rdx mov rdi, rax ; New environment in RDI + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + ; Release the list passed in RDX -.release: mov rsi, rdx call release_cons ; Release the environment mov rsi, r15 call release_object - - pop rsi ; Body - call incref_object ; Will be released by eval + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body jmp eval ; Tail call ; The new environment (in RDI) will be released by eval @@ -1681,7 +1577,6 @@ is_pair: ;; Called by eval with AST in RSI [ modified ] ;; Returns new AST in RAX - quasiquote: ; i. Check if AST is an empty list call is_pair @@ -2007,7 +1902,23 @@ quasiquote: +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + ;; Read-Eval-Print in sequence ;; @@ -2031,25 +1942,16 @@ rep_seq: ; ------------- ; Print - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - ; Release string from pr_str - pop rsi - call release_array + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX - ; Release result of eval - pop rsi + mov r8, rax ; Save output + + pop rsi ; Result from eval call release_object - - ; The AST from read_str is released by eval + mov rax, r8 ret @@ -2119,11 +2021,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call rep_seq + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array ; Release the input string pop rsi @@ -2220,7 +2130,7 @@ run_script: mov cl, ')' call string_append_char ; closing brace - ; Read-Eval-Print "(load-file )" - call rep_seq + ; Read-Eval "(load-file )" + call read_eval jmp quit diff --git a/nasm/step8_macros.asm b/nasm/step8_macros.asm index 3b6d7d5f14..b4c6bd12ea 100644 --- a/nasm/step8_macros.asm +++ b/nasm/step8_macros.asm @@ -19,7 +19,7 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ @@ -29,7 +29,7 @@ section .data static error_string, db 27,'[31m',"Error",27,'[0m',": " - static not_found_string, db " not found.",10 + static not_found_string, db " not found" static def_missing_arg_string, db "missing argument to def!",10 @@ -51,8 +51,7 @@ section .data static if_missing_condition_string, db "missing condition in if expression",10 ;; Symbols used for comparison - - ; Special symbols + static_symbol def_symbol, 'def!' static_symbol let_symbol, 'let*' static_symbol do_symbol, 'do' @@ -69,7 +68,6 @@ section .data static_symbol splice_unquote_symbol, 'splice-unquote' static_symbol concat_symbol, 'concat' static_symbol cons_symbol, 'cons' - ; ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) )" @@ -1415,10 +1413,6 @@ eval: .quasiquote_pointer: ; RSI contains a pointer, so get the object pointed to mov rsi, [rsi + Cons.car] - - ; Uncomment these two lines to test quasiquote - ;call quasiquote - ;ret push r15 ; Environment ; Original AST already on stack @@ -1499,9 +1493,16 @@ eval: je .list_got_args ; No arguments - push rbx + + push rbx ; Function object + + mov rsi, rax ; List with function first + call release_object ; Can be freed now + + ; Create an empty list for the arguments call alloc_cons mov [rax], BYTE maltype_empty_list + pop rbx mov rsi, rax jmp .list_function_call @@ -2113,6 +2114,24 @@ macroexpand: .done: pop r15 ret + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + ;; Read-Eval-Print in sequence ;; @@ -2136,25 +2155,16 @@ rep_seq: ; ------------- ; Print - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - ; Release string from pr_str - pop rsi - call release_array + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX - ; Release result of eval - pop rsi + mov r8, rax ; Save output + + pop rsi ; Result from eval call release_object - - ; The AST from read_str is released by eval + mov rax, r8 ret @@ -2224,11 +2234,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call rep_seq + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array ; Release the input string pop rsi @@ -2325,7 +2343,7 @@ run_script: mov cl, ')' call string_append_char ; closing brace - ; Read-Eval-Print "(load-file )" - call rep_seq + ; Read-Eval "(load-file )" + call read_eval jmp quit diff --git a/nasm/step9_try.asm b/nasm/step9_try.asm index 4faeecf9e6..5c24b599fa 100644 --- a/nasm/step9_try.asm +++ b/nasm/step9_try.asm @@ -19,7 +19,7 @@ section .bss ;; Top-level (REPL) environment repl_env:resq 1 - + section .data ;; ------------------------------------------ @@ -56,7 +56,6 @@ section .data ;; Symbols used for comparison - ; Special symbols static_symbol def_symbol, 'def!' static_symbol let_symbol, 'let*' static_symbol do_symbol, 'do' @@ -75,7 +74,6 @@ section .data static_symbol splice_unquote_symbol, 'splice-unquote' static_symbol concat_symbol, 'concat' static_symbol cons_symbol, 'cons' - ; ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs)))))))) )" @@ -1443,10 +1441,6 @@ eval: .quasiquote_pointer: ; RSI contains a pointer, so get the object pointed to mov rsi, [rsi + Cons.car] - - ; Uncomment these two lines to test quasiquote - ;call quasiquote - ;ret push r15 ; Environment ; Original AST already on stack @@ -1491,7 +1485,7 @@ eval: call macroexpand ; May release and replace RSI mov rax, rsi - jmp .return ; Releases original AST + jmp .return ; Releases original AST ; ----------------------------- @@ -1719,9 +1713,16 @@ eval: je .list_got_args ; No arguments - push rbx + + push rbx ; Function object + + mov rsi, rax ; List with function first + call release_object ; Can be freed now + + ; Create an empty list for the arguments call alloc_cons mov [rax], BYTE maltype_empty_list + pop rbx mov rsi, rax jmp .list_function_call @@ -2333,6 +2334,24 @@ macroexpand: .done: pop r15 ret + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + ;; Read-Eval-Print in sequence ;; @@ -2356,25 +2375,16 @@ rep_seq: ; ------------- ; Print - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - ; Release string from pr_str - pop rsi - call release_array + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX - ; Release result of eval - pop rsi + mov r8, rax ; Save output + + pop rsi ; Result from eval call release_object - - ; The AST from read_str is released by eval + mov rax, r8 ret @@ -2444,11 +2454,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call rep_seq + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array ; Release the input string pop rsi @@ -2545,7 +2563,7 @@ run_script: mov cl, ')' call string_append_char ; closing brace - ; Read-Eval-Print "(load-file )" - call rep_seq + ; Read-Eval "(load-file )" + call read_eval jmp quit diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index c1e3d7a233..c47ee2f6d9 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -56,7 +56,6 @@ section .data ;; Symbols used for comparison - ; Special symbols static_symbol def_symbol, 'def!' static_symbol let_symbol, 'let*' static_symbol do_symbol, 'do' @@ -75,7 +74,6 @@ section .data static_symbol splice_unquote_symbol, 'splice-unquote' static_symbol concat_symbol, 'concat' static_symbol cons_symbol, 'cons' - ; ;; Startup string. This is evaluated on startup static mal_startup_string, db "(do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,")",34," ))))) (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) (def! *gensym-counter* (atom 0)) (def! gensym (fn* [] (symbol (str ",34,"G__",34," (swap! *gensym-counter* (fn* [x] (+ 1 x))))))) (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs))))))))) (def! *host-language* ",34,"nasm",34,") (def! conj nil) )" @@ -1458,10 +1456,6 @@ eval: .quasiquote_pointer: ; RSI contains a pointer, so get the object pointed to mov rsi, [rsi + Cons.car] - - ; Uncomment these two lines to test quasiquote - ;call quasiquote - ;ret push r15 ; Environment ; Original AST already on stack @@ -1506,7 +1500,7 @@ eval: call macroexpand ; May release and replace RSI mov rax, rsi - jmp .return ; Releases original AST + jmp .return ; Releases original AST ; ----------------------------- @@ -1623,7 +1617,7 @@ eval: pop r15 ; Environment ; Discard B and C - ;add rsi, 8 ; pop R10 and R9 + ;add rsi, 8 ; pop R10 and R9 pop r10 pop r9 @@ -1814,7 +1808,6 @@ apply_fn: mov rax, [rax + Cons.cdr] mov rax, [rax + Cons.car] ; Body pop rcx ; Exprs - ; Check the type of the body mov bl, BYTE [rax] @@ -2398,25 +2391,16 @@ rep_seq: ; ------------- ; Print - - ; Put into pr_str - mov rsi, rax - mov rdi, 1 ; print_readably - call pr_str - push rax ; Save output string - - mov rsi, rax ; Put into input of print_string - call print_string - ; Release string from pr_str - pop rsi - call release_array + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX - ; Release result of eval - pop rsi + mov r8, rax ; Save output + + pop rsi ; Result from eval call release_object - - ; The AST from read_str is released by eval + mov rax, r8 ret @@ -2502,11 +2486,19 @@ _start: cmp DWORD [rax+Array.length], 0 je .mainLoopEnd - push rax ; Save address of the input string - - ; Put into read_str + push rax ; Save address of the string + mov rsi, rax - call rep_seq + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array ; Release the input string pop rsi From ba46e3b027e7df2ebd2d0cee1616d5a41a2b3d4e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 2 Apr 2018 11:01:24 -0500 Subject: [PATCH 0354/1998] [clojure] update lumo/image to fix module mismatch. --- clojure/Dockerfile | 2 +- clojure/package.json | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/clojure/Dockerfile b/clojure/Dockerfile index 2a8eb37114..5060a80322 100644 --- a/clojure/Dockerfile +++ b/clojure/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:xenial +FROM ubuntu:17.10 MAINTAINER Joel Martin ########################################################## diff --git a/clojure/package.json b/clojure/package.json index ea4479f733..e2248254f0 100644 --- a/clojure/package.json +++ b/clojure/package.json @@ -4,6 +4,6 @@ "description": "Make a Lisp (mal) language implemented in ClojureScript", "dependencies": { "ffi": "2.2.x", - "lumo-cljs": "^1.6.0" + "lumo-cljs": "1.7.x" } } From 92708e3488ad2e994f481edd05ff24e70e6d6867 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sun, 29 Apr 2018 12:53:32 +0000 Subject: [PATCH 0355/1998] Add Fantom implementation --- .gitignore | 1 + Makefile | 3 +- README.md | 15 +- fantom/Dockerfile | 37 ++++ fantom/Makefile | 31 +++ fantom/run | 4 + fantom/src/mallib/build.fan | 11 ++ fantom/src/mallib/fan/core.fan | 117 ++++++++++++ fantom/src/mallib/fan/env.fan | 40 ++++ fantom/src/mallib/fan/interop.fan | 61 ++++++ fantom/src/mallib/fan/reader.fan | 104 ++++++++++ fantom/src/mallib/fan/types.fan | 234 +++++++++++++++++++++++ fantom/src/step0_repl/build.fan | 11 ++ fantom/src/step0_repl/fan/main.fan | 32 ++++ fantom/src/step1_read_print/build.fan | 11 ++ fantom/src/step1_read_print/fan/main.fan | 37 ++++ fantom/src/step2_eval/build.fan | 11 ++ fantom/src/step2_eval/fan/main.fan | 70 +++++++ fantom/src/step3_env/build.fan | 11 ++ fantom/src/step3_env/fan/main.fan | 79 ++++++++ fantom/src/step4_if_fn_do/build.fan | 11 ++ fantom/src/step4_if_fn_do/fan/main.fan | 91 +++++++++ fantom/src/step5_tco/build.fan | 11 ++ fantom/src/step5_tco/fan/main.fan | 113 +++++++++++ fantom/src/step6_file/build.fan | 11 ++ fantom/src/step6_file/fan/main.fan | 122 ++++++++++++ fantom/src/step7_quote/build.fan | 11 ++ fantom/src/step7_quote/fan/main.fan | 143 ++++++++++++++ fantom/src/step8_macros/build.fan | 11 ++ fantom/src/step8_macros/fan/main.fan | 174 +++++++++++++++++ fantom/src/step9_try/build.fan | 11 ++ fantom/src/step9_try/fan/main.fan | 186 ++++++++++++++++++ fantom/src/stepA_mal/build.fan | 11 ++ fantom/src/stepA_mal/fan/main.fan | 190 ++++++++++++++++++ fantom/tests/step5_tco.mal | 15 ++ fantom/tests/stepA_mal.mal | 32 ++++ 36 files changed, 2061 insertions(+), 2 deletions(-) create mode 100644 fantom/Dockerfile create mode 100644 fantom/Makefile create mode 100755 fantom/run create mode 100644 fantom/src/mallib/build.fan create mode 100644 fantom/src/mallib/fan/core.fan create mode 100644 fantom/src/mallib/fan/env.fan create mode 100644 fantom/src/mallib/fan/interop.fan create mode 100644 fantom/src/mallib/fan/reader.fan create mode 100644 fantom/src/mallib/fan/types.fan create mode 100644 fantom/src/step0_repl/build.fan create mode 100644 fantom/src/step0_repl/fan/main.fan create mode 100644 fantom/src/step1_read_print/build.fan create mode 100644 fantom/src/step1_read_print/fan/main.fan create mode 100644 fantom/src/step2_eval/build.fan create mode 100644 fantom/src/step2_eval/fan/main.fan create mode 100644 fantom/src/step3_env/build.fan create mode 100644 fantom/src/step3_env/fan/main.fan create mode 100644 fantom/src/step4_if_fn_do/build.fan create mode 100644 fantom/src/step4_if_fn_do/fan/main.fan create mode 100644 fantom/src/step5_tco/build.fan create mode 100644 fantom/src/step5_tco/fan/main.fan create mode 100644 fantom/src/step6_file/build.fan create mode 100644 fantom/src/step6_file/fan/main.fan create mode 100644 fantom/src/step7_quote/build.fan create mode 100644 fantom/src/step7_quote/fan/main.fan create mode 100644 fantom/src/step8_macros/build.fan create mode 100644 fantom/src/step8_macros/fan/main.fan create mode 100644 fantom/src/step9_try/build.fan create mode 100644 fantom/src/step9_try/fan/main.fan create mode 100644 fantom/src/stepA_mal/build.fan create mode 100644 fantom/src/stepA_mal/fan/main.fan create mode 100644 fantom/tests/step5_tco.mal create mode 100644 fantom/tests/stepA_mal.mal diff --git a/.gitignore b/.gitignore index 5ecac391f2..1b8b6e41f0 100644 --- a/.gitignore +++ b/.gitignore @@ -54,6 +54,7 @@ erlang/src/*.beam es6/mal.js es6/.esm-cache factor/mal.factor +fantom/lib forth/mal.fs fsharp/*.exe fsharp/*.dll diff --git a/Makefile b/Makefile index d88cd89741..0b061af50b 100644 --- a/Makefile +++ b/Makefile @@ -79,7 +79,7 @@ DOCKERIZE = # IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ - elisp elixir elm erlang es6 factor forth fsharp go groovy gst guile haskell \ + elisp elixir elm erlang es6 factor fantom forth fsharp go groovy gst guile haskell \ haxe hy io java js julia kotlin livescript logo lua make mal matlab miniMAL \ nasm nim objc objpascal ocaml perl perl6 php pil plpgsql plsql powershell ps \ python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ @@ -191,6 +191,7 @@ elm_STEP_TO_PROG = elm/$($(1)).js erlang_STEP_TO_PROG = erlang/$($(1)) es6_STEP_TO_PROG = es6/$($(1)).mjs factor_STEP_TO_PROG = factor/$($(1))/$($(1)).factor +fantom_STEP_TO_PROG = fantom/lib/fan/$($(1)).pod forth_STEP_TO_PROG = forth/$($(1)).fs fsharp_STEP_TO_PROG = fsharp/$($(1)).exe go_STEP_TO_PROG = go/$($(1)) diff --git a/README.md b/README.md index cc88deb97d..d35c81042c 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 72 languages: +Mal is implemented in 73 languages: * Ada * GNU awk @@ -29,6 +29,7 @@ Mal is implemented in 72 languages: * ES6 (ECMAScript 6 / ECMAScript 2015) * F# * Factor +* Fantom * Forth * Go * Groovy @@ -419,6 +420,18 @@ cd factor FACTOR_ROOTS=. factor -run=stepX_YYY ``` +### Fantom + +*The Fantom implementation was created by [Dov Murik](https://github.com/dubek)* + +The Fantom implementation of mal has been tested with Fantom 1.0.70. + +``` +cd fantom +make lib/fan/stepX_YYY.pod +STEP=stepX_YYY ./run +``` + ### Forth *The Forth implementation was created by [Chris Houser (chouser)](https://github.com/chouser)* diff --git a/fantom/Dockerfile b/fantom/Dockerfile new file mode 100644 index 0000000000..a52d7e069b --- /dev/null +++ b/fantom/Dockerfile @@ -0,0 +1,37 @@ +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and Unzip +RUN apt-get -y install openjdk-8-jdk unzip + +# Fantom and JLine +RUN cd /tmp && curl -sfLO https://bitbucket.org/fantom/fan-1.0/downloads/fantom-1.0.70.zip \ + && unzip -q fantom-1.0.70.zip \ + && rm fantom-1.0.70.zip \ + && mv fantom-1.0.70 /opt/fantom \ + && cd /opt/fantom \ + && bash adm/unixsetup \ + && curl -sfL -o /opt/fantom/lib/java/jline.jar https://repo1.maven.org/maven2/jline/jline/2.14.6/jline-2.14.6.jar + +ENV PATH /opt/fantom/bin:$PATH +ENV HOME /mal diff --git a/fantom/Makefile b/fantom/Makefile new file mode 100644 index 0000000000..97ebecc100 --- /dev/null +++ b/fantom/Makefile @@ -0,0 +1,31 @@ +SOURCES_BASE = src/mallib/fan/interop.fan src/mallib/fan/reader.fan src/mallib/fan/types.fan +SOURCES_LISP = src/mallib/fan/env.fan src/mallib/fan/core.fan src/stepA_mal/fan/main.fan +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: dist + +dist: lib/fan/mal.pod + +lib/fan: + mkdir -p $@ + +lib/fan/mal.pod: lib/fan/stepA_mal.pod + cp -a $< $@ + +lib/fan/step%.pod: src/step%/build.fan src/step%/fan/*.fan lib/fan/mallib.pod + FAN_ENV=util::PathEnv FAN_ENV_PATH=. fan $< + +lib/fan/mallib.pod: src/mallib/build.fan src/mallib/fan/*.fan lib/fan + FAN_ENV=util::PathEnv FAN_ENV_PATH=. fan $< + +clean: + rm -rf lib + +.PHONY: stats + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/fantom/run b/fantom/run new file mode 100755 index 0000000000..3d75d6e53a --- /dev/null +++ b/fantom/run @@ -0,0 +1,4 @@ +#!/bin/bash +export FAN_ENV=util::PathEnv +export FAN_ENV_PATH="$(dirname $0)" +exec fan ${STEP:-stepA_mal} "$@" diff --git a/fantom/src/mallib/build.fan b/fantom/src/mallib/build.fan new file mode 100644 index 0000000000..275b9daf95 --- /dev/null +++ b/fantom/src/mallib/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "mallib" + summary = "mal library pod" + depends = ["sys 1.0", "compiler 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/mallib/fan/core.fan b/fantom/src/mallib/fan/core.fan new file mode 100644 index 0000000000..4331db4c54 --- /dev/null +++ b/fantom/src/mallib/fan/core.fan @@ -0,0 +1,117 @@ +class Core +{ + static private MalVal prn(MalVal[] a) + { + echo(a.join(" ") { it.toString(true) }) + return MalNil.INSTANCE + } + + static private MalVal println(MalVal[] a) + { + echo(a.join(" ") { it.toString(false) }) + return MalNil.INSTANCE + } + + static private MalVal readline(MalVal[] a) + { + line := Env.cur.prompt((a[0] as MalString).value) + return line == null ? MalNil.INSTANCE : MalString.make(line) + } + + static private MalVal concat(MalVal[] a) + { + return MalList(a.reduce(MalVal[,]) |MalVal[] r, MalSeq v -> MalVal[]| { return r.addAll(v.value) }) + } + + static private MalVal apply(MalVal[] a) + { + f := a[0] as MalFunc + args := a[1..-2] + args.addAll(((MalSeq)a[-1]).value) + return f.call(args) + } + + static private MalVal swap_bang(MalVal[] a) + { + atom := a[0] as MalAtom + MalVal[] args := [atom.value] + args.addAll(a[2..-1]) + f := a[1] as MalFunc + return atom.set(f.call(args)) + } + + static Str:MalFunc ns() + { + return [ + "=": MalFunc { MalTypes.toMalBool(it[0] == it[1]) }, + "throw": MalFunc { throw MalException(it[0]) }, + + "nil?": MalFunc { MalTypes.toMalBool(it[0] is MalNil) }, + "true?": MalFunc { MalTypes.toMalBool(it[0] is MalTrue) }, + "false?": MalFunc { MalTypes.toMalBool(it[0] is MalFalse) }, + "string?": MalFunc { MalTypes.toMalBool(it[0] is MalString && !((MalString)it[0]).isKeyword) }, + "symbol": MalFunc { MalSymbol.makeFromVal(it[0]) }, + "symbol?": MalFunc { MalTypes.toMalBool(it[0] is MalSymbol) }, + "keyword": MalFunc { MalString.makeKeyword((it[0] as MalString).value) }, + "keyword?": MalFunc { MalTypes.toMalBool(it[0] is MalString && ((MalString)it[0]).isKeyword) }, + "number?": MalFunc { MalTypes.toMalBool(it[0] is MalInteger) }, + "fn?": MalFunc { MalTypes.toMalBool(it[0] is MalFunc && !((it[0] as MalUserFunc)?->isMacro ?: false)) }, + "macro?": MalFunc { MalTypes.toMalBool(it[0] is MalUserFunc && ((MalUserFunc)it[0]).isMacro) }, + + "pr-str": MalFunc { MalString.make(it.join(" ") |MalVal e -> Str| { e.toString(true) }) }, + "str": MalFunc { MalString.make(it.join("") |MalVal e -> Str| { e.toString(false) }) }, + "prn": MalFunc(#prn.func), + "println": MalFunc(#println.func), + "read-string": MalFunc { Reader.read_str((it[0] as MalString).value) }, + "readline": MalFunc(#readline.func), + "slurp": MalFunc { MalString.make(File((it[0] as MalString).value.toUri).readAllStr) }, + + "<": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value < (it[1] as MalInteger).value) }, + "<=": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value <= (it[1] as MalInteger).value) }, + ">": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value > (it[1] as MalInteger).value) }, + ">=": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value >= (it[1] as MalInteger).value) }, + "+": MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }, + "-": MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }, + "*": MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }, + "/": MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) }, + "time-ms": MalFunc { MalInteger(DateTime.nowTicks / 1000000) }, + + "list": MalFunc { MalList(it) }, + "list?": MalFunc { MalTypes.toMalBool(it[0] is MalList) }, + "vector": MalFunc { MalVector(it) }, + "vector?": MalFunc { MalTypes.toMalBool(it[0] is MalVector) }, + "hash-map": MalFunc { MalHashMap.fromList(it) }, + "map?": MalFunc { MalTypes.toMalBool(it[0] is MalHashMap) }, + "assoc": MalFunc { (it[0] as MalHashMap).assoc(it[1..-1]) }, + "dissoc": MalFunc { (it[0] as MalHashMap).dissoc(it[1..-1]) }, + "get": MalFunc { it[0] is MalNil ? MalNil.INSTANCE : (it[0] as MalHashMap).get2((MalString)it[1], MalNil.INSTANCE) }, + "contains?": MalFunc { MalTypes.toMalBool((it[0] as MalHashMap).containsKey((MalString)it[1])) }, + "keys": MalFunc { MalList((it[0] as MalHashMap).keys) }, + "vals": MalFunc { MalList((it[0] as MalHashMap).vals) }, + + "sequential?": MalFunc { MalTypes.toMalBool(it[0] is MalSeq) }, + "cons": MalFunc { MalList([it[0]].addAll((it[1] as MalSeq).value)) }, + "concat": MalFunc(#concat.func), + "nth": MalFunc { (it[0] as MalSeq).nth((it[1] as MalInteger).value) }, + "first": MalFunc { (it[0] as MalSeq)?.first ?: MalNil.INSTANCE }, + "rest": MalFunc { (it[0] as MalSeq)?.rest ?: MalList([,]) }, + "empty?": MalFunc { MalTypes.toMalBool((it[0] as MalSeq).isEmpty) }, + "count": MalFunc { MalInteger(it[0].count) }, + "apply": MalFunc(#apply.func), + "map": MalFunc { (it[1] as MalSeq).map(it[0]) }, + + "conj": MalFunc { (it[0] as MalSeq).conj(it[1..-1]) }, + "seq": MalFunc { it[0].seq }, + + "meta": MalFunc { it[0].meta() }, + "with-meta": MalFunc { it[0].with_meta(it[1]) }, + "atom": MalFunc { MalAtom(it[0]) }, + "atom?": MalFunc { MalTypes.toMalBool(it[0] is MalAtom) }, + "deref": MalFunc { (it[0] as MalAtom).value }, + "reset!": MalFunc { (it[0] as MalAtom).set(it[1]) }, + "swap!": MalFunc(#swap_bang.func), + + "fantom-eval": MalFunc { Interop.fantomEvaluate((it[0] as MalString).value) } + ] + } +} diff --git a/fantom/src/mallib/fan/env.fan b/fantom/src/mallib/fan/env.fan new file mode 100644 index 0000000000..644c181470 --- /dev/null +++ b/fantom/src/mallib/fan/env.fan @@ -0,0 +1,40 @@ +class MalEnv +{ + private Str:MalVal data := [:] + private MalEnv? outer + + new make(MalEnv? outer := null, MalSeq? binds := null, MalSeq? exprs := null) + { + this.outer = outer + if (binds != null && exprs != null) + { + for (i := 0; i < binds.count; i++) + { + if ((binds[i] as MalSymbol).value == "&") + { + set(binds[i + 1], MalList(exprs[i..-1])) + break + } + else + set(binds[i], exprs[i]) + } + } + } + + MalVal set(MalSymbol key, MalVal value) + { + data[key.value] = value + return value + } + + MalEnv? find(MalSymbol key) + { + return data.containsKey(key.value) ? this : outer?.find(key) + } + + MalVal get(MalSymbol key) + { + foundEnv := find(key) ?: throw Err("'$key.value' not found") + return (MalVal)foundEnv.data[key.value] + } +} diff --git a/fantom/src/mallib/fan/interop.fan b/fantom/src/mallib/fan/interop.fan new file mode 100644 index 0000000000..71b0d99a0b --- /dev/null +++ b/fantom/src/mallib/fan/interop.fan @@ -0,0 +1,61 @@ +using compiler + +internal class Interop +{ + static Pod? compile(Str innerBody) + { + ci := CompilerInput + { + podName = "mal_fantom_interop_${DateTime.nowUnique}" + summary = "" + isScript = true + version = Version.defVal + log.level = LogLevel.silent + output = CompilerOutputMode.transientPod + mode = CompilerInputMode.str + srcStr = "class InteropDummyClass {\nstatic Obj? _evalfunc() {\n $innerBody \n}\n}" + srcStrLoc = Loc("mal_fantom_interop") + } + try + return Compiler(ci).compile.transientPod + catch (CompilerErr e) + return null + } + + static Obj? evaluate(Str line) + { + p := compile(line) + if (p == null) + p = compile("return $line") + if (p == null) + p = compile("$line\nreturn null") + if (p == null) + return null + method := p.types.first.method("_evalfunc") + try + return method.call() + catch (Err e) + return null + } + + static MalVal fantomToMal(Obj? obj) + { + if (obj == null) + return MalNil.INSTANCE + else if (obj is Bool) + return MalTypes.toMalBool((Bool)obj) + else if (obj is Int) + return MalInteger((Int)obj) + else if (obj is List) + return MalList((obj as List).map { fantomToMal(it) }) + else if (obj is Map) + return MalHashMap.fromMap((obj as Map).map { fantomToMal(it) }) + else + return MalString.make(obj.toStr) + } + + static MalVal fantomEvaluate(Str line) + { + return fantomToMal(evaluate(line)) + } +} diff --git a/fantom/src/mallib/fan/reader.fan b/fantom/src/mallib/fan/reader.fan new file mode 100644 index 0000000000..edf9fe1337 --- /dev/null +++ b/fantom/src/mallib/fan/reader.fan @@ -0,0 +1,104 @@ +internal class TokenReader +{ + const Str[] tokens + private Int position := 0 + + new make(Str[] new_tokens) { tokens = new_tokens } + + Str? peek() + { + if (position >= tokens.size) return null + return tokens[position] + } + + Str next() { return tokens[position++] } +} + +class Reader +{ + private static Str[] tokenize(Str s) + { + r := Regex <|[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)|> + m := r.matcher(s) + tokens := Str[,] + while (m.find()) + { + token := m.group(1) + if (token.isEmpty || token[0] == ';') continue + tokens.add(m.group(1)) + } + return tokens + } + + private static Str unescape_str(Str s) + { + return s.replace("\\\\", "\u029e").replace("\\\"", "\"").replace("\\n", "\n").replace("\u029e", "\\") + } + + private static MalVal read_atom(TokenReader reader) + { + token := reader.next + intRegex := Regex <|^-?\d+$|> + if (token == "nil") return MalNil.INSTANCE + if (token == "true") return MalTrue.INSTANCE + if (token == "false") return MalFalse.INSTANCE + if (intRegex.matches(token)) return MalInteger(token.toInt) + if (token[0] == '"') return MalString.make(unescape_str(token[1..-2])) + if (token[0] == ':') return MalString.makeKeyword(token[1..-1]) + return MalSymbol(token) + } + + private static MalVal[] read_seq(TokenReader reader, Str open, Str close) + { + reader.next + values := MalVal[,] + token := reader.peek + while (token != close) + { + if (token == null) throw Err("expected '$close', got EOF") + values.add(read_form(reader)) + token = reader.peek + } + if (token != close) throw Err("Missing '$close'") + reader.next + return values + } + + private static MalVal read_form(TokenReader reader) + { + switch (reader.peek) + { + case "\'": + reader.next + return MalList([MalSymbol("quote"), read_form(reader)]) + case "`": + reader.next + return MalList([MalSymbol("quasiquote"), read_form(reader)]) + case "~": + reader.next + return MalList([MalSymbol("unquote"), read_form(reader)]) + case "~@": + reader.next + return MalList([MalSymbol("splice-unquote"), read_form(reader)]) + case "^": + reader.next + meta := read_form(reader) + return MalList([MalSymbol("with-meta"), read_form(reader), meta]) + case "@": + reader.next + return MalList([MalSymbol("deref"), read_form(reader)]) + case "(": return MalList(read_seq(reader, "(", ")")) + case ")": throw Err("unexpected ')'") + case "[": return MalVector(read_seq(reader, "[", "]")) + case "]": throw Err("unexpected ']'") + case "{": return MalHashMap.fromList(read_seq(reader, "{", "}")) + case "}": throw Err("unexpected '}'") + default: return read_atom(reader) + } + } + + static MalVal read_str(Str s) + { + return read_form(TokenReader(tokenize(s))); + } +} diff --git a/fantom/src/mallib/fan/types.fan b/fantom/src/mallib/fan/types.fan new file mode 100644 index 0000000000..c30ff124ea --- /dev/null +++ b/fantom/src/mallib/fan/types.fan @@ -0,0 +1,234 @@ +mixin MalVal +{ + virtual Str toString(Bool readable) { return toStr } + virtual Int count() { throw Err("count not implemented") } + virtual MalVal seq() { throw Err("seq not implemented") } + abstract MalVal meta() + abstract MalVal with_meta(MalVal newMeta) +} + +const mixin MalValNoMeta : MalVal +{ + override MalVal meta() { return MalNil.INSTANCE } + override MalVal with_meta(MalVal newMeta) { return this } +} + +const mixin MalFalseyVal +{ +} + +const class MalNil : MalValNoMeta, MalFalseyVal +{ + static const MalNil INSTANCE := MalNil() + override Bool equals(Obj? that) { return that is MalNil } + override Str toString(Bool readable) { return "nil" } + override Int count() { return 0 } + override MalVal seq() { return this } +} + +const class MalTrue : MalValNoMeta +{ + static const MalTrue INSTANCE := MalTrue() + override Bool equals(Obj? that) { return that is MalTrue } + override Str toString(Bool readable) { return "true" } +} + +const class MalFalse : MalValNoMeta, MalFalseyVal +{ + static const MalFalse INSTANCE := MalFalse() + override Bool equals(Obj? that) { return that is MalFalse } + override Str toString(Bool readable) { return "false" } +} + +const class MalInteger : MalValNoMeta +{ + const Int value + new make(Int v) { value = v } + override Bool equals(Obj? that) { return that is MalInteger && (that as MalInteger).value == value } + override Str toString(Bool readable) { return value.toStr } +} + +abstract class MalValBase : MalVal +{ + private MalVal? metaVal := null + override Str toString(Bool readable) { return toStr } + override Int count() { throw Err("count not implemented") } + override MalVal seq() { throw Err("seq not implemented") } + abstract This dup() + override MalVal meta() { return metaVal ?: MalNil.INSTANCE } + override MalVal with_meta(MalVal newMeta) + { + v := dup + v.metaVal = newMeta + return v + } +} + +class MalSymbol : MalValBase +{ + const Str value + new make(Str v) { value = v } + new makeFromVal(MalVal v) + { + if (v is MalSymbol) return v + value = (v as MalString).value + } + override Bool equals(Obj? that) { return that is MalSymbol && (that as MalSymbol).value == value } + override Str toString(Bool readable) { return value } + override This dup() { return make(value) } +} + +class MalString : MalValBase +{ + const Str value + new make(Str v) { value = v } + new makeKeyword(Str v) { value = "\u029e$v" } + override Bool equals(Obj? that) { return that is MalString && (that as MalString).value == value } + override Str toString(Bool readable) + { + if (isKeyword) return ":${value[1..-1]}" + if (readable) + return "\"${escapeStr(value)}\"" + else + return value + } + Bool isKeyword() { return !value.isEmpty && value[0] == '\u029e' } + static Str escapeStr(Str s) + { + return s.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") + } + override MalVal seq() + { + if (value.size == 0) return MalNil.INSTANCE + return MalList(value.chars.map |Int c -> MalString| { MalString.make(Str.fromChars([c])) }) + } + override This dup() { return make(value) } +} + +abstract class MalSeq : MalValBase +{ + MalVal[] value { protected set } + new make(MalVal[] v) { value = v.ro } + override Bool equals(Obj? that) { return that is MalSeq && (that as MalSeq).value == value } + Bool isEmpty() { return value.isEmpty } + override Int count() { return value.size } + @Operator MalVal get(Int index) { return value[index] } + @Operator MalVal[] getRange(Range range) { return value[range] } + protected Str serialize(Bool readable) { return value.join(" ") { it.toString(readable) } } + abstract MalSeq drop(Int n) + MalVal nth(Int index) { return index < count ? get(index) : throw Err("nth: index out of range") } + MalVal first() { return isEmpty ? MalNil.INSTANCE : value[0] } + MalList rest() { return MalList(isEmpty ? [,] : value[1..-1]) } + MalList map(MalFunc f) { return MalList(value.map { f.call([it]) } ) } + abstract MalSeq conj(MalVal[] args) +} + +class MalList : MalSeq +{ + new make(MalVal[] v) : super.make(v) {} + override Str toString(Bool readable) { return "(${serialize(readable)})" } + override MalList drop(Int n) { return make(value[n..-1]) } + override MalVal seq() { return isEmpty ? MalNil.INSTANCE : this } + override MalList conj(MalVal[] args) { return MalList(value.rw.insertAll(0, args.reverse)) } + override This dup() { return make(value) } +} + +class MalVector : MalSeq +{ + new make(MalVal[] v) : super.make(v) {} + override Str toString(Bool readable) { return "[${serialize(readable)}]" } + override MalVector drop(Int n) { return make(value[n..-1]) } + override MalVal seq() { return isEmpty ? MalNil.INSTANCE : MalList(value) } + override MalVector conj(MalVal[] args) { return MalVector(value.rw.addAll(args)) } + override This dup() { return make(value) } +} + +class MalHashMap : MalValBase +{ + Str:MalVal value { private set } + new fromList(MalVal[] lst) { + m := [Str:MalVal][:] + for (i := 0; i < lst.size; i += 2) + m.add((lst[i] as MalString).value, (MalVal)lst[i + 1]) + value = m.ro + } + new fromMap(Str:MalVal m) { value = m.ro } + override Bool equals(Obj? that) { return that is MalHashMap && (that as MalHashMap).value == value } + override Str toString(Bool readable) + { + elements := Str[,] + value.each(|MalVal v, Str k| { elements.add(MalString.make(k).toString(readable)); elements.add(v.toString(readable)) }) + s := elements.join(" ") + return "{$s}" + } + override Int count() { return value.size } + @Operator MalVal get(Str key) { return value[key] } + MalVal get2(MalString key, MalVal? def := null) { return value.get(key.value, def) } + Bool containsKey(MalString key) { return value.containsKey(key.value) } + MalVal[] keys() { return value.keys.map { MalString.make(it) } } + MalVal[] vals() { return value.vals } + MalHashMap assoc(MalVal[] args) + { + newValue := value.dup + for (i := 0; i < args.size; i += 2) + newValue.set((args[i] as MalString).value, args[i + 1]) + return fromMap(newValue) + } + MalHashMap dissoc(MalVal[] args) + { + newValue := value.dup + args.each { newValue.remove((it as MalString).value) } + return fromMap(newValue) + } + override This dup() { return fromMap(value) } +} + +class MalFunc : MalValBase +{ + protected |MalVal[] a -> MalVal| f + new make(|MalVal[] a -> MalVal| func) { f = func } + MalVal call(MalVal[] a) { return f(a) } + override Str toString(Bool readable) { return "" } + override This dup() { return make(f) } +} + +class MalUserFunc : MalFunc +{ + MalVal ast { private set } + private MalEnv env + private MalSeq params + Bool isMacro := false + new make(MalVal ast, MalEnv env, MalSeq params, |MalVal[] a -> MalVal| func, Bool isMacro := false) : super.make(func) + { + this.ast = ast + this.env = env + this.params = params + this.isMacro = isMacro + } + MalEnv genEnv(MalSeq args) { return MalEnv(env, params, args) } + override Str toString(Bool readable) { return "" } + override This dup() { return make(ast, env, params, f, isMacro) } +} + +class MalAtom : MalValBase +{ + MalVal value + new make(MalVal v) { value = v } + override Str toString(Bool readable) { return "(atom ${value.toString(readable)})" } + override Bool equals(Obj? that) { return that is MalAtom && (that as MalAtom).value == value } + MalVal set(MalVal v) { value = v; return value } + override This dup() { return make(value) } +} + +class MalTypes +{ + static MalVal toMalBool(Bool cond) { return cond ? MalTrue.INSTANCE : MalFalse.INSTANCE } + static Bool isPair(MalVal a) { return a is MalSeq && !(a as MalSeq).isEmpty } +} + +const class MalException : Err +{ + const Str serializedValue + new make(MalVal v) : super.make("Mal exception") { serializedValue = v.toString(true) } + MalVal getValue() { return Reader.read_str(serializedValue) } +} diff --git a/fantom/src/step0_repl/build.fan b/fantom/src/step0_repl/build.fan new file mode 100644 index 0000000000..e16a2a3f8c --- /dev/null +++ b/fantom/src/step0_repl/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step0_repl" + summary = "mal step0_repl pod" + depends = ["sys 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step0_repl/fan/main.fan b/fantom/src/step0_repl/fan/main.fan new file mode 100644 index 0000000000..efccdebd02 --- /dev/null +++ b/fantom/src/step0_repl/fan/main.fan @@ -0,0 +1,32 @@ +class Main +{ + static Str READ(Str s) + { + return s + } + + static Str EVAL(Str ast, Str env) + { + return ast + } + + static Str PRINT(Str exp) + { + return exp + } + + static Str REP(Str s, Str env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + echo(REP(line, "")) + } + } +} diff --git a/fantom/src/step1_read_print/build.fan b/fantom/src/step1_read_print/build.fan new file mode 100644 index 0000000000..3bb399898f --- /dev/null +++ b/fantom/src/step1_read_print/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step1_read_print" + summary = "mal step1_read_print pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step1_read_print/fan/main.fan b/fantom/src/step1_read_print/fan/main.fan new file mode 100644 index 0000000000..5e6f27d95a --- /dev/null +++ b/fantom/src/step1_read_print/fan/main.fan @@ -0,0 +1,37 @@ +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal EVAL(MalVal ast, Str env) + { + return ast + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, Str env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, "")) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step2_eval/build.fan b/fantom/src/step2_eval/build.fan new file mode 100644 index 0000000000..792a7f722e --- /dev/null +++ b/fantom/src/step2_eval/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step2_eval" + summary = "mal step2_eval pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step2_eval/fan/main.fan b/fantom/src/step2_eval/fan/main.fan new file mode 100644 index 0000000000..0ea7bb6d20 --- /dev/null +++ b/fantom/src/step2_eval/fan/main.fan @@ -0,0 +1,70 @@ +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, Str:MalFunc env) + { + switch (ast.typeof) + { + case MalSymbol#: + varName := (ast as MalSymbol).value + varVal := env[varName] ?: throw Err("'$varName' not found") + return (MalVal)varVal + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, Str:MalFunc env) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + evaled_ast := eval_ast(ast, env) as MalList + f := evaled_ast[0] as MalFunc + return f.call(evaled_ast[1..-1]) + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, Str:MalFunc env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + env := [ + "+": MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }, + "-": MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }, + "*": MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }, + "/": MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) } + ] + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step3_env/build.fan b/fantom/src/step3_env/build.fan new file mode 100644 index 0000000000..598092fb24 --- /dev/null +++ b/fantom/src/step3_env/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step3_env" + summary = "mal step3_env pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step3_env/fan/main.fan b/fantom/src/step3_env/fan/main.fan new file mode 100644 index 0000000000..4f8294b4df --- /dev/null +++ b/fantom/src/step3_env/fan/main.fan @@ -0,0 +1,79 @@ +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol).value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := (astList[1] as MalSeq) + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + return EVAL(astList[2], let_env) + default: + evaled_ast := eval_ast(ast, env) as MalList + f := evaled_ast[0] as MalFunc + return f.call(evaled_ast[1..-1]) + } + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + repl_env := MalEnv() + repl_env.set(MalSymbol("+"), MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }) + repl_env.set(MalSymbol("-"), MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }) + repl_env.set(MalSymbol("*"), MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }) + repl_env.set(MalSymbol("/"), MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) }) + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step4_if_fn_do/build.fan b/fantom/src/step4_if_fn_do/build.fan new file mode 100644 index 0000000000..7cf25b342b --- /dev/null +++ b/fantom/src/step4_if_fn_do/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step4_if_fn_do" + summary = "mal step4_if_fn_do pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step4_if_fn_do/fan/main.fan b/fantom/src/step4_if_fn_do/fan/main.fan new file mode 100644 index 0000000000..22d6ea4f02 --- /dev/null +++ b/fantom/src/step4_if_fn_do/fan/main.fan @@ -0,0 +1,91 @@ +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + return EVAL(astList[2], let_env) + case "do": + eval_ast(MalList(astList[1..-2]), env) + return EVAL(astList[-1], env) + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + return astList.count > 3 ? EVAL(astList[3], env) : MalNil.INSTANCE + else + return EVAL(astList[2], env) + case "fn*": + return MalFunc { EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(it))) } + default: + evaled_ast := eval_ast(ast, env) as MalList + f := evaled_ast[0] as MalFunc + return f.call(evaled_ast[1..-1]) + } + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step5_tco/build.fan b/fantom/src/step5_tco/build.fan new file mode 100644 index 0000000000..d96402c8ba --- /dev/null +++ b/fantom/src/step5_tco/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step5_tco" + summary = "mal step5_tco pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step5_tco/fan/main.fan b/fantom/src/step5_tco/fan/main.fan new file mode 100644 index 0000000000..eeab71a07d --- /dev/null +++ b/fantom/src/step5_tco/fan/main.fan @@ -0,0 +1,113 @@ +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step6_file/build.fan b/fantom/src/step6_file/build.fan new file mode 100644 index 0000000000..93e255f5f1 --- /dev/null +++ b/fantom/src/step6_file/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step6_file" + summary = "mal step6_file pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step6_file/fan/main.fan b/fantom/src/step6_file/fan/main.fan new file mode 100644 index 0000000000..aad03665d5 --- /dev/null +++ b/fantom/src/step6_file/fan/main.fan @@ -0,0 +1,122 @@ +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step7_quote/build.fan b/fantom/src/step7_quote/build.fan new file mode 100644 index 0000000000..a32dfca1f9 --- /dev/null +++ b/fantom/src/step7_quote/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step7_quote" + summary = "mal step7_quote pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step7_quote/fan/main.fan b/fantom/src/step7_quote/fan/main.fan new file mode 100644 index 0000000000..7158f03383 --- /dev/null +++ b/fantom/src/step7_quote/fan/main.fan @@ -0,0 +1,143 @@ +using mallib + +class Main +{ + static MalVal quasiquote(MalVal ast) + { + if (!MalTypes.isPair(ast)) + return MalList(MalVal[MalSymbol("quote"), ast]) + astSeq := ast as MalSeq + if ((astSeq[0] as MalSymbol)?.value == "unquote") + return astSeq[1] + if (MalTypes.isPair(astSeq[0])) + { + ast0Seq := astSeq[0] as MalSeq + if ((ast0Seq[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), ast0Seq[1], quasiquote(astSeq.drop(1))]) + } + return MalList(MalVal[MalSymbol("cons"), quasiquote(astSeq[0]), quasiquote(astSeq.drop(1))]) + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step8_macros/build.fan b/fantom/src/step8_macros/build.fan new file mode 100644 index 0000000000..d6333c9854 --- /dev/null +++ b/fantom/src/step8_macros/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step8_macros" + summary = "mal step8_macros pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step8_macros/fan/main.fan b/fantom/src/step8_macros/fan/main.fan new file mode 100644 index 0000000000..243295c47f --- /dev/null +++ b/fantom/src/step8_macros/fan/main.fan @@ -0,0 +1,174 @@ +using mallib + +class Main +{ + static MalVal quasiquote(MalVal ast) + { + if (!MalTypes.isPair(ast)) + return MalList(MalVal[MalSymbol("quote"), ast]) + astSeq := ast as MalSeq + if ((astSeq[0] as MalSymbol)?.value == "unquote") + return astSeq[1] + if (MalTypes.isPair(astSeq[0])) + { + ast0Seq := astSeq[0] as MalSeq + if ((ast0Seq[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), ast0Seq[1], quasiquote(astSeq.drop(1))]) + } + return MalList(MalVal[MalSymbol("cons"), quasiquote(astSeq[0]), quasiquote(astSeq.drop(1))]) + } + + static Bool isMacroCall(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return false + astList := ast as MalList + if (astList.isEmpty) return false + if (!(astList[0] is MalSymbol)) return false + ast0 := astList[0] as MalSymbol + f := env.find(ast0)?.get(ast0) + return (f as MalUserFunc)?.isMacro ?: false + } + + static MalVal macroexpand(MalVal ast, MalEnv env) + { + while (isMacroCall(ast, env)) + { + mac := env.get((ast as MalList)[0]) as MalUserFunc + ast = mac.call((ast as MalSeq).drop(1).value) + } + return ast + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "defmacro!": + f := EVAL(astList[2], env) as MalUserFunc + f.isMacro = true + return env.set(astList[1], f) + case "macroexpand": + return macroexpand(astList[1], env) + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env) + REP("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env) + REP("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/step9_try/build.fan b/fantom/src/step9_try/build.fan new file mode 100644 index 0000000000..8d3b048052 --- /dev/null +++ b/fantom/src/step9_try/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "step9_try" + summary = "mal step9_try pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/step9_try/fan/main.fan b/fantom/src/step9_try/fan/main.fan new file mode 100644 index 0000000000..1cede16369 --- /dev/null +++ b/fantom/src/step9_try/fan/main.fan @@ -0,0 +1,186 @@ +using mallib + +class Main +{ + static MalVal quasiquote(MalVal ast) + { + if (!MalTypes.isPair(ast)) + return MalList(MalVal[MalSymbol("quote"), ast]) + astSeq := ast as MalSeq + if ((astSeq[0] as MalSymbol)?.value == "unquote") + return astSeq[1] + if (MalTypes.isPair(astSeq[0])) + { + ast0Seq := astSeq[0] as MalSeq + if ((ast0Seq[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), ast0Seq[1], quasiquote(astSeq.drop(1))]) + } + return MalList(MalVal[MalSymbol("cons"), quasiquote(astSeq[0]), quasiquote(astSeq.drop(1))]) + } + + static Bool isMacroCall(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return false + astList := ast as MalList + if (astList.isEmpty) return false + if (!(astList[0] is MalSymbol)) return false + ast0 := astList[0] as MalSymbol + f := env.find(ast0)?.get(ast0) + return (f as MalUserFunc)?.isMacro ?: false + } + + static MalVal macroexpand(MalVal ast, MalEnv env) + { + while (isMacroCall(ast, env)) + { + mac := env.get((ast as MalList)[0]) as MalUserFunc + ast = mac.call((ast as MalSeq).drop(1).value) + } + return ast + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "defmacro!": + f := EVAL(astList[2], env) as MalUserFunc + f.isMacro = true + return env.set(astList[1], f) + case "macroexpand": + return macroexpand(astList[1], env) + case "try*": + MalVal exc := MalNil.INSTANCE + try + return EVAL(astList[1], env) + catch (MalException e) + exc = e.getValue + catch (Err e) + exc = MalString.make(e.msg) + catchClause := astList[2] as MalList + return EVAL(catchClause[2], MalEnv(env, MalList([catchClause[1]]), MalList([exc]))) + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env) + REP("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env) + REP("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (MalException e) + echo("Error: ${e.serializedValue}") + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/src/stepA_mal/build.fan b/fantom/src/stepA_mal/build.fan new file mode 100644 index 0000000000..a4c40d7f57 --- /dev/null +++ b/fantom/src/stepA_mal/build.fan @@ -0,0 +1,11 @@ +class Build : build::BuildPod +{ + new make() + { + podName = "stepA_mal" + summary = "mal stepA_mal pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/fantom/src/stepA_mal/fan/main.fan b/fantom/src/stepA_mal/fan/main.fan new file mode 100644 index 0000000000..c42b659657 --- /dev/null +++ b/fantom/src/stepA_mal/fan/main.fan @@ -0,0 +1,190 @@ +using mallib + +class Main +{ + static MalVal quasiquote(MalVal ast) + { + if (!MalTypes.isPair(ast)) + return MalList(MalVal[MalSymbol("quote"), ast]) + astSeq := ast as MalSeq + if ((astSeq[0] as MalSymbol)?.value == "unquote") + return astSeq[1] + if (MalTypes.isPair(astSeq[0])) + { + ast0Seq := astSeq[0] as MalSeq + if ((ast0Seq[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), ast0Seq[1], quasiquote(astSeq.drop(1))]) + } + return MalList(MalVal[MalSymbol("cons"), quasiquote(astSeq[0]), quasiquote(astSeq.drop(1))]) + } + + static Bool isMacroCall(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return false + astList := ast as MalList + if (astList.isEmpty) return false + if (!(astList[0] is MalSymbol)) return false + ast0 := astList[0] as MalSymbol + f := env.find(ast0)?.get(ast0) + return (f as MalUserFunc)?.isMacro ?: false + } + + static MalVal macroexpand(MalVal ast, MalEnv env) + { + while (isMacroCall(ast, env)) + { + mac := env.get((ast as MalList)[0]) as MalUserFunc + ast = mac.call((ast as MalSeq).drop(1).value) + } + return ast + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map { EVAL(it, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map { EVAL(it, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { return EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "defmacro!": + f := EVAL(astList[2], env) as MalUserFunc + f.isMacro = true + return env.set(astList[1], f) + case "macroexpand": + return macroexpand(astList[1], env) + case "try*": + MalVal exc := MalNil.INSTANCE + try + return EVAL(astList[1], env) + catch (MalException e) + exc = e.getValue + catch (Err e) + exc = MalString.make(e.msg) + catchClause := astList[2] as MalList + return EVAL(catchClause[2], MalEnv(env, MalList([catchClause[1]]), MalList([exc]))) + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! *host-language* \"fantom\")", repl_env) + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env) + REP("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env) + REP("(def! *gensym-counter* (atom 0))", repl_env) + REP("(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))", repl_env) + REP("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (MalException e) + echo("Error: ${e.serializedValue}") + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/fantom/tests/step5_tco.mal b/fantom/tests/step5_tco.mal new file mode 100644 index 0000000000..d20df25db7 --- /dev/null +++ b/fantom/tests/step5_tco.mal @@ -0,0 +1,15 @@ +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/fantom/tests/stepA_mal.mal b/fantom/tests/stepA_mal.mal new file mode 100644 index 0000000000..a8c37d819d --- /dev/null +++ b/fantom/tests/stepA_mal.mal @@ -0,0 +1,32 @@ +;; Testing basic fantom interop + +(fantom-eval "7") +;=>7 + +(fantom-eval "return 3 * 9") +;=>27 + +(fantom-eval "\"7\"") +;=>"7" + +(fantom-eval "\"abcd\".upper") +;=>"ABCD" + +(fantom-eval "[7,8,9]") +;=>(7 8 9) + +(fantom-eval "[\"abc\": 789]") +;=>{"abc" 789} + +(fantom-eval "echo(\"hello\")") +; hello +;=>nil + +(fantom-eval "[\"a\",\"b\",\"c\"].join(\" \") { \"X${it}Y\" }") +;=>"XaY XbY XcY" + +(fantom-eval "[1,2,3].map { 1 + it }") +;=>(2 3 4) + +(fantom-eval "Env.cur.runtime") +;=>"java" From 80beb411e073f236e3d31c104b21ed98bf1dbcae Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Sun, 3 Jun 2018 20:14:27 +0000 Subject: [PATCH 0356/1998] travis: Add fantom to build CI matrix --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 76a1a3cf27..d6d3e49787 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,6 +27,7 @@ matrix: - {env: IMPL=erlang NO_PERF=1, services: [docker]} # perf runs out of memory - {env: IMPL=es6, services: [docker]} - {env: IMPL=factor, services: [docker]} + - {env: IMPL=fantom, services: [docker]} - {env: IMPL=forth, services: [docker]} - {env: IMPL=fsharp, services: [docker]} - {env: IMPL=go, services: [docker]} From 8ea36c892f7fcd3a08a3f8a1bf16494a1801cd52 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Sun, 17 Jun 2018 19:54:54 +0200 Subject: [PATCH 0357/1998] Rename gst and pil to gnu-smalltalk and picolisp --- Makefile | 14 +++++++------- {gst => gnu-smalltalk}/Dockerfile | 0 {gst => gnu-smalltalk}/Makefile | 0 {gst => gnu-smalltalk}/core.st | 0 {gst => gnu-smalltalk}/env.st | 0 {gst => gnu-smalltalk}/func.st | 0 {gst => gnu-smalltalk}/printer.st | 0 {gst => gnu-smalltalk}/reader.st | 0 {gst => gnu-smalltalk}/readline.st | 0 {gst => gnu-smalltalk}/run | 0 {gst => gnu-smalltalk}/step0_repl.st | 0 {gst => gnu-smalltalk}/step1_read_print.st | 0 {gst => gnu-smalltalk}/step2_eval.st | 0 {gst => gnu-smalltalk}/step3_env.st | 0 {gst => gnu-smalltalk}/step4_if_fn_do.st | 0 {gst => gnu-smalltalk}/step5_tco.st | 0 {gst => gnu-smalltalk}/step6_file.st | 0 {gst => gnu-smalltalk}/step7_quote.st | 0 {gst => gnu-smalltalk}/step8_macros.st | 0 {gst => gnu-smalltalk}/step9_try.st | 0 {gst => gnu-smalltalk}/stepA_mal.st | 0 {gst => gnu-smalltalk}/tests/stepA_mal.mal | 0 {gst => gnu-smalltalk}/types.st | 0 {gst => gnu-smalltalk}/util.st | 0 {pil => picolisp}/Dockerfile | 0 {pil => picolisp}/Makefile | 0 {pil => picolisp}/core.l | 0 {pil => picolisp}/env.l | 0 {pil => picolisp}/func.l | 0 {pil => picolisp}/printer.l | 0 {pil => picolisp}/reader.l | 0 {pil => picolisp}/readline.l | 0 {pil => picolisp}/run | 0 {pil => picolisp}/step0_repl.l | 0 {pil => picolisp}/step1_read_print.l | 0 {pil => picolisp}/step2_eval.l | 0 {pil => picolisp}/step3_env.l | 0 {pil => picolisp}/step4_if_fn_do.l | 0 {pil => picolisp}/step5_tco.l | 0 {pil => picolisp}/step6_file.l | 0 {pil => picolisp}/step7_quote.l | 0 {pil => picolisp}/step8_macros.l | 0 {pil => picolisp}/step9_try.l | 0 {pil => picolisp}/stepA_mal.l | 0 {pil => picolisp}/tests/step5_tco.mal | 0 {pil => picolisp}/tests/stepA_mal.mal | 0 {pil => picolisp}/types.l | 0 47 files changed, 7 insertions(+), 7 deletions(-) rename {gst => gnu-smalltalk}/Dockerfile (100%) rename {gst => gnu-smalltalk}/Makefile (100%) rename {gst => gnu-smalltalk}/core.st (100%) rename {gst => gnu-smalltalk}/env.st (100%) rename {gst => gnu-smalltalk}/func.st (100%) rename {gst => gnu-smalltalk}/printer.st (100%) rename {gst => gnu-smalltalk}/reader.st (100%) rename {gst => gnu-smalltalk}/readline.st (100%) rename {gst => gnu-smalltalk}/run (100%) rename {gst => gnu-smalltalk}/step0_repl.st (100%) rename {gst => gnu-smalltalk}/step1_read_print.st (100%) rename {gst => gnu-smalltalk}/step2_eval.st (100%) rename {gst => gnu-smalltalk}/step3_env.st (100%) rename {gst => gnu-smalltalk}/step4_if_fn_do.st (100%) rename {gst => gnu-smalltalk}/step5_tco.st (100%) rename {gst => gnu-smalltalk}/step6_file.st (100%) rename {gst => gnu-smalltalk}/step7_quote.st (100%) rename {gst => gnu-smalltalk}/step8_macros.st (100%) rename {gst => gnu-smalltalk}/step9_try.st (100%) rename {gst => gnu-smalltalk}/stepA_mal.st (100%) rename {gst => gnu-smalltalk}/tests/stepA_mal.mal (100%) rename {gst => gnu-smalltalk}/types.st (100%) rename {gst => gnu-smalltalk}/util.st (100%) rename {pil => picolisp}/Dockerfile (100%) rename {pil => picolisp}/Makefile (100%) rename {pil => picolisp}/core.l (100%) rename {pil => picolisp}/env.l (100%) rename {pil => picolisp}/func.l (100%) rename {pil => picolisp}/printer.l (100%) rename {pil => picolisp}/reader.l (100%) rename {pil => picolisp}/readline.l (100%) rename {pil => picolisp}/run (100%) rename {pil => picolisp}/step0_repl.l (100%) rename {pil => picolisp}/step1_read_print.l (100%) rename {pil => picolisp}/step2_eval.l (100%) rename {pil => picolisp}/step3_env.l (100%) rename {pil => picolisp}/step4_if_fn_do.l (100%) rename {pil => picolisp}/step5_tco.l (100%) rename {pil => picolisp}/step6_file.l (100%) rename {pil => picolisp}/step7_quote.l (100%) rename {pil => picolisp}/step8_macros.l (100%) rename {pil => picolisp}/step9_try.l (100%) rename {pil => picolisp}/stepA_mal.l (100%) rename {pil => picolisp}/tests/step5_tco.mal (100%) rename {pil => picolisp}/tests/stepA_mal.mal (100%) rename {pil => picolisp}/types.l (100%) diff --git a/Makefile b/Makefile index 0b061af50b..6c09413982 100644 --- a/Makefile +++ b/Makefile @@ -79,11 +79,11 @@ DOCKERIZE = # IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ - elisp elixir elm erlang es6 factor fantom forth fsharp go groovy gst guile haskell \ - haxe hy io java js julia kotlin livescript logo lua make mal matlab miniMAL \ - nasm nim objc objpascal ocaml perl perl6 php pil plpgsql plsql powershell ps \ - python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \ - ts vb vhdl vimscript yorick + elisp elixir elm erlang es6 factor fantom forth fsharp go groovy gnu-smalltalk \ + guile haskell haxe hy io java js julia kotlin livescript logo lua make mal \ + matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp plpgsql \ + plsql powershell ps python r racket rexx rpython ruby rust scala scheme skew \ + swift swift3 tcl ts vb vhdl vimscript yorick EXTENSION = .mal @@ -196,7 +196,7 @@ forth_STEP_TO_PROG = forth/$($(1)).fs fsharp_STEP_TO_PROG = fsharp/$($(1)).exe go_STEP_TO_PROG = go/$($(1)) groovy_STEP_TO_PROG = groovy/$($(1)).groovy -gst_STEP_TO_PROG = gst/$($(1)).st +gnu-smalltalk_STEP_TO_PROG = gnu-smalltalk/$($(1)).st guile_STEP_TO_PROG = guile/$($(1)).scm haskell_STEP_TO_PROG = haskell/$($(1)) haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(haxe_MODE)) @@ -221,7 +221,7 @@ ocaml_STEP_TO_PROG = ocaml/$($(1)) perl_STEP_TO_PROG = perl/$($(1)).pl perl6_STEP_TO_PROG = perl6/$($(1)).pl php_STEP_TO_PROG = php/$($(1)).php -pil_STEP_TO_PROG = pil/$($(1)).l +picolisp_STEP_TO_PROG = picolisp/$($(1)).l plpgsql_STEP_TO_PROG = plpgsql/$($(1)).sql plsql_STEP_TO_PROG = plsql/$($(1)).sql powershell_STEP_TO_PROG = powershell/$($(1)).ps1 diff --git a/gst/Dockerfile b/gnu-smalltalk/Dockerfile similarity index 100% rename from gst/Dockerfile rename to gnu-smalltalk/Dockerfile diff --git a/gst/Makefile b/gnu-smalltalk/Makefile similarity index 100% rename from gst/Makefile rename to gnu-smalltalk/Makefile diff --git a/gst/core.st b/gnu-smalltalk/core.st similarity index 100% rename from gst/core.st rename to gnu-smalltalk/core.st diff --git a/gst/env.st b/gnu-smalltalk/env.st similarity index 100% rename from gst/env.st rename to gnu-smalltalk/env.st diff --git a/gst/func.st b/gnu-smalltalk/func.st similarity index 100% rename from gst/func.st rename to gnu-smalltalk/func.st diff --git a/gst/printer.st b/gnu-smalltalk/printer.st similarity index 100% rename from gst/printer.st rename to gnu-smalltalk/printer.st diff --git a/gst/reader.st b/gnu-smalltalk/reader.st similarity index 100% rename from gst/reader.st rename to gnu-smalltalk/reader.st diff --git a/gst/readline.st b/gnu-smalltalk/readline.st similarity index 100% rename from gst/readline.st rename to gnu-smalltalk/readline.st diff --git a/gst/run b/gnu-smalltalk/run similarity index 100% rename from gst/run rename to gnu-smalltalk/run diff --git a/gst/step0_repl.st b/gnu-smalltalk/step0_repl.st similarity index 100% rename from gst/step0_repl.st rename to gnu-smalltalk/step0_repl.st diff --git a/gst/step1_read_print.st b/gnu-smalltalk/step1_read_print.st similarity index 100% rename from gst/step1_read_print.st rename to gnu-smalltalk/step1_read_print.st diff --git a/gst/step2_eval.st b/gnu-smalltalk/step2_eval.st similarity index 100% rename from gst/step2_eval.st rename to gnu-smalltalk/step2_eval.st diff --git a/gst/step3_env.st b/gnu-smalltalk/step3_env.st similarity index 100% rename from gst/step3_env.st rename to gnu-smalltalk/step3_env.st diff --git a/gst/step4_if_fn_do.st b/gnu-smalltalk/step4_if_fn_do.st similarity index 100% rename from gst/step4_if_fn_do.st rename to gnu-smalltalk/step4_if_fn_do.st diff --git a/gst/step5_tco.st b/gnu-smalltalk/step5_tco.st similarity index 100% rename from gst/step5_tco.st rename to gnu-smalltalk/step5_tco.st diff --git a/gst/step6_file.st b/gnu-smalltalk/step6_file.st similarity index 100% rename from gst/step6_file.st rename to gnu-smalltalk/step6_file.st diff --git a/gst/step7_quote.st b/gnu-smalltalk/step7_quote.st similarity index 100% rename from gst/step7_quote.st rename to gnu-smalltalk/step7_quote.st diff --git a/gst/step8_macros.st b/gnu-smalltalk/step8_macros.st similarity index 100% rename from gst/step8_macros.st rename to gnu-smalltalk/step8_macros.st diff --git a/gst/step9_try.st b/gnu-smalltalk/step9_try.st similarity index 100% rename from gst/step9_try.st rename to gnu-smalltalk/step9_try.st diff --git a/gst/stepA_mal.st b/gnu-smalltalk/stepA_mal.st similarity index 100% rename from gst/stepA_mal.st rename to gnu-smalltalk/stepA_mal.st diff --git a/gst/tests/stepA_mal.mal b/gnu-smalltalk/tests/stepA_mal.mal similarity index 100% rename from gst/tests/stepA_mal.mal rename to gnu-smalltalk/tests/stepA_mal.mal diff --git a/gst/types.st b/gnu-smalltalk/types.st similarity index 100% rename from gst/types.st rename to gnu-smalltalk/types.st diff --git a/gst/util.st b/gnu-smalltalk/util.st similarity index 100% rename from gst/util.st rename to gnu-smalltalk/util.st diff --git a/pil/Dockerfile b/picolisp/Dockerfile similarity index 100% rename from pil/Dockerfile rename to picolisp/Dockerfile diff --git a/pil/Makefile b/picolisp/Makefile similarity index 100% rename from pil/Makefile rename to picolisp/Makefile diff --git a/pil/core.l b/picolisp/core.l similarity index 100% rename from pil/core.l rename to picolisp/core.l diff --git a/pil/env.l b/picolisp/env.l similarity index 100% rename from pil/env.l rename to picolisp/env.l diff --git a/pil/func.l b/picolisp/func.l similarity index 100% rename from pil/func.l rename to picolisp/func.l diff --git a/pil/printer.l b/picolisp/printer.l similarity index 100% rename from pil/printer.l rename to picolisp/printer.l diff --git a/pil/reader.l b/picolisp/reader.l similarity index 100% rename from pil/reader.l rename to picolisp/reader.l diff --git a/pil/readline.l b/picolisp/readline.l similarity index 100% rename from pil/readline.l rename to picolisp/readline.l diff --git a/pil/run b/picolisp/run similarity index 100% rename from pil/run rename to picolisp/run diff --git a/pil/step0_repl.l b/picolisp/step0_repl.l similarity index 100% rename from pil/step0_repl.l rename to picolisp/step0_repl.l diff --git a/pil/step1_read_print.l b/picolisp/step1_read_print.l similarity index 100% rename from pil/step1_read_print.l rename to picolisp/step1_read_print.l diff --git a/pil/step2_eval.l b/picolisp/step2_eval.l similarity index 100% rename from pil/step2_eval.l rename to picolisp/step2_eval.l diff --git a/pil/step3_env.l b/picolisp/step3_env.l similarity index 100% rename from pil/step3_env.l rename to picolisp/step3_env.l diff --git a/pil/step4_if_fn_do.l b/picolisp/step4_if_fn_do.l similarity index 100% rename from pil/step4_if_fn_do.l rename to picolisp/step4_if_fn_do.l diff --git a/pil/step5_tco.l b/picolisp/step5_tco.l similarity index 100% rename from pil/step5_tco.l rename to picolisp/step5_tco.l diff --git a/pil/step6_file.l b/picolisp/step6_file.l similarity index 100% rename from pil/step6_file.l rename to picolisp/step6_file.l diff --git a/pil/step7_quote.l b/picolisp/step7_quote.l similarity index 100% rename from pil/step7_quote.l rename to picolisp/step7_quote.l diff --git a/pil/step8_macros.l b/picolisp/step8_macros.l similarity index 100% rename from pil/step8_macros.l rename to picolisp/step8_macros.l diff --git a/pil/step9_try.l b/picolisp/step9_try.l similarity index 100% rename from pil/step9_try.l rename to picolisp/step9_try.l diff --git a/pil/stepA_mal.l b/picolisp/stepA_mal.l similarity index 100% rename from pil/stepA_mal.l rename to picolisp/stepA_mal.l diff --git a/pil/tests/step5_tco.mal b/picolisp/tests/step5_tco.mal similarity index 100% rename from pil/tests/step5_tco.mal rename to picolisp/tests/step5_tco.mal diff --git a/pil/tests/stepA_mal.mal b/picolisp/tests/stepA_mal.mal similarity index 100% rename from pil/tests/stepA_mal.mal rename to picolisp/tests/stepA_mal.mal diff --git a/pil/types.l b/picolisp/types.l similarity index 100% rename from pil/types.l rename to picolisp/types.l From b440380f64e3dd52042161f409d9c078f69836bf Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 22 Jun 2018 18:20:38 +0200 Subject: [PATCH 0358/1998] Rename gst and pil directories in README --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index d35c81042c..1361df846b 100644 --- a/README.md +++ b/README.md @@ -480,7 +480,7 @@ guile -L ./ stepX_YYY.scm The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. ``` -cd gst +cd gnu-smalltalk ./run ``` @@ -761,7 +761,7 @@ The Picolisp implementation requires libreadline and Picolisp 3.1.11 or later. ``` -cd pil +cd picolisp ./run ``` From 808c940d861e412771580d58b7ff2b1be9a38f05 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Fri, 22 Jun 2018 18:24:47 +0200 Subject: [PATCH 0359/1998] Use correct implementation names in build matrix --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index d6d3e49787..0079c27890 100644 --- a/.travis.yml +++ b/.travis.yml @@ -32,7 +32,7 @@ matrix: - {env: IMPL=fsharp, services: [docker]} - {env: IMPL=go, services: [docker]} - {env: IMPL=groovy, services: [docker]} - - {env: IMPL=gst, services: [docker]} + - {env: IMPL=gnu-smalltalk, services: [docker]} - {env: IMPL=guile, services: [docker]} - {env: IMPL=haskell, services: [docker]} - {env: IMPL=haxe haxe_MODE=neko, services: [docker]} @@ -61,7 +61,7 @@ matrix: - {env: IMPL=perl, services: [docker]} - {env: IMPL=perl6, services: [docker]} - {env: IMPL=php, services: [docker]} - - {env: IMPL=pil, services: [docker]} + - {env: IMPL=picolisp, services: [docker]} - {env: IMPL=plpgsql, services: [docker]} # - {env: IMPL=plsql, services: [docker]} - {env: IMPL=ps, services: [docker]} From d7f720e653dc7d26419be6e4b1c5611e2ee27a0c Mon Sep 17 00:00:00 2001 From: James Vaughan Date: Sat, 23 Jun 2018 16:08:15 -0700 Subject: [PATCH 0360/1998] Fix typo in Common Lisp section --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 1361df846b..3c366e5642 100644 --- a/README.md +++ b/README.md @@ -259,7 +259,7 @@ cd chuck The implementation has been tested with SBCL, CCL, CMUCL, GNU CLISP, ECL and Allegro CL on Ubuntu 16.04 and Ubuntu 12.04, see -the [README][common-lisp/README.org] for more details. Provided you have the +the [README](common-lisp/README.org) for more details. Provided you have the dependencies mentioned installed, do the following to run the implementation ``` From 9106f92cbcff54f4c46058bbd340fe593d5c95f1 Mon Sep 17 00:00:00 2001 From: Chris McCormick Date: Sun, 24 Jun 2018 19:45:29 +0800 Subject: [PATCH 0361/1998] PHP: refactor web running mechanism. --- .gitignore | 1 + php/Makefile | 5 ++++- php/README.md | 20 ++++++++++++-------- php/stepA_mal.php | 8 +------- php/webrunner.php | 8 ++++++++ 5 files changed, 26 insertions(+), 16 deletions(-) create mode 100644 php/webrunner.php diff --git a/.gitignore b/.gitignore index c7d90d9a16..3a0dafcc60 100644 --- a/.gitignore +++ b/.gitignore @@ -90,6 +90,7 @@ objpascal/regexpr/Source/RegExpr.ppu perl/mal.pl perl6/.precomp/ php/mal.php +php/mal-web.php ps/mal.ps python/mal.pyz r/mal.r diff --git a/php/Makefile b/php/Makefile index 981b6fa7e7..fbf83b0a3b 100644 --- a/php/Makefile +++ b/php/Makefile @@ -17,8 +17,11 @@ mal: mal.php cat $< >> $@ chmod +x $@ +mal-web.php: mal.php + cat $< | ( IFS="NON-MATCHING-IFS"; while read -r line; do if [ "$$line" = "// run mal file" ]; then echo "?>"; cat webrunner.php; echo " $@ + clean: - rm -f mal.php mal + rm -f mal.php mal mal-web.php .PHONY: stats tests $(TESTS) diff --git a/php/README.md b/php/README.md index 1333636620..53f9849d29 100644 --- a/php/README.md +++ b/php/README.md @@ -1,16 +1,20 @@ ### Running .mal scripts on PHP hosting ### -Create a symlink to `mal.php` with the same name as your `.mal` script and your script will be executed as if it was PHP. +Create a symlink to `mal-web.php` with the same name as your `.mal` script and your script will be executed as if it was PHP. -Here's an example using local dev: +Here's an example using local dev. - cd php - make mal.php - echo '(prn "Hello world!")' > myscript.mal - ln -s mal.php myscript.php - php -S 0.0.0.0:8000 +First build `mal-web.php`: -Then browse to http://localhost:8000/myscript.php and you should see "Hello world!" in your browser as `myscript.mal` is run. + cd mal/php + make mal-web.php + +Now you can create a web runnable mal script: + + echo '(println "Hello world!")' > myscript.mal + ln -s mal-web.php myscript.php + +Start a development server with `php -S 0.0.0.0:8000` and then browse to http://localhost:8000/myscript.php and you should see "Hello world!" in your browser as `myscript.mal` is run. You can do the same thing on live PHP web hosting by copying `mal.php` up and creating a symlink for each `.mal` file you want to be web-executable. diff --git a/php/stepA_mal.php b/php/stepA_mal.php index 2ac4c301a3..3518b7fed9 100644 --- a/php/stepA_mal.php +++ b/php/stepA_mal.php @@ -225,13 +225,7 @@ function rep($str) { rep("(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"); rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"); -// if we're called in a webserver context, auto-resolve to mal file -if (php_sapi_name() != "cli") { - $malfile = str_replace(".php", ".mal", $_SERVER['SCRIPT_FILENAME']); - rep('(load-file "' . $malfile . '")'); - exit(0); -} - +// run mal file if (count($argv) > 1) { rep('(load-file "' . $argv[1] . '")'); exit(0); diff --git a/php/webrunner.php b/php/webrunner.php new file mode 100644 index 0000000000..ce720a7f20 --- /dev/null +++ b/php/webrunner.php @@ -0,0 +1,8 @@ + From ba218d6f0a342fa909919f53d8a9485b419ec961 Mon Sep 17 00:00:00 2001 From: Chris McCormick Date: Sun, 24 Jun 2018 16:31:40 +0800 Subject: [PATCH 0362/1998] Updated PHP native interop interface. --- php/README.md | 8 ++++---- php/interop.php | 16 ++++++++++++++++ php/reader.php | 6 +++++- php/stepA_mal.php | 24 ++---------------------- php/tests/stepA_mal.mal | 11 ++++++++--- 5 files changed, 35 insertions(+), 30 deletions(-) diff --git a/php/README.md b/php/README.md index 53f9849d29..24500da82e 100644 --- a/php/README.md +++ b/php/README.md @@ -32,11 +32,11 @@ Eval PHP code: Native function call: - (! date "Y-m-d" 0) - 1970-01-01 + (php/date "Y-m-d" 0) + "1970-01-01" Accessing PHP "superglobal" variables: - (get ($ "_SERVER") "PHP_SELF") - ./mal + (get php/_SERVER "PHP_SELF") + "./mal" diff --git a/php/interop.php b/php/interop.php index e83c0ef3a5..eca03ad134 100644 --- a/php/interop.php +++ b/php/interop.php @@ -45,4 +45,20 @@ function _to_mal($obj) { } } +function _to_native($name, $env) { + if (is_callable($name)) { + return _function(function() use ($name) { + $args = array_map("_to_php", func_get_args()); + $res = call_user_func_array($name, $args); + return _to_mal($res); + }); + } else if (in_array($name, ["_SERVER", "_GET", "_POST", "_FILES", "_REQUEST", "_SESSION", "_ENV", "_COOKIE"])) { + $val = $GLOBALS[$name]; + } else if (defined($name)) { + $val = constant($name); + } else { + $val = ${$name}; + } + return _to_mal($val); +} ?> diff --git a/php/reader.php b/php/reader.php index 54ed8b11c2..3408b1ae1f 100644 --- a/php/reader.php +++ b/php/reader.php @@ -27,7 +27,7 @@ function _real_token($s) { } function tokenize($str) { - $pat = "/[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\s\[\]{}('\"`,;)]*)/"; + $pat = "/[\s,]*(php\/|~@|[\[\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\s\[\]{}('\"`,;)]*)/"; preg_match_all($pat, $str, $matches); return array_values(array_filter($matches[1], '_real_token')); } @@ -102,6 +102,10 @@ function read_form($reader) { return _list(_symbol('deref'), read_form($reader)); + case 'php/': $reader->next(); + return _list(_symbol('to-native'), + read_form($reader)); + case ')': throw new Exception("unexpected ')'"); case '(': return read_list($reader); case ']': throw new Exception("unexpected ']'"); diff --git a/php/stepA_mal.php b/php/stepA_mal.php index 3cec087791..115732b6ca 100644 --- a/php/stepA_mal.php +++ b/php/stepA_mal.php @@ -72,7 +72,6 @@ function eval_ast($ast, $env) { } function MAL_EVAL($ast, $env) { - $_SUPERGLOBALS = ["_SERVER", "_GET", "_POST", "_FILES", "_REQUEST", "_SESSION", "_ENV", "_COOKIE"]; while (true) { #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; @@ -152,27 +151,8 @@ function MAL_EVAL($ast, $env) { case "fn*": return _function('MAL_EVAL', 'native', $ast[2], $env, $ast[1]); - case "$": - $var = MAL_EVAL($ast[1], $env); - if (_symbol_Q($var)) { - $varname = $var->value; - } elseif (gettype($var) === "string") { - $varname = $var; - } else { - throw new Exception("$ arg unknown type: " . gettype($var)); - } - if (in_array($varname, $_SUPERGLOBALS)) { - $val = $GLOBALS[$varname]; - } else { - $val = ${$varname}; - } - return _to_mal($val); - case "!": - $fn = $ast[1]->value; - $el = eval_ast($ast->slice(2), $env); - $args = _to_php($el); - $res = call_user_func_array($fn, $args); - return _to_mal($res); + case "to-native": + return _to_native($ast[1]->value, $env); default: $el = eval_ast($ast, $env); $f = $el[0]; diff --git a/php/tests/stepA_mal.mal b/php/tests/stepA_mal.mal index f86faeef3b..80d9a0bdec 100644 --- a/php/tests/stepA_mal.mal +++ b/php/tests/stepA_mal.mal @@ -26,15 +26,20 @@ ;; testing native function calling -(! date "Y-m-d" 0) +(php/date "Y-m-d" 0) ;=>"1970-01-01" ;; testing native function with mal callback -(! array_map (fn* [t] (if (> t 3) t)) [1 2 3 4 5 6]) +(php/array_map (fn* [t] (if (> t 3) t)) [1 2 3 4 5 6]) ;=>(nil nil nil 4 5 6) ;; testing superglobal variable access -(get ($ "_SERVER") "PHP_SELF") +(get php/_SERVER "PHP_SELF") ;=>"../php/stepA_mal.php" + +;; testing PHP constants access + +php/FILE_APPEND +;=>8 From b0687d365bdb9a497b622bbd12f6229527adb991 Mon Sep 17 00:00:00 2001 From: Chris McCormick Date: Tue, 26 Jun 2018 15:27:45 +0800 Subject: [PATCH 0363/1998] Added README section for projects using mal. --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 3c366e5642..150ad85edc 100644 --- a/README.md +++ b/README.md @@ -1217,6 +1217,10 @@ make "docker-build^IMPL" out. These dependencies are download to dot-files in the /mal directory so they will persist between runs. +## Projects using mal + + * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. + * [frock](https://github.com/chr15m/frock) - Clojure-flavoured PHP. Uses mal/php to run programs. ## License From 07bd1c1ff1a17ae959ddac1c6a34d8598f50151c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jordi=20=C3=8D=C3=B1igo?= Date: Fri, 6 Jul 2018 13:01:57 +0200 Subject: [PATCH 0364/1998] Go: Fix panic on call to function with wrong number of arguments --- go/src/core/core.go | 91 +++++++++++++++++++++++++++++++++ go/src/step2_eval/step2_eval.go | 19 +++++++ go/src/step3_env/step3_env.go | 19 +++++++ go/tests/step2_eval.mal | 34 ++++++++++++ go/tests/step3_env.mal | 34 ++++++++++++ go/tests/step4_if_fn_do.mal | 34 ++++++++++++ go/tests/step5_tco.mal | 35 +++++++++++++ go/tests/step6_file.mal | 34 ++++++++++++ go/tests/step7_quote.mal | 34 ++++++++++++ go/tests/step8_macros.mal | 34 ++++++++++++ go/tests/step9_try.mal | 34 ++++++++++++ go/tests/stepA_mal.mal | 34 ++++++++++++ 12 files changed, 436 insertions(+) create mode 100644 go/tests/step2_eval.mal create mode 100644 go/tests/step3_env.mal create mode 100644 go/tests/step4_if_fn_do.mal create mode 100644 go/tests/step6_file.mal create mode 100644 go/tests/step7_quote.mal create mode 100644 go/tests/step8_macros.mal create mode 100644 go/tests/step9_try.mal create mode 100644 go/tests/stepA_mal.mal diff --git a/go/src/core/core.go b/go/src/core/core.go index abbaae8986..615f0c46c1 100644 --- a/go/src/core/core.go +++ b/go/src/core/core.go @@ -446,28 +446,52 @@ func swap_BANG(a []MalType) (MalType, error) { // core namespace var NS = map[string]MalType{ "=": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return Equal_Q(a[0], a[1]), nil }, "throw": throw, "nil?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Nil_Q(a[0]), nil }, "true?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return True_Q(a[0]), nil }, "false?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return False_Q(a[0]), nil }, "symbol": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Symbol{a[0].(string)}, nil }, "symbol?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Symbol_Q(a[0]), nil }, "string?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return (String_Q(a[0]) && !Keyword_Q(a[0])), nil }, "keyword": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } if Keyword_Q(a[0]) { return a[0], nil } else { @@ -475,13 +499,22 @@ var NS = map[string]MalType{ } }, "keyword?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Keyword_Q(a[0]), nil }, "number?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Number_Q(a[0]), nil }, "fn?": fn_q, "macro?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return MalFunc_Q(a[0]) && a[0].(MalFunc).GetMacro(), nil }, @@ -490,35 +523,65 @@ var NS = map[string]MalType{ "prn": func(a []MalType) (MalType, error) { return prn(a) }, "println": func(a []MalType) (MalType, error) { return println(a) }, "read-string": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return reader.Read_str(a[0].(string)) }, "slurp": slurp, "readline": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return readline.Readline(a[0].(string)) }, "<": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) < a[1].(int), nil }, "<=": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) <= a[1].(int), nil }, ">": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) > a[1].(int), nil }, ">=": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) >= a[1].(int), nil }, "+": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) + a[1].(int), nil }, "-": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) - a[1].(int), nil }, "*": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) * a[1].(int), nil }, "/": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) / a[1].(int), nil }, "time-ms": time_ms, @@ -527,30 +590,45 @@ var NS = map[string]MalType{ return List{a, nil}, nil }, "list?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return List_Q(a[0]), nil }, "vector": func(a []MalType) (MalType, error) { return Vector{a, nil}, nil }, "vector?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Vector_Q(a[0]), nil }, "hash-map": func(a []MalType) (MalType, error) { return NewHashMap(List{a, nil}) }, "map?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return HashMap_Q(a[0]), nil }, "assoc": assoc, "dissoc": dissoc, "get": get, "contains?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return contains_Q(a[0], a[1]) }, "keys": keys, "vals": vals, "sequential?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Sequential_Q(a[0]), nil }, "cons": cons, @@ -568,12 +646,25 @@ var NS = map[string]MalType{ "with-meta": with_meta, "meta": meta, "atom": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return &Atom{a[0], nil}, nil }, "atom?": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 1); e != nil { + return nil, e + } return Atom_Q(a[0]), nil }, "deref": deref, "reset!": reset_BANG, "swap!": swap_BANG, } + +func assertArgNum(a []MalType, n int) error { + if len(a) != n { + return errors.New("wrong number of arguments") + } + return nil +} diff --git a/go/src/step2_eval/step2_eval.go b/go/src/step2_eval/step2_eval.go index 9517695613..6eb67b7616 100644 --- a/go/src/step2_eval/step2_eval.go +++ b/go/src/step2_eval/step2_eval.go @@ -102,19 +102,38 @@ func PRINT(exp MalType) (string, error) { var repl_env = map[string]MalType{ "+": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) + a[1].(int), nil }, "-": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) - a[1].(int), nil }, "*": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) * a[1].(int), nil }, "/": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) / a[1].(int), nil }, } +func assertArgNum(a []MalType, n int) error { + if len(a) != n { + return errors.New("wrong number of arguments") + } + return nil +} + // repl func rep(str string) (MalType, error) { var exp MalType diff --git a/go/src/step3_env/step3_env.go b/go/src/step3_env/step3_env.go index 2c0575c7ce..3b2e99a169 100644 --- a/go/src/step3_env/step3_env.go +++ b/go/src/step3_env/step3_env.go @@ -164,15 +164,27 @@ func rep(str string) (MalType, error) { func main() { repl_env.Set(Symbol{"+"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) + a[1].(int), nil }) repl_env.Set(Symbol{"-"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) - a[1].(int), nil }) repl_env.Set(Symbol{"*"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) * a[1].(int), nil }) repl_env.Set(Symbol{"/"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } return a[0].(int) / a[1].(int), nil }) @@ -195,3 +207,10 @@ func main() { fmt.Printf("%v\n", out) } } + +func assertArgNum(a []MalType, n int) error { + if len(a) != n { + return errors.New("wrong number of arguments") + } + return nil +} diff --git a/go/tests/step2_eval.mal b/go/tests/step2_eval.mal new file mode 100644 index 0000000000..4b3a4bf27d --- /dev/null +++ b/go/tests/step2_eval.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(- 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(- 1 2) +;=>-1 + + +;; Testing evaluation of missing arguments +(- 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(-) +;=>Error: wrong number of arguments + diff --git a/go/tests/step3_env.mal b/go/tests/step3_env.mal new file mode 100644 index 0000000000..4b3a4bf27d --- /dev/null +++ b/go/tests/step3_env.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(- 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(- 1 2) +;=>-1 + + +;; Testing evaluation of missing arguments +(- 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(-) +;=>Error: wrong number of arguments + diff --git a/go/tests/step4_if_fn_do.mal b/go/tests/step4_if_fn_do.mal new file mode 100644 index 0000000000..bc9ea985d2 --- /dev/null +++ b/go/tests/step4_if_fn_do.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + diff --git a/go/tests/step5_tco.mal b/go/tests/step5_tco.mal index 6fa1da6fdf..f589099870 100644 --- a/go/tests/step5_tco.mal +++ b/go/tests/step5_tco.mal @@ -1,2 +1,37 @@ ;; Go: skipping non-TCO recursion ;; Reason: completes even at 100,000 + +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + diff --git a/go/tests/step6_file.mal b/go/tests/step6_file.mal new file mode 100644 index 0000000000..bc9ea985d2 --- /dev/null +++ b/go/tests/step6_file.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + diff --git a/go/tests/step7_quote.mal b/go/tests/step7_quote.mal new file mode 100644 index 0000000000..bc9ea985d2 --- /dev/null +++ b/go/tests/step7_quote.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + diff --git a/go/tests/step8_macros.mal b/go/tests/step8_macros.mal new file mode 100644 index 0000000000..bc9ea985d2 --- /dev/null +++ b/go/tests/step8_macros.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + diff --git a/go/tests/step9_try.mal b/go/tests/step9_try.mal new file mode 100644 index 0000000000..bc9ea985d2 --- /dev/null +++ b/go/tests/step9_try.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + diff --git a/go/tests/stepA_mal.mal b/go/tests/stepA_mal.mal new file mode 100644 index 0000000000..bc9ea985d2 --- /dev/null +++ b/go/tests/stepA_mal.mal @@ -0,0 +1,34 @@ +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments + From 9bc61630d2c592b2e16c47001ecb8673def42f57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jordi=20=C3=8D=C3=B1igo?= Date: Sat, 7 Jul 2018 22:04:52 +0200 Subject: [PATCH 0365/1998] Go: removed some redundant tests --- go/tests/step3_env.mal | 34 ---------------------------------- go/tests/step5_tco.mal | 37 ------------------------------------- go/tests/step6_file.mal | 34 ---------------------------------- go/tests/step7_quote.mal | 34 ---------------------------------- go/tests/step8_macros.mal | 34 ---------------------------------- go/tests/step9_try.mal | 34 ---------------------------------- go/tests/stepA_mal.mal | 34 ---------------------------------- 7 files changed, 241 deletions(-) delete mode 100644 go/tests/step3_env.mal delete mode 100644 go/tests/step5_tco.mal delete mode 100644 go/tests/step6_file.mal delete mode 100644 go/tests/step7_quote.mal delete mode 100644 go/tests/step8_macros.mal delete mode 100644 go/tests/step9_try.mal delete mode 100644 go/tests/stepA_mal.mal diff --git a/go/tests/step3_env.mal b/go/tests/step3_env.mal deleted file mode 100644 index 4b3a4bf27d..0000000000 --- a/go/tests/step3_env.mal +++ /dev/null @@ -1,34 +0,0 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(- 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(- 1 2) -;=>-1 - - -;; Testing evaluation of missing arguments -(- 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(-) -;=>Error: wrong number of arguments - diff --git a/go/tests/step5_tco.mal b/go/tests/step5_tco.mal deleted file mode 100644 index f589099870..0000000000 --- a/go/tests/step5_tco.mal +++ /dev/null @@ -1,37 +0,0 @@ -;; Go: skipping non-TCO recursion -;; Reason: completes even at 100,000 - -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments - diff --git a/go/tests/step6_file.mal b/go/tests/step6_file.mal deleted file mode 100644 index bc9ea985d2..0000000000 --- a/go/tests/step6_file.mal +++ /dev/null @@ -1,34 +0,0 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments - diff --git a/go/tests/step7_quote.mal b/go/tests/step7_quote.mal deleted file mode 100644 index bc9ea985d2..0000000000 --- a/go/tests/step7_quote.mal +++ /dev/null @@ -1,34 +0,0 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments - diff --git a/go/tests/step8_macros.mal b/go/tests/step8_macros.mal deleted file mode 100644 index bc9ea985d2..0000000000 --- a/go/tests/step8_macros.mal +++ /dev/null @@ -1,34 +0,0 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments - diff --git a/go/tests/step9_try.mal b/go/tests/step9_try.mal deleted file mode 100644 index bc9ea985d2..0000000000 --- a/go/tests/step9_try.mal +++ /dev/null @@ -1,34 +0,0 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments - diff --git a/go/tests/stepA_mal.mal b/go/tests/stepA_mal.mal deleted file mode 100644 index bc9ea985d2..0000000000 --- a/go/tests/stepA_mal.mal +++ /dev/null @@ -1,34 +0,0 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments - From ed1819f423cb590683ea1a2c461fc2ec5c493f67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jordi=20=C3=8D=C3=B1igo?= Date: Sun, 8 Jul 2018 01:23:00 +0200 Subject: [PATCH 0366/1998] Go: added argument count checks to functions --- go/src/core/core.go | 343 +++++++++++++++----------------------------- 1 file changed, 114 insertions(+), 229 deletions(-) diff --git a/go/src/core/core.go b/go/src/core/core.go index 615f0c46c1..975f0447a2 100644 --- a/go/src/core/core.go +++ b/go/src/core/core.go @@ -115,9 +115,6 @@ func dissoc(a []MalType) (MalType, error) { } func get(a []MalType) (MalType, error) { - if len(a) != 2 { - return nil, errors.New("get requires 2 arguments") - } if Nil_Q(a[0]) { return nil, nil } @@ -154,6 +151,7 @@ func keys(a []MalType) (MalType, error) { } return List{slc, nil}, nil } + func vals(a []MalType) (MalType, error) { if !HashMap_Q(a[0]) { return nil, errors.New("keys called on non-hash map") @@ -173,7 +171,6 @@ func cons(a []MalType) (MalType, error) { if e != nil { return nil, e } - return List{append([]MalType{val}, lst...), nil}, nil } @@ -285,9 +282,6 @@ func apply(a []MalType) (MalType, error) { } func do_map(a []MalType) (MalType, error) { - if len(a) != 2 { - return nil, errors.New("map requires 2 args") - } f := a[0] results := []MalType{} args, e := GetSlice(a[1]) @@ -367,9 +361,6 @@ func seq(a []MalType) (MalType, error) { // Metadata functions func with_meta(a []MalType) (MalType, error) { - if len(a) != 2 { - return nil, errors.New("with-meta requires 2 args") - } obj := a[0] m := a[1] switch tobj := obj.(type) { @@ -428,9 +419,6 @@ func swap_BANG(a []MalType) (MalType, error) { if !Atom_Q(a[0]) { return nil, errors.New("swap! called with non-atom") } - if len(a) < 2 { - return nil, errors.New("swap! requires at least 2 args") - } atm := a[0].(*Atom) args := []MalType{atm.Val} f := a[1] @@ -445,226 +433,123 @@ func swap_BANG(a []MalType) (MalType, error) { // core namespace var NS = map[string]MalType{ - "=": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return Equal_Q(a[0], a[1]), nil - }, - "throw": throw, - "nil?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Nil_Q(a[0]), nil - }, - "true?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return True_Q(a[0]), nil - }, - "false?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return False_Q(a[0]), nil - }, - "symbol": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Symbol{a[0].(string)}, nil - }, - "symbol?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Symbol_Q(a[0]), nil - }, - "string?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return (String_Q(a[0]) && !Keyword_Q(a[0])), nil - }, - "keyword": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } + "=": call2b(Equal_Q), + "throw": call1e(throw), + "nil?": call1b(Nil_Q), + "true?": call1b(True_Q), + "false?": call1b(False_Q), + "symbol": call1e(func(a []MalType) (MalType, error) { return Symbol{a[0].(string)}, nil }), + "symbol?": call1b(Symbol_Q), + "string?": call1e(func(a []MalType) (MalType, error) { return (String_Q(a[0]) && !Keyword_Q(a[0])), nil }), + "keyword": call1e(func(a []MalType) (MalType, error) { if Keyword_Q(a[0]) { return a[0], nil } else { return NewKeyword(a[0].(string)) } - }, - "keyword?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Keyword_Q(a[0]), nil - }, - "number?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Number_Q(a[0]), nil - }, - "fn?": fn_q, - "macro?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return MalFunc_Q(a[0]) && a[0].(MalFunc).GetMacro(), nil - }, - - "pr-str": func(a []MalType) (MalType, error) { return pr_str(a) }, - "str": func(a []MalType) (MalType, error) { return str(a) }, - "prn": func(a []MalType) (MalType, error) { return prn(a) }, - "println": func(a []MalType) (MalType, error) { return println(a) }, - "read-string": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return reader.Read_str(a[0].(string)) - }, - "slurp": slurp, - "readline": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return readline.Readline(a[0].(string)) - }, - - "<": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) < a[1].(int), nil - }, - "<=": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) <= a[1].(int), nil - }, - ">": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) > a[1].(int), nil - }, - ">=": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) >= a[1].(int), nil - }, - "+": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) + a[1].(int), nil - }, - "-": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) - a[1].(int), nil - }, - "*": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) * a[1].(int), nil - }, - "/": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) / a[1].(int), nil - }, - "time-ms": time_ms, - - "list": func(a []MalType) (MalType, error) { - return List{a, nil}, nil - }, - "list?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return List_Q(a[0]), nil - }, - "vector": func(a []MalType) (MalType, error) { - return Vector{a, nil}, nil - }, - "vector?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Vector_Q(a[0]), nil - }, - "hash-map": func(a []MalType) (MalType, error) { - return NewHashMap(List{a, nil}) - }, - "map?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return HashMap_Q(a[0]), nil - }, - "assoc": assoc, - "dissoc": dissoc, - "get": get, - "contains?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return contains_Q(a[0], a[1]) - }, - "keys": keys, - "vals": vals, - - "sequential?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Sequential_Q(a[0]), nil - }, - "cons": cons, - "concat": concat, - "nth": nth, - "first": first, - "rest": rest, - "empty?": empty_Q, - "count": count, - "apply": apply, - "map": do_map, - "conj": conj, - "seq": seq, - - "with-meta": with_meta, - "meta": meta, - "atom": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return &Atom{a[0], nil}, nil - }, - "atom?": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 1); e != nil { - return nil, e - } - return Atom_Q(a[0]), nil - }, - "deref": deref, - "reset!": reset_BANG, - "swap!": swap_BANG, -} - -func assertArgNum(a []MalType, n int) error { - if len(a) != n { - return errors.New("wrong number of arguments") + }), + "keyword?": call1b(Keyword_Q), + "number?": call1b(Number_Q), + "fn?": call1e(fn_q), + "macro?": call1e(func(a []MalType) (MalType, error) { return MalFunc_Q(a[0]) && a[0].(MalFunc).GetMacro(), nil }), + "pr-str": callNe(pr_str), + "str": callNe(str), + "prn": callNe(prn), + "println": callNe(println), + "read-string": call1e(func(a []MalType) (MalType, error) { return reader.Read_str(a[0].(string)) }), + "slurp": call1e(slurp), + "readline": call1e(func(a []MalType) (MalType, error) { return readline.Readline(a[0].(string)) }), + "<": call2e(func(a []MalType) (MalType, error) { return a[0].(int) < a[1].(int), nil }), + "<=": call2e(func(a []MalType) (MalType, error) { return a[0].(int) <= a[1].(int), nil }), + ">": call2e(func(a []MalType) (MalType, error) { return a[0].(int) > a[1].(int), nil }), + ">=": call2e(func(a []MalType) (MalType, error) { return a[0].(int) >= a[1].(int), nil }), + "+": call2e(func(a []MalType) (MalType, error) { return a[0].(int) + a[1].(int), nil }), + "-": call2e(func(a []MalType) (MalType, error) { return a[0].(int) - a[1].(int), nil }), + "*": call2e(func(a []MalType) (MalType, error) { return a[0].(int) * a[1].(int), nil }), + "/": call2e(func(a []MalType) (MalType, error) { return a[0].(int) / a[1].(int), nil }), + "time-ms": call0e(time_ms), + "list": callNe(func(a []MalType) (MalType, error) { return List{a, nil}, nil }), + "list?": call1b(List_Q), + "vector": callNe(func(a []MalType) (MalType, error) { return Vector{a, nil}, nil }), + "vector?": call1b(Vector_Q), + "hash-map": callNe(func(a []MalType) (MalType, error) { return NewHashMap(List{a, nil}) }), + "map?": call1b(HashMap_Q), + "assoc": callNe(assoc), // at least 3 + "dissoc": callNe(dissoc), // at least 2 + "get": call2e(get), + "contains?": call2e(func(a []MalType) (MalType, error) { return contains_Q(a[0], a[1]) }), + "keys": call1e(keys), + "vals": call1e(vals), + "sequential?": call1b(Sequential_Q), + "cons": call2e(cons), + "concat": callNe(concat), + "nth": call2e(nth), + "first": call1e(first), + "rest": call1e(rest), + "empty?": call1e(empty_Q), + "count": call1e(count), + "apply": callNe(apply), // at least 2 + "map": call2e(do_map), + "conj": callNe(conj), // at least 2 + "seq": call1e(seq), + "with-meta": call2e(with_meta), + "meta": call1e(meta), + "atom": call1e(func(a []MalType) (MalType, error) { return &Atom{a[0], nil}, nil }), + "atom?": call1b(Atom_Q), + "deref": call1e(deref), + "reset!": call2e(reset_BANG), + "swap!": callNe(swap_BANG), +} + +// callXX functions check the number of arguments +func call0e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 0 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 0)", len(args)) + } + return f(args) + } +} + +func call1e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 1 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 1)", len(args)) + } + return f(args) + } +} + +func call2e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 2 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 2)", len(args)) + } + return f(args) + } +} + +func callNe(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + // just for documenting purposes, does not check anything + return func(args []MalType) (MalType, error) { + return f(args) + } +} + +func call1b(f func(MalType) bool) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 1 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 1)", len(args)) + } + return f(args[0]), nil + } +} + +func call2b(f func(MalType, MalType) bool) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 2 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 2)", len(args)) + } + return f(args[0], args[1]), nil } - return nil } From 3932a29be3219bc24d5358b8bee1177b522ada84 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jordi=20=C3=8D=C3=B1igo?= Date: Sun, 8 Jul 2018 01:44:28 +0200 Subject: [PATCH 0367/1998] Go: modified error messages --- go/tests/step4_if_fn_do.mal | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/go/tests/step4_if_fn_do.mal b/go/tests/step4_if_fn_do.mal index bc9ea985d2..2134ce66f8 100644 --- a/go/tests/step4_if_fn_do.mal +++ b/go/tests/step4_if_fn_do.mal @@ -1,6 +1,6 @@ ;; Testing evaluation of excessive arguments (+ 1 2 3) -;=>Error: wrong number of arguments +;=>Error: wrong number of arguments (3 instead of 2) ;; Valid call (+ 1 2) @@ -9,15 +9,15 @@ ;; Testing evaluation of missing arguments (+ 1) -;=>Error: wrong number of arguments +;=>Error: wrong number of arguments (1 instead of 2) ;; Testing evaluation of missing arguments (+) -;=>Error: wrong number of arguments +;=>Error: wrong number of arguments (0 instead of 2) ;; Testing evaluation of excessive arguments (= 1 2 3) -;=>Error: wrong number of arguments +;=>Error: wrong number of arguments (3 instead of 2) ;; Valid call (= 1 2) @@ -26,9 +26,9 @@ ;; Testing evaluation of missing arguments (= 1) -;=>Error: wrong number of arguments +;=>Error: wrong number of arguments (1 instead of 2) ;; Testing evaluation of missing arguments (=) -;=>Error: wrong number of arguments +;=>Error: wrong number of arguments (0 instead of 2) From a536db2105c2e29cc2ee4d1133a937128171de1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jordi=20=C3=8D=C3=B1igo?= Date: Sun, 8 Jul 2018 11:20:46 +0200 Subject: [PATCH 0368/1998] Go: added file back accidentally removed --- go/tests/step5_tco.mal | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 go/tests/step5_tco.mal diff --git a/go/tests/step5_tco.mal b/go/tests/step5_tco.mal new file mode 100644 index 0000000000..093d5872fe --- /dev/null +++ b/go/tests/step5_tco.mal @@ -0,0 +1,2 @@ +;; Go: skipping non-TCO recursion +;; Reason: completes even at 100,000 From 1e8fc91409d2b138634693b3cd3a8da7a4308b93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jordi=20=C3=8D=C3=B1igo?= Date: Sun, 8 Jul 2018 11:22:49 +0200 Subject: [PATCH 0369/1998] Go: Minor --- go/tests/step5_tco.mal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/go/tests/step5_tco.mal b/go/tests/step5_tco.mal index 093d5872fe..6fa1da6fdf 100644 --- a/go/tests/step5_tco.mal +++ b/go/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Go: skipping non-TCO recursion +;; Go: skipping non-TCO recursion ;; Reason: completes even at 100,000 From e2352e739b5174bea7e427f8f018614ee62036e5 Mon Sep 17 00:00:00 2001 From: Tim Morgan Date: Sun, 8 Jul 2018 22:21:01 -0500 Subject: [PATCH 0370/1998] Test that (not nil) returns true --- tests/step4_if_fn_do.mal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal index 6e503f9748..1117818d4b 100644 --- a/tests/step4_if_fn_do.mal +++ b/tests/step4_if_fn_do.mal @@ -243,6 +243,8 @@ a ;; Testing language defined not function (not false) ;=>true +(not nil) +;=>true (not true) ;=>false (not "a") From 634ca5e98b0e9fac232159a0a23a15e13b7a7906 Mon Sep 17 00:00:00 2001 From: Chris McCormick Date: Thu, 12 Jul 2018 20:21:03 +0800 Subject: [PATCH 0371/1998] PHP: Wrap some native "language constructs". Common ones which can't be called otherwise. Can now be reached via php/exit, php/print, php/require. Fixes chr15m/frock#7 --- php/interop.php | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/php/interop.php b/php/interop.php index eca03ad134..bb14d880ed 100644 --- a/php/interop.php +++ b/php/interop.php @@ -52,6 +52,22 @@ function _to_native($name, $env) { $res = call_user_func_array($name, $args); return _to_mal($res); }); + // special case for language constructs + } else if ($name == "print") { + return _function(function($value) { + print(_to_php($value)); + return null; + }); + } else if ($name == "exit") { + return _function(function($value) { + exit(_to_php($value)); + return null; + }); + } else if ($name == "require") { + return _function(function($value) { + require(_to_php($value)); + return null; + }); } else if (in_array($name, ["_SERVER", "_GET", "_POST", "_FILES", "_REQUEST", "_SESSION", "_ENV", "_COOKIE"])) { $val = $GLOBALS[$name]; } else if (defined($name)) { From 63462732fa1121a017c6f657c746b5e2dec90cc3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 12 Jul 2018 09:27:21 -0500 Subject: [PATCH 0372/1998] java: fix by updating to xenial, java 8, maven 3 The vivid build with java 7 and maven 2 was no longer able to retrieve upstream deps and was failing. --- java/Dockerfile | 6 +++--- java/pom.xml | 1 + java/run | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/java/Dockerfile b/java/Dockerfile index 0dc69c55d5..7c9fdd4aea 100644 --- a/java/Dockerfile +++ b/java/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:xenial MAINTAINER Joel Martin ########################################################## @@ -22,7 +22,7 @@ WORKDIR /mal ########################################################## # Java and maven -RUN apt-get -y install openjdk-7-jdk -RUN apt-get -y install maven2 +RUN apt-get -y install openjdk-8-jdk +RUN apt-get -y install maven ENV MAVEN_OPTS -Duser.home=/mal diff --git a/java/pom.xml b/java/pom.xml index 5ee5b7c73b..63621f87b5 100644 --- a/java/pom.xml +++ b/java/pom.xml @@ -29,6 +29,7 @@ maven-compiler-plugin + 3.0 1.7 1.7 diff --git a/java/run b/java/run index 8252305dac..7119297e78 100755 --- a/java/run +++ b/java/run @@ -6,4 +6,4 @@ if [ "$#" -gt 0 ]; then args="$args '$a'" done fi -exec mvn -quiet exec:java -Dexec.mainClass="mal.${STEP:-stepA_mal}" "$args" +exec mvn -quiet -e exec:java -Dexec.mainClass="mal.${STEP:-stepA_mal}" ${args:+"$args"} From 6e59c4f26d213399f68aeafed2ed2566daa469d8 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 12 Jul 2018 13:51:02 -0500 Subject: [PATCH 0373/1998] scala: fix w/ xenial, sbt 0.14.6, update build. Build had become out of date so update docker image to xenial and sbt to 0.14.6 and update Scala build files to go with new sbt version. --- scala/Dockerfile | 4 ++-- scala/assembly.sbt | 6 ++---- scala/build.sbt | 1 - scala/project/assembly.sbt | 2 +- 4 files changed, 5 insertions(+), 8 deletions(-) diff --git a/scala/Dockerfile b/scala/Dockerfile index 989c32e17d..1aa29b5dde 100644 --- a/scala/Dockerfile +++ b/scala/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:xenial MAINTAINER Joel Martin ########################################################## @@ -22,7 +22,7 @@ WORKDIR /mal ########################################################## # Java and maven -RUN apt-get -y install openjdk-7-jdk +RUN apt-get -y install openjdk-8-jdk #RUN apt-get -y install maven2 #ENV MAVEN_OPTS -Duser.home=/mal diff --git a/scala/assembly.sbt b/scala/assembly.sbt index 89a285dc1f..0b3ef91c19 100644 --- a/scala/assembly.sbt +++ b/scala/assembly.sbt @@ -1,8 +1,6 @@ -import AssemblyKeys._ // put this at the top of the file - -assemblySettings +import sbtassembly.AssemblyPlugin.defaultShellScript test in assembly := {} -jarName in assembly := "mal.jar" +assemblyJarName in assembly := "mal.jar" mainClass in assembly := Some("stepA_mal") assemblyOption in assembly ~= { _.copy(prependShellScript = Some(defaultShellScript)) } diff --git a/scala/build.sbt b/scala/build.sbt index 8c7430bd07..c5bfda397c 100644 --- a/scala/build.sbt +++ b/scala/build.sbt @@ -1,5 +1,4 @@ lazy val root = (project in file(".")). - settings(assemblySettings: _*). settings( name := "mal", version := "0.1", diff --git a/scala/project/assembly.sbt b/scala/project/assembly.sbt index 54c32528e9..652a3b93be 100644 --- a/scala/project/assembly.sbt +++ b/scala/project/assembly.sbt @@ -1 +1 @@ -addSbtPlugin("com.eed3si9n" % "sbt-assembly" % "0.11.2") +addSbtPlugin("com.eed3si9n" % "sbt-assembly" % "0.14.6") From e44c0be968f56fc12c34133a90ffd502cd706997 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 12 Jul 2018 14:21:55 -0500 Subject: [PATCH 0374/1998] TypeScript: fix HOME bug and node symlink. Update the Dockerfile to fix a symlink loop. Update node_readline.ts to fix a failure with usage of process.env.HOME which started failing for some reason. --- ts/Dockerfile | 1 - ts/node_readline.ts | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/ts/Dockerfile b/ts/Dockerfile index 8926b363f5..1bb0452dc9 100644 --- a/ts/Dockerfile +++ b/ts/Dockerfile @@ -24,6 +24,5 @@ WORKDIR /mal RUN apt-get -y install build-essential RUN curl -sL https://deb.nodesource.com/setup_6.x | bash - RUN apt-get -y install nodejs -RUN ln -sf nodejs /usr/bin/node ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/ts/node_readline.ts b/ts/node_readline.ts index dca3ac5610..cc0af945d8 100644 --- a/ts/node_readline.ts +++ b/ts/node_readline.ts @@ -6,7 +6,7 @@ import * as fs from "fs"; const RL_LIB = "libreadline"; // NOTE: libreadline is GPL // var RL_LIB = "libedit"; -const HISTORY_FILE = path.join(process.env.HOME, ".mal-history"); +const HISTORY_FILE = path.join(process.env.HOME || ".", ".mal-history"); const rllib = ffi.Library(RL_LIB, { "readline": ["string", ["string"]], From bbd62dc97c5deb43eec6ed9cc5c7bace06b76671 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 12 Jul 2018 14:24:14 -0500 Subject: [PATCH 0375/1998] tests/stepA: allow time-ms result to be signed. In Java the time-ms value was negative. This actually still works fine because arithmetic comparison is still correct. So allow signed time-ms results. --- tests/stepA_mal.mal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/stepA_mal.mal b/tests/stepA_mal.mal index 1d3601f098..ac8a717f80 100644 --- a/tests/stepA_mal.mal +++ b/tests/stepA_mal.mal @@ -268,8 +268,8 @@ ;; ;; Testing time-ms function (def! start-time (time-ms)) -(> start-time 0) -;=>true +(= start-time 0) +;=>false (let* [sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0))] (sumdown 10)) ; Waste some time ;=>55 (> (time-ms) start-time) From 9a66ffcd2e411e0dff235e3055e453b1bb2800a1 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 28 Jun 2018 22:02:42 -0500 Subject: [PATCH 0376/1998] rust: remove rustyline ANSI CSI codes from output --- runtest.py | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/runtest.py b/runtest.py index 1930b62c1d..1f9dd7033c 100755 --- a/runtest.py +++ b/runtest.py @@ -133,6 +133,13 @@ def read_to_prompt(self, prompts, timeout): else: self.buf += new_data self.buf = self.buf.replace("\r\r", "\r") + # Remove ANSI codes generally + #ansi_escape = re.compile(r'\x1B\[[0-?]*[ -/]*[@-~]') + # Remove rustyline ANSI CSI codes: + # - [6C - CR + cursor forward + # - [6K - CR + erase in line + ansi_escape = re.compile(r'\r\x1B\[[0-9]*[CK]') + self.buf = ansi_escape.sub('', self.buf) for prompt in prompts: regexp = re.compile(prompt) match = regexp.search(self.buf) From 4ef4b17cd0bd0c2c8ee7ae908a405db2af849f70 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 12 Jul 2018 00:23:40 -0500 Subject: [PATCH 0377/1998] rust: Update rust and update/refactor implementation This rewrites the rust implementation to use many new features of the current version of rust. The refactor is much more concise (only 2/3rds the size) and switches to using a lot of the more functional features (iterators, closures, etc) that have been added or improved in rust. Unfortunately, the implementation is a fair bit slower (about 30% on perf3). It's not clear why this is the case but concision and being more idiomatic wins over performance. --- Makefile | 2 +- rust/.gitignore | 1 + rust/Cargo.lock | 186 ++++++++++ rust/Cargo.toml | 62 +++- rust/Dockerfile | 40 +-- rust/Makefile | 43 +-- rust/core.rs | 327 ++++++++++++++++++ rust/env.rs | 84 +++++ rust/printer.rs | 60 ++++ rust/reader.rs | 142 ++++++++ rust/readline.rs | 0 rust/run | 2 +- rust/src/bin/step0_repl.rs | 26 -- rust/src/bin/step1_read_print.rs | 39 --- rust/src/bin/step2_eval.rs | 114 ------- rust/src/bin/step3_env.rs | 165 --------- rust/src/bin/step4_if_fn_do.rs | 185 ---------- rust/src/bin/step5_tco.rs | 202 ----------- rust/src/bin/step6_file.rs | 232 ------------- rust/src/bin/step7_quote.rs | 281 ---------------- rust/src/bin/step8_macros.rs | 350 ------------------- rust/src/bin/step9_try.rs | 380 --------------------- rust/src/bin/stepA_mal.rs | 385 --------------------- rust/src/core.rs | 560 ------------------------------- rust/src/env.rs | 106 ------ rust/src/lib.rs | 15 - rust/src/printer.rs | 47 --- rust/src/reader.rs | 198 ----------- rust/src/readline.rs | 81 ----- rust/src/types.rs | 430 ------------------------ rust/step0_repl.rs | 33 ++ rust/step1_read_print.rs | 53 +++ rust/step2_eval.rs | 135 ++++++++ rust/step3_env.rs | 159 +++++++++ rust/step4_if_fn_do.rs | 182 ++++++++++ rust/step5_tco.rs | 209 ++++++++++++ rust/step6_file.rs | 232 +++++++++++++ rust/step7_quote.rs | 274 +++++++++++++++ rust/step8_macros.rs | 343 +++++++++++++++++++ rust/step9_try.rs | 364 ++++++++++++++++++++ rust/stepA_mal.rs | 370 ++++++++++++++++++++ rust/tests/step5_tco.mal | 2 - rust/types.rs | 232 +++++++++++++ 43 files changed, 3467 insertions(+), 3866 deletions(-) create mode 100644 rust/.gitignore create mode 100644 rust/Cargo.lock create mode 100644 rust/core.rs create mode 100644 rust/env.rs create mode 100644 rust/printer.rs create mode 100644 rust/reader.rs create mode 100644 rust/readline.rs delete mode 100644 rust/src/bin/step0_repl.rs delete mode 100644 rust/src/bin/step1_read_print.rs delete mode 100644 rust/src/bin/step2_eval.rs delete mode 100644 rust/src/bin/step3_env.rs delete mode 100644 rust/src/bin/step4_if_fn_do.rs delete mode 100644 rust/src/bin/step5_tco.rs delete mode 100644 rust/src/bin/step6_file.rs delete mode 100644 rust/src/bin/step7_quote.rs delete mode 100644 rust/src/bin/step8_macros.rs delete mode 100644 rust/src/bin/step9_try.rs delete mode 100644 rust/src/bin/stepA_mal.rs delete mode 100644 rust/src/core.rs delete mode 100644 rust/src/env.rs delete mode 100644 rust/src/lib.rs delete mode 100644 rust/src/printer.rs delete mode 100644 rust/src/reader.rs delete mode 100644 rust/src/readline.rs delete mode 100644 rust/src/types.rs create mode 100644 rust/step0_repl.rs create mode 100644 rust/step1_read_print.rs create mode 100644 rust/step2_eval.rs create mode 100644 rust/step3_env.rs create mode 100644 rust/step4_if_fn_do.rs create mode 100644 rust/step5_tco.rs create mode 100644 rust/step6_file.rs create mode 100644 rust/step7_quote.rs create mode 100644 rust/step8_macros.rs create mode 100644 rust/step9_try.rs create mode 100644 rust/stepA_mal.rs delete mode 100644 rust/tests/step5_tco.mal create mode 100644 rust/types.rs diff --git a/Makefile b/Makefile index 6c09413982..62c9b330fa 100644 --- a/Makefile +++ b/Makefile @@ -232,7 +232,7 @@ racket_STEP_TO_PROG = racket/$($(1)).rkt rexx_STEP_TO_PROG = rexx/$($(1)).rexxpp rpython_STEP_TO_PROG = rpython/$($(1)) ruby_STEP_TO_PROG = ruby/$($(1)).rb -rust_STEP_TO_PROG = rust/target/release/$($(1)) +rust_STEP_TO_PROG = rust/$($(1)) scala_STEP_TO_PROG = scala/target/scala-2.11/classes/$($(1)).class scheme_STEP_TO_PROG = $(scheme_STEP_TO_PROG_$(scheme_MODE)) skew_STEP_TO_PROG = skew/$($(1)).js diff --git a/rust/.gitignore b/rust/.gitignore new file mode 100644 index 0000000000..9fe342cbf4 --- /dev/null +++ b/rust/.gitignore @@ -0,0 +1 @@ +./target diff --git a/rust/Cargo.lock b/rust/Cargo.lock new file mode 100644 index 0000000000..c4891eb4d3 --- /dev/null +++ b/rust/Cargo.lock @@ -0,0 +1,186 @@ +[[package]] +name = "aho-corasick" +version = "0.6.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "memchr 2.0.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "bitflags" +version = "0.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "either" +version = "1.5.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "encode_unicode" +version = "0.1.3" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "fnv" +version = "1.0.6" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "itertools" +version = "0.7.8" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "either 1.5.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "kernel32-sys" +version = "0.2.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "winapi 0.2.8 (registry+https://github.com/rust-lang/crates.io-index)", + "winapi-build 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "lazy_static" +version = "1.0.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "libc" +version = "0.2.42" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "memchr" +version = "2.0.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "libc 0.2.42 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "nix" +version = "0.5.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "bitflags 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.42 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "regex" +version = "1.0.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "aho-corasick 0.6.5 (registry+https://github.com/rust-lang/crates.io-index)", + "memchr 2.0.1 (registry+https://github.com/rust-lang/crates.io-index)", + "regex-syntax 0.6.1 (registry+https://github.com/rust-lang/crates.io-index)", + "thread_local 0.3.5 (registry+https://github.com/rust-lang/crates.io-index)", + "utf8-ranges 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "regex-syntax" +version = "0.6.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "ucd-util 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rust2" +version = "0.1.0" +dependencies = [ + "fnv 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", + "itertools 0.7.8 (registry+https://github.com/rust-lang/crates.io-index)", + "lazy_static 1.0.1 (registry+https://github.com/rust-lang/crates.io-index)", + "regex 1.0.1 (registry+https://github.com/rust-lang/crates.io-index)", + "rustyline 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rustyline" +version = "1.0.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "encode_unicode 0.1.3 (registry+https://github.com/rust-lang/crates.io-index)", + "kernel32-sys 0.2.2 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.42 (registry+https://github.com/rust-lang/crates.io-index)", + "nix 0.5.1 (registry+https://github.com/rust-lang/crates.io-index)", + "unicode-width 0.1.5 (registry+https://github.com/rust-lang/crates.io-index)", + "winapi 0.2.8 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "thread_local" +version = "0.3.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "lazy_static 1.0.1 (registry+https://github.com/rust-lang/crates.io-index)", + "unreachable 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "ucd-util" +version = "0.1.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "unicode-width" +version = "0.1.5" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "unreachable" +version = "1.0.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "void 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "utf8-ranges" +version = "1.0.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "void" +version = "1.0.2" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "winapi" +version = "0.2.8" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "winapi-build" +version = "0.1.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[metadata] +"checksum aho-corasick 0.6.5 (registry+https://github.com/rust-lang/crates.io-index)" = "f0ba20154ea1f47ce2793322f049c5646cc6d0fa9759d5f333f286e507bf8080" +"checksum bitflags 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "8dead7461c1127cf637931a1e50934eb6eee8bff2f74433ac7909e9afcee04a3" +"checksum either 1.5.0 (registry+https://github.com/rust-lang/crates.io-index)" = "3be565ca5c557d7f59e7cfcf1844f9e3033650c929c6566f511e8005f205c1d0" +"checksum encode_unicode 0.1.3 (registry+https://github.com/rust-lang/crates.io-index)" = "28d65f1f5841ef7c6792861294b72beda34c664deb8be27970f36c306b7da1ce" +"checksum fnv 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)" = "2fad85553e09a6f881f739c29f0b00b0f01357c743266d478b68951ce23285f3" +"checksum itertools 0.7.8 (registry+https://github.com/rust-lang/crates.io-index)" = "f58856976b776fedd95533137617a02fb25719f40e7d9b01c7043cd65474f450" +"checksum kernel32-sys 0.2.2 (registry+https://github.com/rust-lang/crates.io-index)" = "7507624b29483431c0ba2d82aece8ca6cdba9382bff4ddd0f7490560c056098d" +"checksum lazy_static 1.0.1 (registry+https://github.com/rust-lang/crates.io-index)" = "e6412c5e2ad9584b0b8e979393122026cdd6d2a80b933f890dcd694ddbe73739" +"checksum libc 0.2.42 (registry+https://github.com/rust-lang/crates.io-index)" = "b685088df2b950fccadf07a7187c8ef846a959c142338a48f9dc0b94517eb5f1" +"checksum memchr 2.0.1 (registry+https://github.com/rust-lang/crates.io-index)" = "796fba70e76612589ed2ce7f45282f5af869e0fdd7cc6199fa1aa1f1d591ba9d" +"checksum nix 0.5.1 (registry+https://github.com/rust-lang/crates.io-index)" = "bfb3ddedaa14746434a02041940495bf11325c22f6d36125d3bdd56090d50a79" +"checksum regex 1.0.1 (registry+https://github.com/rust-lang/crates.io-index)" = "13c93d55961981ba9226a213b385216f83ab43bd6ac53ab16b2eeb47e337cf4e" +"checksum regex-syntax 0.6.1 (registry+https://github.com/rust-lang/crates.io-index)" = "05b06a75f5217880fc5e905952a42750bf44787e56a6c6d6852ed0992f5e1d54" +"checksum rustyline 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)" = "00b06ac9c8e8e3e83b33d175d39a9f7b6c2c930c82990593719c8e48788ae2d9" +"checksum thread_local 0.3.5 (registry+https://github.com/rust-lang/crates.io-index)" = "279ef31c19ededf577bfd12dfae728040a21f635b06a24cd670ff510edd38963" +"checksum ucd-util 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "fd2be2d6639d0f8fe6cdda291ad456e23629558d466e2789d2c3e9892bda285d" +"checksum unicode-width 0.1.5 (registry+https://github.com/rust-lang/crates.io-index)" = "882386231c45df4700b275c7ff55b6f3698780a650026380e72dabe76fa46526" +"checksum unreachable 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)" = "382810877fe448991dfc7f0dd6e3ae5d58088fd0ea5e35189655f84e6814fa56" +"checksum utf8-ranges 1.0.0 (registry+https://github.com/rust-lang/crates.io-index)" = "662fab6525a98beff2921d7f61a39e7d59e0b425ebc7d0d9e66d316e55124122" +"checksum void 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "6a02e4885ed3bc0f2de90ea6dd45ebcbb66dacffe03547fadbb0eeae2770887d" +"checksum winapi 0.2.8 (registry+https://github.com/rust-lang/crates.io-index)" = "167dc9d6949a9b857f3451275e911c3f44255842c1f7a76f33c55103a909087a" +"checksum winapi-build 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "2d315eee3b34aca4797b2da6b13ed88266e6d612562a0c46390af8299fc699bc" diff --git a/rust/Cargo.toml b/rust/Cargo.toml index 70e24d3beb..3eb30b08eb 100644 --- a/rust/Cargo.toml +++ b/rust/Cargo.toml @@ -1,11 +1,57 @@ [package] - -name = "mal" -version = "0.0.1" -authors = [ "Your name " ] +name = "rust2" +version = "0.1.0" +authors = ["root"] [dependencies] -time = "0.1" -regex = "0.1" -libc = "0.1" -num = "*" +rustyline = "1.0.0" +lazy_static = "1.0.1" + +regex = "1.0.0" +itertools = "0.7.4" +fnv = "1.0.3" + + +[[bin]] +name = "step0_repl" +path = "step0_repl.rs" + +[[bin]] +name = "step1_read_print" +path = "step1_read_print.rs" + +[[bin]] +name = "step2_eval" +path = "step2_eval.rs" + +[[bin]] +name = "step3_env" +path = "step3_env.rs" + +[[bin]] +name = "step4_if_fn_do" +path = "step4_if_fn_do.rs" + +[[bin]] +name = "step5_tco" +path = "step5_tco.rs" + +[[bin]] +name = "step6_file" +path = "step6_file.rs" + +[[bin]] +name = "step7_quote" +path = "step7_quote.rs" + +[[bin]] +name = "step8_macros" +path = "step8_macros.rs" + +[[bin]] +name = "step9_try" +path = "step9_try.rs" + +[[bin]] +name = "stepA_mal" +path = "stepA_mal.rs" diff --git a/rust/Dockerfile b/rust/Dockerfile index ba373a258f..fb1fdd69ee 100644 --- a/rust/Dockerfile +++ b/rust/Dockerfile @@ -1,39 +1,3 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin +FROM rust -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ - -# Based on https://github.com/Scorpil/docker-rust/blob/master/stable/Dockerfile - -ENV RUST_ARCHIVE=rust-1.14.0-x86_64-unknown-linux-gnu.tar.gz -ENV RUST_DOWNLOAD_URL=https://static.rust-lang.org/dist/$RUST_ARCHIVE - -RUN mkdir -p /rust && cd /rust \ - && curl -fsOSL $RUST_DOWNLOAD_URL \ - && curl -s $RUST_DOWNLOAD_URL.sha256 | sha256sum -c - \ - && tar -C /rust -xzf $RUST_ARCHIVE --strip-components=1 \ - && rm $RUST_ARCHIVE \ - && ./install.sh - -ENV CARGO_HOME /mal/.cargo +ENV CARGO_HOME=/mal diff --git a/rust/Makefile b/rust/Makefile index 03a1a6936e..49fc80fb21 100644 --- a/rust/Makefile +++ b/rust/Makefile @@ -1,40 +1,43 @@ -##################### -SOURCES_BASE = src/types.rs src/readline.rs \ - src/reader.rs src/printer.rs \ - src/env.rs src/core.rs -SOURCES_LISP = src/env.rs src/core.rs src/bin/stepA_mal.rs +UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal +STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) + +SOURCES_BASE = types.rs reader.rs printer.rs +SOURCES_LISP = env.rs core.rs stepA_mal.rs SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -##################### +all: $(STEPS) -SRCS = step0_repl.rs step1_read_print.rs step2_eval.rs step3_env.rs \ - step4_if_fn_do.rs step5_tco.rs step6_file.rs step7_quote.rs \ - step8_macros.rs step9_try.rs stepA_mal.rs -BINS = $(SRCS:%.rs=target/release/%) +dist: mal -##################### +mal: stepA_mal + cp $< $@ -all: $(BINS) +%: %.rs + cargo build --release --bin $* + cp target/release/$* $@ -dist: mal +STEP0_DEPS = readline.rs +STEP1_DEPS = $(STEP0_DEPS) types.rs reader.rs printer.rs +STEP3_DEPS = $(STEP1_DEPS) env.rs +STEP4_DEPS = $(STEP3_DEPS) core.rs -mal: target/release/stepA_mal - cp $< $@ +step0_repl: $(STEP0_DEPS) +step1_read_print step2_eval: $(STEP1_DEPS) +step3_env: $(STEP3_DEPS) +$(UPPER_STEPS): $(STEP4_DEPS) -# TODO: would be nice to build just the step requested -$(BINS): target/release/%: src/bin/%.rs $(wildcard src/*.rs) - cargo build --release +.PHONY: clean stats stats-lisp clean: cargo clean + rm -f $(STEPS) rm -f mal -.PHONY: stats stats-lisp mal - stats: $(SOURCES) @wc $^ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" stats-lisp: $(SOURCES_LISP) @wc $^ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" + diff --git a/rust/core.rs b/rust/core.rs new file mode 100644 index 0000000000..438c8486c2 --- /dev/null +++ b/rust/core.rs @@ -0,0 +1,327 @@ +use std::rc::Rc; +use std::fs::File; +use std::io::Read; +use std::sync::Mutex; +use std::time::{SystemTime, UNIX_EPOCH}; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +use types::{MalVal,MalArgs,MalRet,error,func,hash_map,_assoc,_dissoc,atom}; +use types::MalVal::{Nil,Bool,Int,Str,Sym,List,Vector,Hash,Func,MalFunc,Atom}; +use types::MalErr::{ErrMalVal}; +use reader::read_str; +use printer::pr_seq; + +macro_rules! fn_t_int_int { + ($ret:ident, $fn:expr) => {{ + |a:MalArgs| { + match (a[0].clone(), a[1].clone()) { + (Int(a0), Int(a1)) => Ok($ret($fn(a0, a1))), + _ => error("expecting (int,int) args"), + } + } + }}; +} + +macro_rules! fn_is_type { + ($($ps:pat),*) => {{ + |a:MalArgs| { Ok(Bool(match a[0] { $($ps => true,)* _ => false})) } + }}; + ($p:pat if $e:expr) => {{ + |a:MalArgs| { Ok(Bool(match a[0] { $p if $e => true, _ => false})) } + }}; + ($p:pat if $e:expr,$($ps:pat),*) => {{ + |a:MalArgs| { Ok(Bool(match a[0] { $p if $e => true, $($ps => true,)* _ => false})) } + }}; +} + +macro_rules! fn_str { + ($fn:expr) => {{ + |a:MalArgs| { + match a[0].clone() { + Str(a0) => $fn(a0), + _ => error("expecting (str) arg"), + } + } + }}; +} + +fn symbol(a: MalArgs) -> MalRet { + match a[0] { + Str(ref s) => Ok(Sym(s.to_string())), + _ => error("illegal symbol call") + } +} + +fn readline(a: MalArgs) -> MalRet { + lazy_static! { + static ref RL: Mutex> = Mutex::new(Editor::<()>::new()); + } + //let mut rl = Editor::<()>::new(); + + match a[0] { + Str(ref p) => { + //match rl.readline(p) { + match RL.lock().unwrap().readline(p) { + Ok(line) => Ok(Str(line)), + Err(ReadlineError::Eof) => Ok(Nil), + Err(e) => error(&format!("{:?}", e)) + } + }, + _ => error("readline: prompt is not Str"), + } +} + +fn slurp(f: String) -> MalRet { + let mut s = String::new(); + match File::open(f).and_then(|mut f| f.read_to_string(&mut s)) { + Ok(_) => Ok(Str(s)), + Err(e) => error(&e.to_string()), + } +} + +fn time_ms(_a: MalArgs) -> MalRet { + let ms_e = match SystemTime::now().duration_since(UNIX_EPOCH) { + Ok(d) => d, + Err(e) => return error(&format!("{:?}", e)), + }; + Ok(Int(ms_e.as_secs() as i64 * 1000 + + ms_e.subsec_nanos() as i64 / 1_000_000)) +} + +fn get(a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Nil, _) => Ok(Nil), + (Hash(ref hm,_), Str(ref s)) => { + match hm.get(s) { + Some(mv) => Ok(mv.clone()), + None => Ok(Nil), + } + }, + _ => error("illegal get args") + } +} + +fn assoc(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm,_) => _assoc((**hm).clone(), a[1..].to_vec()), + _ => error("assoc on non-Hash Map") + } +} + +fn dissoc(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm,_) => _dissoc((**hm).clone(), a[1..].to_vec()), + _ => error("dissoc on non-Hash Map") + } +} + +fn contains_q(a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Hash(ref hm,_), Str(ref s)) => { + Ok(Bool(hm.contains_key(s))) + }, + _ => error("illegal get args") + } +} + +fn keys(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm,_) => { + Ok(list!(hm.keys().map(|k|{Str(k.to_string())}).collect())) + }, + _ => error("keys requires Hash Map") + } +} + +fn vals(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm,_) => { + Ok(list!(hm.values().map(|v|{v.clone()}).collect())) + }, + _ => error("keys requires Hash Map") + } +} + +fn cons(a: MalArgs) -> MalRet { + match a[1].clone() { + List(v,_) | Vector(v,_) => { + let mut new_v = vec![a[0].clone()]; + new_v.extend_from_slice(&v); + Ok(list!(new_v.to_vec())) + }, + _ => error("cons expects seq as second arg"), + } +} + +fn concat(a: MalArgs) -> MalRet { + let mut new_v = vec![]; + for seq in a.iter() { + match seq { + List(v,_) | Vector(v,_) => new_v.extend_from_slice(v), + _ => return error("non-seq passed to concat"), + } + } + Ok(list!(new_v.to_vec())) +} + +fn nth(a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (List(seq,_), Int(idx)) | (Vector(seq,_), Int(idx)) => { + if seq.len() <= idx as usize { + return error("nth: index out of range"); + } + Ok(seq[idx as usize].clone()) + } + _ => error("invalid args to nth"), + } +} + +fn first(a: MalArgs) -> MalRet { + match a[0].clone() { + List(ref seq,_) | Vector(ref seq,_) if seq.len() == 0 => Ok(Nil), + List(ref seq,_) | Vector(ref seq,_) => Ok(seq[0].clone()), + Nil => Ok(Nil), + _ => error("invalid args to first"), + } +} + +fn rest(a: MalArgs) -> MalRet { + match a[0].clone() { + List(ref seq,_) | Vector(ref seq,_) => { + if seq.len() > 1 { + Ok(list!(seq[1..].to_vec())) + } else { + Ok(list![]) + } + }, + Nil => Ok(list![]), + _ => error("invalid args to first"), + } +} + +fn apply(a: MalArgs) -> MalRet { + match a[a.len()-1] { + List(ref v,_) | Vector(ref v,_) => { + let f = &a[0]; + let mut fargs = a[1..a.len()-1].to_vec(); + fargs.extend_from_slice(&v); + f.apply(fargs) + }, + _ => error("apply called with non-seq"), + } +} + +fn map(a: MalArgs) -> MalRet { + match a[1] { + List(ref v,_) | Vector(ref v,_) => { + let mut res = vec![]; + for mv in v.iter() { + res.push(a[0].apply(vec![mv.clone()])?) + } + Ok(list!(res)) + }, + _ => error("map called with non-seq"), + } +} + +fn conj(a: MalArgs) -> MalRet { + match a[0] { + List(ref v,_) => { + let sl = a[1..].iter().rev().map(|a|{a.clone()}).collect::>(); + Ok(list!([&sl[..],v].concat())) + }, + Vector(ref v,_) => Ok(vector!([v,&a[1..]].concat())), + _ => error("conj: called with non-seq"), + } +} + +fn seq(a: MalArgs) -> MalRet { + match a[0] { + List(ref v,_) | Vector(ref v,_) if v.len() == 0 => Ok(Nil), + List(ref v,_) | Vector(ref v,_) => Ok(list!(v.to_vec())), + Str(ref s) if s.len() == 0 => Ok(Nil), + Str(ref s) if !a[0].keyword_q() => { + Ok(list!(s.chars().map(|c|{Str(c.to_string())}).collect())) + }, + Nil => Ok(Nil), + _ => error("seq: called with non-seq"), + } +} + +pub fn ns() -> Vec<(&'static str, MalVal)> { + vec![ + ("=", func(|a|{Ok(Bool(a[0] == a[1]))})), + ("throw", func(|a|{Err(ErrMalVal(a[0].clone()))})), + + ("nil?", func(fn_is_type!(Nil))), + ("true?", func(fn_is_type!(Bool(true)))), + ("false?", func(fn_is_type!(Bool(false)))), + ("symbol", func(symbol)), + ("symbol?", func(fn_is_type!(Sym(_)))), + ("string?", func(fn_is_type!(Str(ref s) if !s.starts_with("\u{29e}")))), + ("keyword", func(|a|{a[0].keyword()})), + ("keyword?", func(fn_is_type!(Str(ref s) if s.starts_with("\u{29e}")))), + ("number?", func(fn_is_type!(Int(_)))), + ("fn?", func(fn_is_type!(MalFunc{is_macro,..} if !is_macro,Func(_,_)))), + ("macro?", func(fn_is_type!(MalFunc{is_macro,..} if is_macro))), + + ("pr-str", func(|a|Ok(Str(pr_seq(&a, true, "", "", " "))))), + ("str", func(|a|Ok(Str(pr_seq(&a, false, "", "", ""))))), + ("prn", func(|a|{println!("{}", pr_seq(&a, true, "", "", " ")); Ok(Nil)})), + ("println", func(|a|{println!("{}", pr_seq(&a, false, "", "", " ")); Ok(Nil)})), + ("read-string", func(fn_str!(|s|{read_str(s)}))), + ("readline", func(readline)), + ("slurp", func(fn_str!(|f|{slurp(f)}))), + + ("<", func(fn_t_int_int!(Bool,|i,j|{i", func(fn_t_int_int!(Bool,|i,j|{i>j}))), + (">=", func(fn_t_int_int!(Bool,|i,j|{i>=j}))), + ("+", func(fn_t_int_int!(Int,|i,j|{i+j}))), + ("-", func(fn_t_int_int!(Int,|i,j|{i-j}))), + ("*", func(fn_t_int_int!(Int,|i,j|{i*j}))), + ("/", func(fn_t_int_int!(Int,|i,j|{i/j}))), + ("time-ms", func(time_ms)), + + ("sequential?", func(fn_is_type!(List(_,_),Vector(_,_)))), + ("list", func(|a|{Ok(list!(a))})), + ("list?", func(fn_is_type!(List(_,_)))), + ("vector", func(|a|{Ok(vector!(a))})), + ("vector?", func(fn_is_type!(Vector(_,_)))), + ("hash-map", func(|a|{hash_map(a)})), + ("map?", func(fn_is_type!(Hash(_,_)))), + ("assoc", func(assoc)), + ("dissoc", func(dissoc)), + ("get", func(get)), + ("contains?", func(contains_q)), + ("keys", func(keys)), + ("vals", func(vals)), + + ("cons", func(cons)), + ("concat", func(concat)), + ("empty?", func(|a|{a[0].empty_q()})), + ("nth", func(nth)), + ("first", func(first)), + ("rest", func(rest)), + ("count", func(|a|{a[0].count()})), + ("apply", func(apply)), + ("map", func(map)), + + ("conj", func(conj)), + ("seq", func(seq)), + + ("meta", func(|a|{a[0].get_meta()})), + ("with-meta", func(|a|{a[0].clone().with_meta(&a[1])})), + ("atom", func(|a|{Ok(atom(&a[0]))})), + ("atom?", func(fn_is_type!(Atom(_)))), + ("deref", func(|a|{a[0].deref()})), + ("reset!", func(|a|{a[0].reset_bang(&a[1])})), + ("swap!", func(|a|{a[0].swap_bang(&a[1..].to_vec())})), + ] +} + +// vim: ts=2:sw=2:expandtab + diff --git a/rust/env.rs b/rust/env.rs new file mode 100644 index 0000000000..130bca250b --- /dev/null +++ b/rust/env.rs @@ -0,0 +1,84 @@ +use std::rc::Rc; +use std::cell::RefCell; +//use std::collections::HashMap; +use fnv::FnvHashMap; + +use types::{MalVal,MalRet,MalErr,error}; +use types::MalVal::{Nil,Sym,List,Vector}; +use types::MalErr::{ErrString}; + +#[derive(Debug)] +pub struct EnvStruct { + data: RefCell>, + pub outer: Option, +} + +pub type Env = Rc; + +// TODO: it would be nice to use impl here but it doesn't work on +// a deftype (i.e. Env) + +pub fn env_new(outer: Option) -> Env { + Rc::new(EnvStruct{data: RefCell::new(FnvHashMap::default()), outer: outer}) +} + +// TODO: mbinds and exprs as & types +pub fn env_bind(outer: Option, mbinds: MalVal, + exprs: Vec) -> Result { + let env = env_new(outer); + match mbinds { + List(binds,_) | Vector(binds,_) => { + for (i, b) in binds.iter().enumerate() { + match b { + Sym(s) if s == "&" => { + env_set(&env, binds[i+1].clone(), list!(exprs[i..].to_vec()))?; + break; + }, + _ => { + env_set(&env, b.clone(), exprs[i].clone())?; + }, + } + } + Ok(env) + }, + _ => Err(ErrString("env_bind binds not List/Vector".to_string())), + } +} + +pub fn env_find(env: &Env, key: &str) -> Option { + match (env.data.borrow().contains_key(key), env.outer.clone()) { + (true, _) => Some(env.clone()), + (false, Some(o)) => env_find(&o, key), + _ => None, + } +} + +pub fn env_get(env: &Env, key: &MalVal) -> MalRet { + match key { + Sym(ref s) => { + match env_find(env, s) { + Some(e) => Ok(e.data.borrow().get(s) + .ok_or(ErrString(format!("'{}' not found", s)))? + .clone()), + _ => error(&format!("'{}' not found", s)), + } + }, + _ => error("Env.get called with non-Str"), + } +} + +pub fn env_set(env: &Env, key: MalVal, val: MalVal) -> MalRet { + match key { + Sym(ref s) => { + env.data.borrow_mut().insert(s.to_string(), val.clone()); + Ok(val) + }, + _ => error("Env.set called with non-Str") + } +} + +pub fn env_sets(env: &Env, key: &str, val: MalVal) { + env.data.borrow_mut().insert(key.to_string(), val); +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/printer.rs b/rust/printer.rs new file mode 100644 index 0000000000..01a7ff6b0f --- /dev/null +++ b/rust/printer.rs @@ -0,0 +1,60 @@ +use types::MalVal; +use types::MalVal::{Nil,Bool,Int,Str,Sym,List,Vector,Hash,Func,MalFunc,Atom}; + +fn escape_str(s: &str) -> String { + s.chars().map(|c| { + match c { + '"' => "\\\"".to_string(), + '\n' => "\\n".to_string(), + '\\' => "\\\\".to_string(), + _ => c.to_string(), + } + }).collect::>().join("") +} + +impl MalVal { + pub fn pr_str(&self, print_readably: bool) -> String { + match self { + Nil => String::from("nil"), + Bool(true) => String::from("true"), + Bool(false) => String::from("false"), + Int(i) => format!("{}", i), + //Float(f) => format!("{}", f), + Str(s) => { + if s.starts_with("\u{29e}") { + format!(":{}", &s[2..]) + } else if print_readably { + format!("\"{}\"", escape_str(s)) + } else { + s.clone() + } + } + Sym(s) => s.clone(), + List(l,_) => pr_seq(&**l, print_readably, "(", ")", " "), + Vector(l,_) => pr_seq(&**l, print_readably, "[", "]", " "), + Hash(hm,_) => { + let l: Vec = hm + .iter() + .flat_map(|(k, v)| { vec![Str(k.to_string()), v.clone()] }) + .collect(); + pr_seq(&l, print_readably, "{", "}", " ") + }, + Func(f,_) => format!("#", f), + MalFunc{ast: a, params: p, ..} => { + format!("(fn* {} {})", p.pr_str(true), a.pr_str(true)) + }, + Atom(a) => format!("(atom {})", a.borrow().pr_str(true)), + } + } +} + +pub fn pr_seq(seq: &Vec, print_readably: bool, + start: &str, end: &str, join: &str) -> String { + let strs: Vec = seq + .iter() + .map(|x| x.pr_str(print_readably)) + .collect(); + format!("{}{}{}", start, strs.join(join), end) +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/reader.rs b/rust/reader.rs new file mode 100644 index 0000000000..cae8223cfa --- /dev/null +++ b/rust/reader.rs @@ -0,0 +1,142 @@ +use std::rc::Rc; +use regex::{Regex,Captures}; + +use types::{MalVal,MalRet,MalErr,error,hash_map}; +use types::MalVal::{Nil,Bool,Int,Str,Sym,List,Vector}; +use types::MalErr::ErrString; + +#[derive(Debug, Clone)] +struct Reader { + tokens: Vec, + pos: usize, +} + +impl Reader { + fn next(&mut self) -> Result { + self.pos = self.pos + 1; + Ok(self.tokens.get(self.pos-1) + .ok_or(ErrString("underflow".to_string()))?.to_string()) + } + fn peek(&self) -> Result { + Ok(self.tokens.get(self.pos) + .ok_or(ErrString("underflow".to_string()))?.to_string()) + } +} + +fn tokenize(str: &str) -> Vec { + lazy_static! { + static ref RE: Regex = Regex::new(r###"[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]+)"###).unwrap(); + } + + let mut res = vec![]; + for cap in RE.captures_iter(str) { + if cap[1].starts_with(";") { continue } + res.push(String::from(&cap[1])); + } + res +} + +fn unescape_str(s: &str) -> String { + lazy_static! { + static ref RE: Regex = Regex::new(r#"\\(.)"#).unwrap(); + } + RE.replace_all(&s, |caps: &Captures| { + format!("{}", if &caps[1] == "n" { "\n" } else { &caps[1] }) + }).to_string() +} + +fn read_atom(rdr: &mut Reader) -> MalRet { + lazy_static! { + static ref INT_RE: Regex = Regex::new(r"^-?[0-9]+$").unwrap(); + } + let token = rdr.next()?; + match &token[..] { + "nil" => Ok(Nil), + "false" => Ok(Bool(false)), + "true" => Ok(Bool(true)), + _ => { + if INT_RE.is_match(&token) { + Ok(Int(token.parse().unwrap())) + } else if token.starts_with("\"") { + if token.ends_with("\"") { + Ok(Str(unescape_str(&token[1..token.len()-1]))) + } else { + error("expected '\"', got EOF") + } + } else if token.starts_with(":") { + Ok(Str(format!("\u{29e}{}", &token[1..]))) + } else { + Ok(Sym(token.to_string())) + } + } + } +} + +fn read_seq(rdr: &mut Reader, end: &str) -> MalRet { + let mut seq : Vec = vec![]; + rdr.next()?; + loop { + let token = match rdr.peek() { + Ok(t) => t, + Err(_) => return error(&format!("expected '{}', got EOF", end)) + }; + if token == end { break } + seq.push(read_form(rdr)?) + } + let _ = rdr.next(); + match end { + ")" => Ok(list!(seq)), + "]" => Ok(vector!(seq)), + "}" => hash_map(seq), + _ => error("read_seq unknown end value"), + } +} + +fn read_form(rdr: &mut Reader) -> MalRet { + let token = rdr.peek()?; + match &token[..] { + "'" => { + let _ = rdr.next(); + Ok(list![Sym("quote".to_string()), read_form(rdr)?]) + }, + "`" => { + let _ = rdr.next(); + Ok(list![Sym("quasiquote".to_string()), read_form(rdr)?]) + }, + "~" => { + let _ = rdr.next(); + Ok(list![Sym("unquote".to_string()), read_form(rdr)?]) + }, + "~@" => { + let _ = rdr.next(); + Ok(list![Sym("splice-unquote".to_string()), read_form(rdr)?]) + }, + "^" => { + let _ = rdr.next(); + let meta = read_form(rdr)?; + Ok(list![Sym("with-meta".to_string()), read_form(rdr)?, meta]) + }, + "@" => { + let _ = rdr.next(); + Ok(list![Sym("deref".to_string()), read_form(rdr)?]) + }, + ")" => error("unexpected ')'"), + "(" => read_seq(rdr, ")"), + "]" => error("unexpected ']'"), + "[" => read_seq(rdr, "]"), + "}" => error("unexpected '}'"), + "{" => read_seq(rdr, "}"), + _ => read_atom(rdr), + } +} + +pub fn read_str(str: String) -> MalRet { + let tokens = tokenize(&str); + //println!("tokens: {:?}", tokens); + if tokens.len() == 0 { + return error("no input"); + } + read_form(&mut Reader { pos: 0, tokens: tokens }) +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/readline.rs b/rust/readline.rs new file mode 100644 index 0000000000..e69de29bb2 diff --git a/rust/run b/rust/run index 06764851ce..8ba68a5484 100755 --- a/rust/run +++ b/rust/run @@ -1,2 +1,2 @@ #!/bin/bash -exec $(dirname $0)/target/release/${STEP:-stepA_mal} "${@}" +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/rust/src/bin/step0_repl.rs b/rust/src/bin/step0_repl.rs deleted file mode 100644 index ba5f5fe08b..0000000000 --- a/rust/src/bin/step0_repl.rs +++ /dev/null @@ -1,26 +0,0 @@ -extern crate mal; - -use mal::readline; - -// read -fn read(str: String) -> String { - str -} - -// eval -fn eval(ast: String) -> String { - ast -} - -// print -fn print(exp: String) -> String { - exp -} - -fn main() { - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - println!("{}", print(eval(read(line.unwrap())))); - } -} diff --git a/rust/src/bin/step1_read_print.rs b/rust/src/bin/step1_read_print.rs deleted file mode 100644 index 02b2da7bf8..0000000000 --- a/rust/src/bin/step1_read_print.rs +++ /dev/null @@ -1,39 +0,0 @@ -extern crate mal; - -use mal::types::{MalVal, MalRet, MalError}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::{readline, reader}; - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn eval(ast: MalVal) -> MalRet { - Ok(ast) -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast)); - Ok(print(exp)) -} - -fn main() { - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step2_eval.rs b/rust/src/bin/step2_eval.rs deleted file mode 100644 index c807e3d73c..0000000000 --- a/rust/src/bin/step2_eval.rs +++ /dev/null @@ -1,114 +0,0 @@ -extern crate mal; - -use std::collections::HashMap; - -use mal::types::{MalVal, MalRet, MalError, err_str, err_string}; -use mal::types::{list, vector, hash_map, _int, func}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Sym, List, Vector, Hash_Map, Int}; -use mal::{readline, reader}; - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn eval_ast(ast: MalVal, env: &HashMap) -> MalRet { - match *ast { - Sym(ref sym) => { - match env.get(sym) { - Some(mv) => Ok(mv.clone()), - //None => Ok(_nil()), - None => err_string(format!("'{}' not found", sym)), - } - }, - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(ast: MalVal, env: &HashMap) -> MalRet { - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - match *try!(eval_ast(ast, env)) { - List(ref args,_) => { - match args.len() { - 0 => - Ok(list(vec![])), - _ => { - let ref f = args.clone()[0]; - f.apply(args[1..].to_vec()) - } - } - }, - _ => return err_str("Expected list"), - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: &HashMap) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn int_op(f: F, a:Vec) -> MalRet - where F: FnOnce(isize, isize) -> isize -{ - match *a[0] { - Int(a0) => match *a[1] { - Int(a1) => Ok(_int(f(a0,a1))), - _ => err_str("second arg must be an int"), - }, - _ => err_str("first arg must be an int"), - } -} -fn add(a:Vec) -> MalRet { int_op(|i,j| { i+j }, a) } -fn sub(a:Vec) -> MalRet { int_op(|i,j| { i-j }, a) } -fn mul(a:Vec) -> MalRet { int_op(|i,j| { i*j }, a) } -fn div(a:Vec) -> MalRet { int_op(|i,j| { i/j }, a) } - -fn main() { - let mut repl_env : HashMap = HashMap::new(); - repl_env.insert("+".to_string(), func(add)); - repl_env.insert("-".to_string(), func(sub)); - repl_env.insert("*".to_string(), func(mul)); - repl_env.insert("/".to_string(), func(div)); - - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), &repl_env) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step3_env.rs b/rust/src/bin/step3_env.rs deleted file mode 100644 index afadc178d8..0000000000 --- a/rust/src/bin/step3_env.rs +++ /dev/null @@ -1,165 +0,0 @@ -extern crate mal; - -use std::collections::HashMap; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _int, list, vector, hash_map, func}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Int, Sym, List, Vector, Hash_Map}; -use mal::{readline, reader}; -use mal::env::{Env, env_new, env_set, env_get}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(ast: MalVal, env: Env) -> MalRet { - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - match *ast { - List(_,_) => (), // continue - _ => return Ok(ast), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - return eval(a2, let_env.clone()); - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - let ref f = args.clone()[0]; - f.apply(args[1..].to_vec()) - }, - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn int_op(f: F, a:Vec) -> MalRet - where F: FnOnce(isize, isize) -> isize -{ - match *a[0] { - Int(a0) => match *a[1] { - Int(a1) => Ok(_int(f(a0,a1))), - _ => err_str("second arg must be an int"), - }, - _ => err_str("first arg must be an int"), - } -} -fn add(a:Vec) -> MalRet { int_op(|i,j| { i+j }, a) } -fn sub(a:Vec) -> MalRet { int_op(|i,j| { i-j }, a) } -fn mul(a:Vec) -> MalRet { int_op(|i,j| { i*j }, a) } -fn div(a:Vec) -> MalRet { int_op(|i,j| { i/j }, a) } - -fn main() { - let repl_env = env_new(None); - env_set(&repl_env, symbol("+"), func(add)); - env_set(&repl_env, symbol("-"), func(sub)); - env_set(&repl_env, symbol("*"), func(mul)); - env_set(&repl_env, symbol("/"), func(div)); - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step4_if_fn_do.rs b/rust/src/bin/step4_if_fn_do.rs deleted file mode 100644 index 2be0f6bd11..0000000000 --- a/rust/src/bin/step4_if_fn_do.rs +++ /dev/null @@ -1,185 +0,0 @@ -extern crate mal; - -use std::collections::HashMap; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, list, vector, hash_map, malfunc}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(ast: MalVal, env: Env) -> MalRet { - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - match *ast { - List(_,_) => (), // continue - _ => return Ok(ast), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - return eval(a2, let_env.clone()); - }, - "do" => { - let el = list(args[1..].to_vec()); - match *try!(eval_ast(el, env.clone())) { - List(ref lst,_) => { - let ref last = lst[lst.len()-1]; - return Ok(last.clone()); - } - _ => return err_str("invalid do call"), - } - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - let a3 = (*args)[3].clone(); - return eval(a3, env.clone()); - } else { - return Ok(_nil()); - } - }, - _ => { - let a2 = (*args)[2].clone(); - return eval(a2, env.clone()); - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - let ref f = args.clone()[0]; - f.apply(args[1..].to_vec()) - }, - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step5_tco.rs b/rust/src/bin/step5_tco.rs deleted file mode 100644 index 9a2a4ced0e..0000000000 --- a/rust/src/bin/step5_tco.rs +++ /dev/null @@ -1,202 +0,0 @@ -extern crate mal; - -use std::collections::HashMap; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, list, vector, hash_map, malfunc}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map, Func, MalFunc}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, env_bind, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - 'tco: loop { - - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - match *ast { - List(_,_) => (), // continue - _ => return Ok(ast), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - ast = a2; - env = let_env.clone(); - continue 'tco; - }, - "do" => { - let el = list(args[1..args.len()-1].to_vec()); - try!(eval_ast(el, env.clone())); - ast = args[args.len() - 1].clone(); - continue 'tco; - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - ast = args[3].clone(); - continue 'tco; - } else { - return Ok(_nil()); - } - }, - _ => { - ast = args[2].clone(); - continue 'tco; - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - return match *args.clone()[0] { - Func(f,_) => f(args[1..].to_vec()), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args[1..].to_vec()); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => { - ast = mfc.exp; - env = new_env; - continue 'tco; - }, - Err(e) => err_str(&e), - } - }, - _ => err_str("attempt to call non-function"), - } - }, - } - - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step6_file.rs b/rust/src/bin/step6_file.rs deleted file mode 100644 index c2f0d57754..0000000000 --- a/rust/src/bin/step6_file.rs +++ /dev/null @@ -1,232 +0,0 @@ - -extern crate mal; - -use std::collections::HashMap; -use std::env as stdenv; -use std::process as process; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, string, list, vector, hash_map, malfunc}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map, Func, MalFunc}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, env_bind, env_root, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - 'tco: loop { - - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - match *ast { - List(_,_) => (), // continue - _ => return Ok(ast), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - ast = a2; - env = let_env.clone(); - continue 'tco; - }, - "do" => { - let el = list(args[1..args.len()-1].to_vec()); - try!(eval_ast(el, env.clone())); - ast = args[args.len() - 1].clone(); - continue 'tco; - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - ast = args[3].clone(); - continue 'tco; - } else { - return Ok(_nil()); - } - }, - _ => { - ast = args[2].clone(); - continue 'tco; - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - "eval" => { - let a1 = (*args)[1].clone(); - ast = try!(eval(a1, env.clone())); - env = env_root(&env); - continue 'tco; - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - return match *args.clone()[0] { - Func(f,_) => f(args[1..].to_vec()), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args[1..].to_vec()); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => { - ast = mfc.exp; - env = new_env; - continue 'tco; - }, - Err(e) => err_str(&e), - } - }, - _ => err_str("attempt to call non-function"), - } - }, - } - - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - // see eval() for definition of "eval" - env_set(&repl_env, symbol("*ARGV*"), list(vec![])); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env.clone()); - - // Invoked with command line arguments - let args = stdenv::args(); - if args.len() > 1 { - let mv_args = args.skip(2) - .map(|a| string(a)) - .collect::>(); - env_set(&repl_env, symbol("*ARGV*"), list(mv_args)); - let lf = format!("(load-file \"{}\")", - stdenv::args().skip(1).next().unwrap()); - return match rep(&lf, repl_env.clone()) { - Ok(_) => process::exit(0), - Err(str) => { - println!("Error: {:?}", str); - process::exit(1); - } - }; - } - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step7_quote.rs b/rust/src/bin/step7_quote.rs deleted file mode 100644 index 7b0788db2d..0000000000 --- a/rust/src/bin/step7_quote.rs +++ /dev/null @@ -1,281 +0,0 @@ - -extern crate mal; - -use std::collections::HashMap; -use std::env as stdenv; -use std::process as process; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, string, list, vector, hash_map, malfunc}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map, Func, MalFunc}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, env_bind, env_root, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn is_pair(x: MalVal) -> bool { - match *x { - List(ref lst,_) | Vector(ref lst,_) => lst.len() > 0, - _ => false, - } -} - -fn quasiquote(ast: MalVal) -> MalVal { - if !is_pair(ast.clone()) { - return list(vec![symbol("quote"), ast]) - } - - match *ast.clone() { - List(ref args,_) | Vector(ref args,_) => { - let ref a0 = args[0]; - match **a0 { - Sym(ref s) if *s == "unquote" => return args[1].clone(), - _ => (), - } - if is_pair(a0.clone()) { - match **a0 { - List(ref a0args,_) | Vector(ref a0args,_) => { - match *a0args[0] { - Sym(ref s) if *s == "splice-unquote" => { - return list(vec![symbol("concat"), - a0args[1].clone(), - quasiquote(list(args[1..].to_vec()))]) - }, - _ => (), - } - }, - _ => (), - } - } - let rest = list(args[1..].to_vec()); - return list(vec![symbol("cons"), - quasiquote(a0.clone()), - quasiquote(rest)]) - }, - _ => _nil(), // should never reach - } -} - -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - 'tco: loop { - - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - match *ast { - List(_,_) => (), // continue - _ => return Ok(ast), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - ast = a2; - env = let_env.clone(); - continue 'tco; - }, - "quote" => return Ok((*args)[1].clone()), - "quasiquote" => { - let a1 = (*args)[1].clone(); - ast = quasiquote(a1); - continue 'tco; - }, - "do" => { - let el = list(args[1..args.len()-1].to_vec()); - try!(eval_ast(el, env.clone())); - ast = args[args.len() - 1].clone(); - continue 'tco; - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - ast = args[3].clone(); - continue 'tco; - } else { - return Ok(_nil()); - } - }, - _ => { - ast = args[2].clone(); - continue 'tco; - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - "eval" => { - let a1 = (*args)[1].clone(); - ast = try!(eval(a1, env.clone())); - env = env_root(&env); - continue 'tco; - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - return match *args.clone()[0] { - Func(f,_) => f(args[1..].to_vec()), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args[1..].to_vec()); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => { - ast = mfc.exp; - env = new_env; - continue 'tco; - }, - Err(e) => err_str(&e), - } - }, - _ => err_str("attempt to call non-function"), - } - }, - } - - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - // see eval() for definition of "eval" - env_set(&repl_env, symbol("*ARGV*"), list(vec![])); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env.clone()); - - // Invoked with command line arguments - let args = stdenv::args(); - if args.len() > 1 { - let mv_args = args.skip(2) - .map(|a| string(a)) - .collect::>(); - env_set(&repl_env, symbol("*ARGV*"), list(mv_args)); - let lf = format!("(load-file \"{}\")", - stdenv::args().skip(1).next().unwrap()); - return match rep(&lf, repl_env.clone()) { - Ok(_) => process::exit(0), - Err(str) => { - println!("Error: {:?}", str); - process::exit(1); - } - }; - } - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step8_macros.rs b/rust/src/bin/step8_macros.rs deleted file mode 100644 index ea52d42b5b..0000000000 --- a/rust/src/bin/step8_macros.rs +++ /dev/null @@ -1,350 +0,0 @@ - -extern crate mal; - -use std::collections::HashMap; -use std::env as stdenv; -use std::process as process; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, string, list, vector, hash_map, malfunc, malfuncd}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map, Func, MalFunc}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, env_bind, env_find, env_root, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn is_pair(x: MalVal) -> bool { - match *x { - List(ref lst,_) | Vector(ref lst,_) => lst.len() > 0, - _ => false, - } -} - -fn quasiquote(ast: MalVal) -> MalVal { - if !is_pair(ast.clone()) { - return list(vec![symbol("quote"), ast]) - } - - match *ast.clone() { - List(ref args,_) | Vector(ref args,_) => { - let ref a0 = args[0]; - match **a0 { - Sym(ref s) if *s == "unquote" => return args[1].clone(), - _ => (), - } - if is_pair(a0.clone()) { - match **a0 { - List(ref a0args,_) | Vector(ref a0args,_) => { - match *a0args[0] { - Sym(ref s) if *s == "splice-unquote" => { - return list(vec![symbol("concat"), - a0args[1].clone(), - quasiquote(list(args[1..].to_vec()))]) - }, - _ => (), - } - }, - _ => (), - } - } - let rest = list(args[1..].to_vec()); - return list(vec![symbol("cons"), - quasiquote(a0.clone()), - quasiquote(rest)]) - }, - _ => _nil(), // should never reach - } -} - -fn is_macro_call(ast: MalVal, env: Env) -> bool { - let lst = match *ast { - List(ref lst,_) => &lst[0], - _ => return false - }; - match **lst { - Sym(_) => {}, - _ => return false - } - if env_find(&env, lst).is_none() { - return false - } - let f = match env_get(&env, lst) { - Ok(f) => f, - _ => return false - }; - match *f { - MalFunc(ref mfd,_) => mfd.is_macro, - _ => false, - } -} - -fn macroexpand(mut ast: MalVal, env: Env) -> MalRet { - while is_macro_call(ast.clone(), env.clone()) { - let ast2 = ast.clone(); - let args = match *ast2 { - List(ref args,_) => args, - _ => break, - }; - let ref a0 = args[0]; - let mf = match **a0 { - Sym(_) => try!(env_get(&env, &a0)), - _ => break, - }; - match *mf { - MalFunc(_,_) => ast = try!(mf.apply(args[1..].to_vec())), - _ => break, - } - } - Ok(ast) -} - -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - 'tco: loop { - - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - ast = try!(macroexpand(ast, env.clone())); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - ast = a2; - env = let_env.clone(); - continue 'tco; - }, - "quote" => return Ok((*args)[1].clone()), - "quasiquote" => { - let a1 = (*args)[1].clone(); - ast = quasiquote(a1); - continue 'tco; - }, - "defmacro!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *r { - MalFunc(ref mfd,_) => { - match *a1 { - Sym(_) => { - let mut new_mfd = mfd.clone(); - new_mfd.is_macro = true; - let mf = malfuncd(new_mfd,_nil()); - env_set(&env.clone(), a1.clone(), mf.clone()); - return Ok(mf); - }, - _ => return err_str("def! of non-symbol"), - } - }, - _ => return err_str("def! of non-symbol"), - } - }, - "macroexpand" => { - let a1 = (*args)[1].clone(); - return macroexpand(a1, env.clone()) - }, - "do" => { - let el = list(args[1..args.len()-1].to_vec()); - try!(eval_ast(el, env.clone())); - ast = args[args.len() - 1].clone(); - continue 'tco; - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - ast = args[3].clone(); - continue 'tco; - } else { - return Ok(_nil()); - } - }, - _ => { - ast = args[2].clone(); - continue 'tco; - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - "eval" => { - let a1 = (*args)[1].clone(); - ast = try!(eval(a1, env.clone())); - env = env_root(&env); - continue 'tco; - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - return match *args.clone()[0] { - Func(f,_) => f(args[1..].to_vec()), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args[1..].to_vec()); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => { - ast = mfc.exp; - env = new_env; - continue 'tco; - }, - Err(e) => err_str(&e), - } - }, - _ => err_str("attempt to call non-function"), - } - }, - } - - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - // see eval() for definition of "eval" - env_set(&repl_env, symbol("*ARGV*"), list(vec![])); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env.clone()); - let _ = rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env.clone()); - let _ = rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", repl_env.clone()); - - // Invoked with command line arguments - let args = stdenv::args(); - if args.len() > 1 { - let mv_args = args.skip(2) - .map(|a| string(a)) - .collect::>(); - env_set(&repl_env, symbol("*ARGV*"), list(mv_args)); - let lf = format!("(load-file \"{}\")", - stdenv::args().skip(1).next().unwrap()); - return match rep(&lf, repl_env.clone()) { - Ok(_) => process::exit(0), - Err(str) => { - println!("Error: {:?}", str); - process::exit(1); - } - }; - } - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/step9_try.rs b/rust/src/bin/step9_try.rs deleted file mode 100644 index 10a70b0157..0000000000 --- a/rust/src/bin/step9_try.rs +++ /dev/null @@ -1,380 +0,0 @@ - -extern crate mal; - -use std::collections::HashMap; -use std::env as stdenv; -use std::process as process; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, string, list, vector, hash_map, malfunc, malfuncd}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map, Func, MalFunc}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, env_bind, env_find, env_root, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn is_pair(x: MalVal) -> bool { - match *x { - List(ref lst,_) | Vector(ref lst,_) => lst.len() > 0, - _ => false, - } -} - -fn quasiquote(ast: MalVal) -> MalVal { - if !is_pair(ast.clone()) { - return list(vec![symbol("quote"), ast]) - } - - match *ast.clone() { - List(ref args,_) | Vector(ref args,_) => { - let ref a0 = args[0]; - match **a0 { - Sym(ref s) if *s == "unquote" => return args[1].clone(), - _ => (), - } - if is_pair(a0.clone()) { - match **a0 { - List(ref a0args,_) | Vector(ref a0args,_) => { - match *a0args[0] { - Sym(ref s) if *s == "splice-unquote" => { - return list(vec![symbol("concat"), - a0args[1].clone(), - quasiquote(list(args[1..].to_vec()))]) - }, - _ => (), - } - }, - _ => (), - } - } - let rest = list(args[1..].to_vec()); - return list(vec![symbol("cons"), - quasiquote(a0.clone()), - quasiquote(rest)]) - }, - _ => _nil(), // should never reach - } -} - -fn is_macro_call(ast: MalVal, env: Env) -> bool { - let lst = match *ast { - List(ref lst,_) => &lst[0], - _ => return false - }; - match **lst { - Sym(_) => {}, - _ => return false - } - if env_find(&env, lst).is_none() { - return false - } - let f = match env_get(&env, lst) { - Ok(f) => f, - _ => return false - }; - match *f { - MalFunc(ref mfd,_) => mfd.is_macro, - _ => false, - } -} - -fn macroexpand(mut ast: MalVal, env: Env) -> MalRet { - while is_macro_call(ast.clone(), env.clone()) { - let ast2 = ast.clone(); - let args = match *ast2 { - List(ref args,_) => args, - _ => break, - }; - let ref a0 = args[0]; - let mf = match **a0 { - Sym(_) => try!(env_get(&env, &a0)), - _ => break, - }; - match *mf { - MalFunc(_,_) => ast = try!(mf.apply(args[1..].to_vec())), - _ => break, - } - } - Ok(ast) -} - -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - 'tco: loop { - - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - ast = try!(macroexpand(ast, env.clone())); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - ast = a2; - env = let_env.clone(); - continue 'tco; - }, - "quote" => return Ok((*args)[1].clone()), - "quasiquote" => { - let a1 = (*args)[1].clone(); - ast = quasiquote(a1); - continue 'tco; - }, - "defmacro!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *r { - MalFunc(ref mfd,_) => { - match *a1 { - Sym(_) => { - let mut new_mfd = mfd.clone(); - new_mfd.is_macro = true; - let mf = malfuncd(new_mfd,_nil()); - env_set(&env.clone(), a1.clone(), mf.clone()); - return Ok(mf); - }, - _ => return err_str("def! of non-symbol"), - } - }, - _ => return err_str("def! of non-symbol"), - } - }, - "macroexpand" => { - let a1 = (*args)[1].clone(); - return macroexpand(a1, env.clone()) - }, - "try*" => { - let a1 = (*args)[1].clone(); - match eval(a1, env.clone()) { - Ok(res) => return Ok(res), - Err(err) => { - if args.len() < 3 { return Err(err); } - let a2 = (*args)[2].clone(); - let cat = match *a2 { - List(ref cat,_) => cat, - _ => return err_str("invalid catch* clause"), - }; - if cat.len() != 3 { - return err_str("wrong arity to catch* clause"); - } - let c1 = (*cat)[1].clone(); - match *c1 { - Sym(_) => {}, - _ => return err_str("invalid catch* binding"), - }; - let exc = match err { - ErrMalVal(mv) => mv, - ErrString(s) => string(s), - }; - let bind_env = env_new(Some(env.clone())); - env_set(&bind_env, c1.clone(), exc); - let c2 = (*cat)[2].clone(); - return eval(c2, bind_env); - }, - }; - } - "do" => { - let el = list(args[1..args.len()-1].to_vec()); - try!(eval_ast(el, env.clone())); - ast = args[args.len() - 1].clone(); - continue 'tco; - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - ast = args[3].clone(); - continue 'tco; - } else { - return Ok(_nil()); - } - }, - _ => { - ast = args[2].clone(); - continue 'tco; - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - "eval" => { - let a1 = (*args)[1].clone(); - ast = try!(eval(a1, env.clone())); - env = env_root(&env); - continue 'tco; - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - return match *args.clone()[0] { - Func(f,_) => f(args[1..].to_vec()), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args[1..].to_vec()); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => { - ast = mfc.exp; - env = new_env; - continue 'tco; - }, - Err(e) => err_str(&e), - } - }, - _ => err_str("attempt to call non-function"), - } - }, - } - - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - // see eval() for definition of "eval" - env_set(&repl_env, symbol("*ARGV*"), list(vec![])); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env.clone()); - let _ = rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env.clone()); - let _ = rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", repl_env.clone()); - - // Invoked with command line arguments - let args = stdenv::args(); - if args.len() > 1 { - let mv_args = args.skip(2) - .map(|a| string(a)) - .collect::>(); - env_set(&repl_env, symbol("*ARGV*"), list(mv_args)); - let lf = format!("(load-file \"{}\")", - stdenv::args().skip(1).next().unwrap()); - return match rep(&lf, repl_env.clone()) { - Ok(_) => process::exit(0), - Err(str) => { - println!("Error: {:?}", str); - process::exit(1); - } - }; - } - - // repl loop - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/bin/stepA_mal.rs b/rust/src/bin/stepA_mal.rs deleted file mode 100644 index 59b966e5a4..0000000000 --- a/rust/src/bin/stepA_mal.rs +++ /dev/null @@ -1,385 +0,0 @@ -#![allow(non_snake_case)] - -extern crate mal; - -use std::collections::HashMap; -use std::env as stdenv; -use std::process as process; - -use mal::types::{MalVal, MalRet, MalError, err_str}; -use mal::types::{symbol, _nil, string, list, vector, hash_map, malfunc, malfuncd}; -use mal::types::MalError::{ErrString, ErrMalVal}; -use mal::types::MalType::{Nil, False, Sym, List, Vector, Hash_Map, Func, MalFunc}; -use mal::{readline, reader, core}; -use mal::env::{env_set, env_get, env_new, env_bind, env_find, env_root, Env}; - - -// read -fn read(str: String) -> MalRet { - reader::read_str(str) -} - -// eval -fn is_pair(x: MalVal) -> bool { - match *x { - List(ref lst,_) | Vector(ref lst,_) => lst.len() > 0, - _ => false, - } -} - -fn quasiquote(ast: MalVal) -> MalVal { - if !is_pair(ast.clone()) { - return list(vec![symbol("quote"), ast]) - } - - match *ast.clone() { - List(ref args,_) | Vector(ref args,_) => { - let ref a0 = args[0]; - match **a0 { - Sym(ref s) if *s == "unquote" => return args[1].clone(), - _ => (), - } - if is_pair(a0.clone()) { - match **a0 { - List(ref a0args,_) | Vector(ref a0args,_) => { - match *a0args[0] { - Sym(ref s) if *s == "splice-unquote" => { - return list(vec![symbol("concat"), - a0args[1].clone(), - quasiquote(list(args[1..].to_vec()))]) - }, - _ => (), - } - }, - _ => (), - } - } - let rest = list(args[1..].to_vec()); - return list(vec![symbol("cons"), - quasiquote(a0.clone()), - quasiquote(rest)]) - }, - _ => _nil(), // should never reach - } -} - -fn is_macro_call(ast: MalVal, env: Env) -> bool { - let lst = match *ast { - List(ref lst,_) => &lst[0], - _ => return false - }; - match **lst { - Sym(_) => {}, - _ => return false - } - if env_find(&env, lst).is_none() { - return false - } - let f = match env_get(&env, lst) { - Ok(f) => f, - _ => return false - }; - match *f { - MalFunc(ref mfd,_) => mfd.is_macro, - _ => false, - } -} - -fn macroexpand(mut ast: MalVal, env: Env) -> MalRet { - while is_macro_call(ast.clone(), env.clone()) { - let ast2 = ast.clone(); - let args = match *ast2 { - List(ref args,_) => args, - _ => break, - }; - let ref a0 = args[0]; - let mf = match **a0 { - Sym(_) => try!(env_get(&env, &a0)), - _ => break, - }; - match *mf { - MalFunc(_,_) => ast = try!(mf.apply(args[1..].to_vec())), - _ => break, - } - } - Ok(ast) -} - -fn eval_ast(ast: MalVal, env: Env) -> MalRet { - match *ast { - Sym(_) => env_get(&env, &ast), - List(ref a,_) | Vector(ref a,_) => { - let mut ast_vec : Vec = vec![]; - for mv in a.iter() { - let mv2 = mv.clone(); - ast_vec.push(try!(eval(mv2, env.clone()))); - } - Ok(match *ast { List(_,_) => list(ast_vec), - _ => vector(ast_vec) }) - } - Hash_Map(ref hm,_) => { - let mut new_hm: HashMap = HashMap::new(); - for (key, value) in hm.iter() { - new_hm.insert(key.to_string(), - try!(eval(value.clone(), env.clone()))); - } - Ok(hash_map(new_hm)) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - 'tco: loop { - - //println!("eval: {}, {}", ast, env.borrow()); - //println!("eval: {}", ast); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - // apply list - ast = try!(macroexpand(ast, env.clone())); - match *ast { - List(_,_) => (), // continue - _ => return eval_ast(ast, env), - } - - let tmp = ast; - let (args, a0sym) = match *tmp { - List(ref args,_) => { - if args.len() == 0 { - return Ok(tmp.clone()); - } - let ref a0 = *args[0]; - match *a0 { - Sym(ref a0sym) => (args, &a0sym[..]), - _ => (args, "____"), - } - }, - _ => return err_str("Expected list"), - }; - - match a0sym { - "def!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *a1 { - Sym(_) => { - env_set(&env.clone(), a1, r.clone()); - return Ok(r); - }, - _ => return err_str("def! of non-symbol"), - } - }, - "let*" => { - let let_env = env_new(Some(env.clone())); - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - match *a1 { - List(ref binds,_) | Vector(ref binds,_) => { - let mut it = binds.iter(); - while it.len() >= 2 { - let b = it.next().unwrap(); - let exp = it.next().unwrap(); - match **b { - Sym(_) => { - let r = try!(eval(exp.clone(), let_env.clone())); - env_set(&let_env, b.clone(), r); - }, - _ => return err_str("let* with non-symbol binding"), - } - } - }, - _ => return err_str("let* with non-list bindings"), - } - ast = a2; - env = let_env.clone(); - continue 'tco; - }, - "quote" => return Ok((*args)[1].clone()), - "quasiquote" => { - let a1 = (*args)[1].clone(); - ast = quasiquote(a1); - continue 'tco; - }, - "defmacro!" => { - let a1 = (*args)[1].clone(); - let a2 = (*args)[2].clone(); - let r = try!(eval(a2, env.clone())); - match *r { - MalFunc(ref mfd,_) => { - match *a1 { - Sym(_) => { - let mut new_mfd = mfd.clone(); - new_mfd.is_macro = true; - let mf = malfuncd(new_mfd,_nil()); - env_set(&env.clone(), a1.clone(), mf.clone()); - return Ok(mf); - }, - _ => return err_str("def! of non-symbol"), - } - }, - _ => return err_str("def! of non-symbol"), - } - }, - "macroexpand" => { - let a1 = (*args)[1].clone(); - return macroexpand(a1, env.clone()) - }, - "try*" => { - let a1 = (*args)[1].clone(); - match eval(a1, env.clone()) { - Ok(res) => return Ok(res), - Err(err) => { - if args.len() < 3 { return Err(err); } - let a2 = (*args)[2].clone(); - let cat = match *a2 { - List(ref cat,_) => cat, - _ => return err_str("invalid catch* clause"), - }; - if cat.len() != 3 { - return err_str("wrong arity to catch* clause"); - } - let c1 = (*cat)[1].clone(); - match *c1 { - Sym(_) => {}, - _ => return err_str("invalid catch* binding"), - }; - let exc = match err { - ErrMalVal(mv) => mv, - ErrString(s) => string(s), - }; - let bind_env = env_new(Some(env.clone())); - env_set(&bind_env, c1.clone(), exc); - let c2 = (*cat)[2].clone(); - return eval(c2, bind_env); - }, - }; - } - "do" => { - let el = list(args[1..args.len()-1].to_vec()); - try!(eval_ast(el, env.clone())); - ast = args[args.len() - 1].clone(); - continue 'tco; - }, - "if" => { - let a1 = (*args)[1].clone(); - let c = try!(eval(a1, env.clone())); - match *c { - False | Nil => { - if args.len() >= 4 { - ast = args[3].clone(); - continue 'tco; - } else { - return Ok(_nil()); - } - }, - _ => { - ast = args[2].clone(); - continue 'tco; - }, - } - }, - "fn*" => { - let a1 = args[1].clone(); - let a2 = args[2].clone(); - return Ok(malfunc(eval, a2, env, a1, _nil())); - }, - "eval" => { - let a1 = (*args)[1].clone(); - ast = try!(eval(a1, env.clone())); - env = env_root(&env); - continue 'tco; - }, - _ => { // function call - let el = try!(eval_ast(tmp.clone(), env.clone())); - let args = match *el { - List(ref args,_) => args, - _ => return err_str("Invalid apply"), - }; - return match *args.clone()[0] { - Func(f,_) => f(args[1..].to_vec()), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args[1..].to_vec()); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => { - ast = mfc.exp; - env = new_env; - continue 'tco; - }, - Err(e) => err_str(&e), - } - }, - _ => err_str("attempt to call non-function"), - } - }, - } - - } -} - -// print -fn print(exp: MalVal) -> String { - exp.pr_str(true) -} - -fn rep(str: &str, env: Env) -> Result { - let ast = try!(read(str.to_string())); - //println!("read: {}", ast); - let exp = try!(eval(ast, env)); - Ok(print(exp)) -} - -fn main() { - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns().into_iter() { - env_set(&repl_env, symbol(&k), v); - } - // see eval() for definition of "eval" - env_set(&repl_env, symbol("*ARGV*"), list(vec![])); - - // core.mal: defined using the language itself - let _ = rep("(def! *host-language* \"rust\")", repl_env.clone()); - let _ = rep("(def! not (fn* (a) (if a false true)))", repl_env.clone()); - let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", repl_env.clone()); - let _ = rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", repl_env.clone()); - let _ = rep("(def! *gensym-counter* (atom 0))", repl_env.clone()); - let _ = rep("(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))", repl_env.clone()); - let _ = rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", repl_env.clone()); - - // Invoked with command line arguments - let args = stdenv::args(); - if args.len() > 1 { - let mv_args = args.skip(2) - .map(|a| string(a)) - .collect::>(); - env_set(&repl_env, symbol("*ARGV*"), list(mv_args)); - let lf = format!("(load-file \"{}\")", - stdenv::args().skip(1).next().unwrap()); - return match rep(&lf, repl_env.clone()) { - Ok(_) => process::exit(0), - Err(str) => { - println!("Error: {:?}", str); - process::exit(1); - } - }; - } - - // repl loop - let _ = rep("(println (str \"Mal [\" *host-language* \"]\"))", repl_env.clone()); - loop { - let line = readline::mal_readline("user> "); - match line { None => break, _ => () } - match rep(&line.unwrap(), repl_env.clone()) { - Ok(str) => println!("{}", str), - Err(ErrMalVal(_)) => (), // Blank line - Err(ErrString(s)) => println!("Error: {}", s), - } - } -} diff --git a/rust/src/core.rs b/rust/src/core.rs deleted file mode 100644 index a598f6cf17..0000000000 --- a/rust/src/core.rs +++ /dev/null @@ -1,560 +0,0 @@ -#![allow(dead_code)] - -use std::collections::HashMap; -use std::fs::File; -use std::io::prelude::*; -//use std::num::ToPrimitive; -use num::traits::ToPrimitive; -use time; - -use types::{MalVal,MalRet,err_val,err_str,err_string, - _nil,_true,_false,_int,string, - list,vector,listm,vectorm,hash_mapm,func,funcm,malfuncd}; -use types::MalType::{Nil, Int, Strn, List, Vector, Hash_Map, Func, MalFunc, Atom}; -use types; -use readline; -use reader; -use printer; - -// General functions -fn equal_q(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to equal? call"); - } - if a[0] == a[1] {Ok(_true())} else {Ok(_false())} -} - -// Errors/Exceptions -fn throw(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to throw call"); - } - err_val(a[0].clone()) -} - -// String routines -fn pr_str(a: Vec) -> MalRet { - Ok(string(printer::pr_list(&a, true, "", "", " "))) -} - -fn str(a: Vec) -> MalRet { - Ok(string(printer::pr_list(&a, false, "", "", ""))) -} - -fn prn(a: Vec) -> MalRet { - println!("{}", printer::pr_list(&a, true, "", "", " ")); - Ok(_nil()) -} - -fn println(a: Vec) -> MalRet { - println!("{}", printer::pr_list(&a, false, "", "", " ")); - Ok(_nil()) -} - -fn readline(a: Vec) -> MalRet { - match *a[0] { - Strn(ref a0) => match readline::mal_readline(&a0) { - Some(line) => Ok(string(line)), - None => err_val(_nil()), - }, - _ => err_str("read_string called with non-string"), - } -} - -fn read_string(a: Vec) -> MalRet { - match *a[0] { - Strn(ref a0) => reader::read_str(a0.to_string()), - _ => err_str("read_string called with non-string"), - } -} - -fn slurp(a: Vec) -> MalRet { - match *a[0] { - Strn(ref a0) => { - let mut s = String::new(); - match File::open(a0).and_then(|mut f| f.read_to_string(&mut s)) { - Ok(_) => Ok(string(s)), - Err(e) => err_string(e.to_string()), - } - }, - _ => err_str("slurp called with non-string"), - } -} - - -// Numeric functions -fn int_op(f: F, a: Vec) -> MalRet - where F: FnOnce(isize, isize) -> isize -{ - match *a[0] { - Int(a0) => match *a[1] { - Int(a1) => Ok(_int(f(a0,a1))), - _ => err_str("second arg must be an int"), - }, - _ => err_str("first arg must be an int"), - } -} - -fn bool_op(f: F, a: Vec) -> MalRet - where F: FnOnce(isize, isize) -> bool -{ - match *a[0] { - Int(a0) => match *a[1] { - Int(a1) => { - match f(a0,a1) { - true => Ok(_true()), - false => Ok(_false()), - } - }, - _ => err_str("second arg must be an int"), - }, - _ => err_str("first arg must be an int"), - } -} - -pub fn add(a: Vec) -> MalRet { int_op(|i,j| { i+j }, a) } -pub fn sub(a: Vec) -> MalRet { int_op(|i,j| { i-j }, a) } -pub fn mul(a: Vec) -> MalRet { int_op(|i,j| { i*j }, a) } -pub fn div(a: Vec) -> MalRet { int_op(|i,j| { i/j }, a) } - -pub fn lt (a: Vec) -> MalRet { bool_op(|i,j| { i) -> MalRet { bool_op(|i,j| { i<=j }, a) } -pub fn gt (a: Vec) -> MalRet { bool_op(|i,j| { i>j }, a) } -pub fn gte(a: Vec) -> MalRet { bool_op(|i,j| { i>=j }, a) } - -pub fn time_ms(_a: Vec) -> MalRet { - //let x = time::now(); - let now = time::get_time(); - let now_ms = (now.sec * 1000).to_isize().unwrap() + - (now.nsec.to_isize().unwrap() / 1000000); - Ok(_int(now_ms)) -} - - -// Hash Map functions -pub fn assoc(a: Vec) -> MalRet { - if a.len() < 3 { - return err_str("Wrong arity to assoc call"); - } - match *a[0] { - Hash_Map(ref hm,_) => types::_assoc(hm, a[1..].to_vec()), - Nil => types::hash_mapv(a[1..].to_vec()), - _ => err_str("assoc onto non-hash map"), - } -} - -pub fn dissoc(a: Vec) -> MalRet { - if a.len() < 2 { - return err_str("Wrong arity to dissoc call"); - } - match *a[0] { - Hash_Map(ref hm,_) => types::_dissoc(hm, a[1..].to_vec()), - Nil => Ok(_nil()), - _ => err_str("dissoc onto non-hash map"), - } -} - -pub fn get(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to get call"); - } - let hm = match *a[0] { - Hash_Map(ref hm,_) => hm, - Nil => return Ok(_nil()), - _ => return err_str("get on non-hash map"), - }; - match *a[1] { - Strn(ref key) => { - match hm.get(key) { - Some(v) => Ok(v.clone()), - None => Ok(_nil()), - } - }, - _ => err_str("get with non-string key"), - } -} - -pub fn contains_q(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to contains? call"); - } - let hm = match *a[0] { - Hash_Map(ref hm,_) => hm, - Nil => return Ok(_false()), - _ => return err_str("contains? on non-hash map"), - }; - match *a[1] { - Strn(ref key) => { - match hm.contains_key(key) { - true => Ok(_true()), - false => Ok(_false()), - } - } - _ => err_str("contains? with non-string key"), - } -} - -pub fn keys(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to keys call"); - } - let hm = match *a[0] { - Hash_Map(ref hm,_) => hm, - Nil => return Ok(_nil()), - _ => return err_str("contains? on non-hash map"), - }; - Ok(list(hm.keys().map(|s| string(s.to_string())).collect())) -} - -pub fn vals(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to values call"); - } - let hm = match *a[0] { - Hash_Map(ref hm,_) => hm, - Nil => return Ok(_nil()), - _ => return err_str("contains? on non-hash map"), - }; - Ok(list(hm.values().map(|s| s.clone()).collect())) -} - -// Sequence functions -pub fn cons(a: Vec) -> MalRet { - match *a[1] { - List(ref v,_) | Vector(ref v,_) => { - let mut new_v = v.clone(); - new_v.insert(0, a[0].clone()); - Ok(list(new_v)) - }, - _ => err_str("Second arg to cons not a sequence"), - } -} - -pub fn concat(a: Vec) -> MalRet { - let mut new_v: Vec = vec![]; - for lst in a.iter() { - match **lst { - List(ref l,_) | Vector(ref l,_) => new_v.extend(l.clone()), - _ => return err_str("concat called with non-sequence"), - } - } - Ok(list(new_v)) -} - -pub fn nth(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to nth call"); - } - let seq = match *a[0] { - List(ref v,_) | Vector(ref v,_) => v, - _ => return err_str("nth called with non-sequence"), - }; - let idx = match *a[1] { - Int(i) => { - match i.to_usize() { - Some(ui) => ui, - None => return Ok(_nil()), - } - }, - _ => return err_str("nth called with non-integer index"), - }; - if idx >= seq.len() { - err_str("nth: index out of range") - } else { - Ok(seq[idx].clone()) - } -} - -pub fn first(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to first call"); - } - let seq = match *a[0] { - List(ref v,_) | Vector(ref v,_) => v, - Nil => return Ok(_nil()), - _ => return err_str("first called with non-sequence"), - }; - if seq.len() == 0 { - Ok(_nil()) - } else { - Ok(seq[0].clone()) - } -} - -pub fn rest(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to rest call"); - } - let seq = match *a[0] { - List(ref v,_) | Vector(ref v,_) => v, - Nil => return Ok(list(vec![])), - _ => return err_str("rest called with non-sequence"), - }; - if seq.len() == 0 { - Ok(list(vec![])) - } else { - Ok(list(seq[1..].to_vec())) - } -} - -pub fn empty_q(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to empty? call"); - } - match *a[0] { - List(ref v,_) | Vector(ref v,_) => { - match v.len() { - 0 => Ok(_true()), - _ => Ok(_false()), - } - }, - _ => err_str("empty? called on non-sequence"), - } -} - -pub fn count(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to count call"); - } - match *a[0] { - List(ref v,_) | Vector(ref v,_) => Ok(_int(v.len().to_isize().unwrap())), - Nil => Ok(_int(0)), - _ => err_str("count called on non-sequence"), - } -} - -pub fn apply(a: Vec) -> MalRet { - if a.len() < 2 { - return err_str("apply call needs 2 or more arguments"); - } - let ref f = a[0]; - let mut args = a[1..a.len()-1].to_vec(); - match *a[a.len()-1] { - List(ref v, _) | Vector(ref v, _) => { - args.extend(v.clone()); - f.apply(args) - }, - _ => err_str("apply call with non-sequence"), - } -} - -pub fn map(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to map call"); - } - let mut results:Vec = vec![]; - match *a[1] { - List(ref v,_) | Vector(ref v,_) => { - for mv in v.iter() { - let res = try!(a[0].apply(vec![mv.clone()])); - results.push(res); - } - }, - _ => return err_str("map call with non-sequence"), - } - Ok(list(results)) -} - -pub fn conj(a: Vec) -> MalRet { - if a.len() < 2 { - return err_str("Wrong arity to conj call"); - } - let mut new_v: Vec = vec![]; - match *a[0] { - List(ref l,_) => { - new_v.extend(l.clone()); - for mv in a.iter().skip(1) { - new_v.insert(0, mv.clone()); - } - Ok(list(new_v)) - } - Vector(ref l,_) => { - new_v.extend(l.clone()); - for mv in a.iter().skip(1) { - new_v.push(mv.clone()); - } - Ok(vector(new_v)) - } - _ => err_str("conj called with non-sequence"), - } -} - -pub fn seq(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to seq call"); - } - let mut new_v: Vec = vec![]; - match *a[0] { - List(ref l,_) | - Vector(ref l,_) => { - if l.len() == 0 { - Ok(_nil()) - } else { - new_v.extend(l.clone()); - Ok(list(new_v)) - } - }, - Strn(ref s) => { - if s.len() == 0 { - Ok(_nil()) - } else if s.starts_with("\u{29e}") { - err_str("seq: called with non-sequence") - } else { - for c in s.chars() { - new_v.push(string(c.to_string())); - } - Ok(list(new_v)) - } - }, - Nil => Ok(_nil()), - _ => err_str("seq: called with non-sequence"), - } -} - - - -// Metadata functions -fn with_meta(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to with-meta call"); - } - let meta = a[1].clone(); - match *a[0] { - List(ref v,_) => Ok(listm(v.clone(), meta)), - Vector(ref v,_) => Ok(vectorm(v.clone(), meta)), - Hash_Map(ref hm,_) => Ok(hash_mapm(hm.clone(), meta)), - MalFunc(ref mfd,_) => Ok(malfuncd(mfd.clone(), meta)), - Func(f,_) => Ok(funcm(f, meta)), - _ => err_str("type does not support metadata"), - } -} - -fn meta(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to meta call"); - } - match *a[0] { - List(_,ref meta) | - Vector(_,ref meta) | - Hash_Map(_,ref meta) | - MalFunc(_,ref meta) | - Func(_,ref meta) => Ok(meta.clone()), - _ => err_str("type does not support metadata"), - } -} - -// Atom functions -fn deref(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to deref call"); - } - match *a[0] { - Atom(ref val) => Ok(val.borrow().clone()), - _ => err_str("deref called on non-atom"), - } -} - -fn reset_bang(a: Vec) -> MalRet { - if a.len() != 2 { - return err_str("Wrong arity to map call"); - } - match *a[0] { - Atom(ref val) => { - let mut val_cell = val.borrow_mut(); - *val_cell = a[1].clone(); - Ok(a[1].clone()) - }, - _ => err_str("reset! called on non-atom"), - } -} - -fn swap_bang(a: Vec) -> MalRet { - if a.len() < 2 { - return err_str("Wrong arity to swap_q call"); - } - let f = a[1].clone(); - match *a[0] { - Atom(ref val) => { - let mut val_cell = val.borrow_mut(); - let mut args = a[2..].to_vec(); - args.insert(0, val_cell.clone()); - *val_cell = try!(f.apply(args)); - Ok(val_cell.clone()) - }, - _ => err_str("swap! called on non-atom"), - } -} - - -pub fn ns() -> HashMap { - let mut ns = HashMap::new();; - - ns.insert("=".to_string(), func(equal_q)); - ns.insert("throw".to_string(), func(throw)); - ns.insert("nil?".to_string(), func(types::nil_q)); - ns.insert("true?".to_string(), func(types::true_q)); - ns.insert("false?".to_string(), func(types::false_q)); - ns.insert("string?".to_string(), func(types::string_q)); - ns.insert("symbol".to_string(), func(types::_symbol)); - ns.insert("symbol?".to_string(), func(types::symbol_q)); - ns.insert("keyword".to_string(), func(types::_keyword)); - ns.insert("keyword?".to_string(), func(types::keyword_q)); - ns.insert("number?".to_string(), func(types::int_q)); - ns.insert("fn?".to_string(), func(types::fn_q)); - ns.insert("macro?".to_string(), func(types::macro_q)); - - ns.insert("pr-str".to_string(), func(pr_str)); - ns.insert("str".to_string(), func(str)); - ns.insert("prn".to_string(), func(prn)); - ns.insert("println".to_string(), func(println)); - ns.insert("readline".to_string(), func(readline)); - ns.insert("read-string".to_string(), func(read_string)); - ns.insert("slurp".to_string(), func(slurp)); - - ns.insert("<".to_string(), func(lt)); - ns.insert("<=".to_string(), func(lte)); - ns.insert(">".to_string(), func(gt)); - ns.insert(">=".to_string(), func(gte)); - ns.insert("+".to_string(), func(add)); - ns.insert("-".to_string(), func(sub)); - ns.insert("*".to_string(), func(mul)); - ns.insert("/".to_string(), func(div)); - ns.insert("time-ms".to_string(), func(time_ms)); - - ns.insert("list".to_string(), func(types::listv)); - ns.insert("list?".to_string(), func(types::list_q)); - ns.insert("vector".to_string(), func(types::vectorv)); - ns.insert("vector?".to_string(), func(types::vector_q)); - ns.insert("hash-map".to_string(), func(types::hash_mapv)); - ns.insert("map?".to_string(), func(types::hash_map_q)); - ns.insert("assoc".to_string(), func(assoc)); - ns.insert("dissoc".to_string(), func(dissoc)); - ns.insert("get".to_string(), func(get)); - ns.insert("contains?".to_string(), func(contains_q)); - ns.insert("keys".to_string(), func(keys)); - ns.insert("vals".to_string(), func(vals)); - - ns.insert("sequential?".to_string(), func(types::sequential_q)); - ns.insert("cons".to_string(), func(cons)); - ns.insert("concat".to_string(), func(concat)); - ns.insert("empty?".to_string(), func(empty_q)); - ns.insert("nth".to_string(), func(nth)); - ns.insert("first".to_string(), func(first)); - ns.insert("rest".to_string(), func(rest)); - ns.insert("count".to_string(), func(count)); - ns.insert("apply".to_string(), func(apply)); - ns.insert("map".to_string(), func(map)); - - ns.insert("conj".to_string(), func(conj)); - ns.insert("seq".to_string(), func(seq)); - - ns.insert("with-meta".to_string(), func(with_meta)); - ns.insert("meta".to_string(), func(meta)); - ns.insert("atom".to_string(), func(types::atom)); - ns.insert("atom?".to_string(), func(types::atom_q)); - ns.insert("deref".to_string(), func(deref)); - ns.insert("reset!".to_string(), func(reset_bang)); - ns.insert("swap!".to_string(), func(swap_bang)); - - return ns; -} diff --git a/rust/src/env.rs b/rust/src/env.rs deleted file mode 100644 index a1588065ae..0000000000 --- a/rust/src/env.rs +++ /dev/null @@ -1,106 +0,0 @@ -use std::rc::Rc; -use std::cell::RefCell; -use std::collections::HashMap; - -use types::{MalVal, MalRet, _nil, list, err_string}; -use types::MalType::{Sym, List, Vector}; - -pub struct EnvType { - data: HashMap, - outer: Option, -} - -pub type Env = Rc>; - -pub fn env_new(outer: Option) -> Env { - Rc::new(RefCell::new(EnvType{data: HashMap::new(), outer: outer})) -} - -pub fn env_bind(env: &Env, - mbinds: MalVal, - mexprs: MalVal) -> Result { - let mut variadic = false; - match *mbinds { - List(ref binds,_) | Vector(ref binds,_) => { - match *mexprs { - List(ref exprs,_) | Vector(ref exprs,_) => { - let mut it = binds.iter().enumerate(); - for (i, b) in it.by_ref() { - match **b { - Sym(ref strn) => { - if *strn == "&" { - variadic = true; - break; - } else { - env_set(env, b.clone(), exprs[i].clone()); - } - } - _ => return Err("non-symbol bind".to_string()), - } - } - if variadic { - let (i, sym) = it.next().unwrap(); - match **sym { - Sym(_) => { - let rest = exprs[i-1..].to_vec(); - env_set(env, sym.clone(), list(rest)); - } - _ => return Err("& bind to non-symbol".to_string()), - } - } - Ok(env.clone()) - }, - _ => Err("exprs must be a list".to_string()), - } - }, - _ => Err("binds must be a list".to_string()), - } -} - -pub fn env_find(env: &Env, key: &MalVal) -> Option { - match **key { - Sym(ref k) => { - let map = env.borrow(); - if map.data.contains_key(k) { - Some(env.clone()) - } else { - match map.outer { - Some(ref e) => env_find(e, key), - None => None, - } - } - }, - _ => None - } -} - -pub fn env_root(env: &Env) -> Env { - match env.borrow().outer { - Some(ref ei) => env_root(ei), - None => env.clone(), - } -} - -pub fn env_set(env: &Env, key: MalVal, val: MalVal) { - match *key { - Sym(ref k) => { env.borrow_mut().data.insert(k.to_string(), val); } - _ => {}, - } -} - -pub fn env_get(env: &Env, key: &MalVal) -> MalRet { - match **key { - Sym(ref k) => { - match env_find(env, key) { - Some(e) => { - match e.borrow().data.get(k) { - Some(v) => Ok(v.clone()), - None => Ok(_nil()), - } - }, - None => err_string(format!("'{}' not found", k)), - } - } - _ => err_string("env_get called with non-symbol key".to_string()), - } -} diff --git a/rust/src/lib.rs b/rust/src/lib.rs deleted file mode 100644 index 0961bcc3e3..0000000000 --- a/rust/src/lib.rs +++ /dev/null @@ -1,15 +0,0 @@ -extern crate libc; -extern crate regex; -extern crate time; -extern crate num; - -macro_rules! regex { - ($e:expr) => (::regex::Regex::new($e).unwrap()) -} - -pub mod core; -pub mod env; -pub mod printer; -pub mod reader; -pub mod readline; -pub mod types; diff --git a/rust/src/printer.rs b/rust/src/printer.rs deleted file mode 100644 index 1bb11e3c27..0000000000 --- a/rust/src/printer.rs +++ /dev/null @@ -1,47 +0,0 @@ -use types::MalVal; -use regex::Captures; - -pub fn escape_str(s: &str) -> String { - let mut escaped = String::new(); - escaped.push('"'); - for c in s.chars() { - let _ = match c { - '"' => escaped.push_str("\\\""), - '\\' => escaped.push_str("\\\\"), - '\x08' => escaped.push_str("\\b"), - '\x0c' => escaped.push_str("\\f"), - '\n' => escaped.push_str("\\n"), - '\r' => escaped.push_str("\\r"), - '\t' => escaped.push_str("\\t"), - _ => escaped.push(c), - }; - }; - - escaped.push('"'); - - escaped -} - -pub fn unescape_str(s: &str) -> String { - let re = regex!(r#"\\(.)"#); - re.replace_all(&s, |caps: &Captures| { - format!("{}", if &caps[1] == "n" { "\n" } else { &caps[1] }) - }) -} - -pub fn pr_list(lst: &Vec, pr: bool, - start: &str , end: &str, join: &str) -> String { - let mut first = true; - let mut res = String::new(); - res.push_str(start); - for mv in lst.iter() { - if first { - first = false; - } else { - res.push_str(join); - } - res.push_str(&mv.pr_str(pr)); - } - res.push_str(end); - res -} diff --git a/rust/src/reader.rs b/rust/src/reader.rs deleted file mode 100644 index 94093db2c4..0000000000 --- a/rust/src/reader.rs +++ /dev/null @@ -1,198 +0,0 @@ -use std::borrow::ToOwned; -use types::MalError::{ErrString, ErrMalVal}; -use types::{MalVal, MalRet, - _nil, _true, _false, _int, symbol, string, list, vector, hash_mapv, - err_str, err_string, err_val}; -use super::printer::unescape_str; - -#[derive(Debug, Clone)] -struct Reader { - tokens: Vec, - position: usize, -} - -impl Reader { - fn next(&mut self) -> Option { - if self.position < self.tokens.len() { - self.position += 1; - Some(self.tokens[self.position-1].to_string()) - } else { - None - } - } - fn peek(&self) -> Option { - if self.position < self.tokens.len() { - Some(self.tokens[self.position].to_string()) - } else { - None - } - } -} - -fn tokenize(str: String) -> Vec { - let mut results = vec![]; - let re = regex!(r###"[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)"###); - for cap in re.captures_iter(&str) { - let group = cap.at(1).unwrap_or(""); - if group == "" { break; } - if group.starts_with(";") { continue; } - results.push(group.to_owned()); - } - results -} - -fn read_atom(rdr : &mut Reader) -> MalRet { - let otoken = rdr.next(); - //println!("read_atom: {}", otoken); - if otoken.is_none() { return err_str("read_atom underflow"); } - let stoken = otoken.unwrap(); - let token = &stoken[..]; - if regex!(r"^-?[0-9]+$").is_match(token) { - let num : Option = token.parse().ok(); - Ok(_int(num.unwrap())) - } else if regex!(r#"^".*"$"#).is_match(token) { - let new_str = &token[1..token.len()-1]; - Ok(string(unescape_str(new_str))) - } else if regex!(r#"^:"#).is_match(token) { - Ok(string(format!("\u{29e}{}", &token[1..]))) - } else if token == "nil" { - Ok(_nil()) - } else if token == "true" { - Ok(_true()) - } else if token == "false" { - Ok(_false()) - } else { - Ok(symbol(token)) - } -} - -fn read_seq(rdr : &mut Reader, start: &str, end: &str) -> Result,String> { - let otoken = rdr.next(); - if otoken.is_none() { - return Err("read_atom underflow".to_string()); - } - let stoken = otoken.unwrap(); - let token = &stoken[..]; - if token != start { - return Err(format!("expected '{}'", start)) - } - - let mut ast_vec : Vec = vec![]; - loop { - let otoken = rdr.peek(); - if otoken.is_none() { - return Err(format!("expected '{}', got EOF", end)); - } - let stoken = otoken.unwrap(); - let token = &stoken[..]; - if token == end { break; } - - match read_form(rdr) { - Ok(mv) => ast_vec.push(mv), - Err(ErrString(es)) => return Err(es), - Err(ErrMalVal(_)) => return Err("read_seq exception".to_string()), - } - } - rdr.next(); - - Ok(ast_vec) -} - -fn read_list(rdr : &mut Reader) -> MalRet { - match read_seq(rdr, "(", ")") { - Ok(seq) => Ok(list(seq)), - Err(es) => err_string(es), - } -} - -fn read_vector(rdr : &mut Reader) -> MalRet { - match read_seq(rdr, "[", "]") { - Ok(seq) => Ok(vector(seq)), - Err(es) => err_string(es), - } -} - -fn read_hash_map(rdr : &mut Reader) -> MalRet { - match read_seq(rdr, "{", "}") { - Ok(seq) => hash_mapv(seq), - Err(es) => err_string(es), - } -} - -fn read_form(rdr : &mut Reader) -> MalRet { - let otoken = rdr.peek(); - //println!("read_form: {}", otoken); - let stoken = otoken.unwrap(); - let token = &stoken[..]; - match token { - "'" => { - let _ = rdr.next(); - match read_form(rdr) { - Ok(f) => Ok(list(vec![symbol("quote"), f])), - Err(e) => Err(e), - } - }, - "`" => { - let _ = rdr.next(); - match read_form(rdr) { - Ok(f) => Ok(list(vec![symbol("quasiquote"), f])), - Err(e) => Err(e), - } - }, - "~" => { - let _ = rdr.next(); - match read_form(rdr) { - Ok(f) => Ok(list(vec![symbol("unquote"), f])), - Err(e) => Err(e), - } - }, - "~@" => { - let _ = rdr.next(); - match read_form(rdr) { - Ok(f) => Ok(list(vec![symbol("splice-unquote"), f])), - Err(e) => Err(e), - } - }, - "^" => { - let _ = rdr.next(); - match read_form(rdr) { - Ok(meta) => { - match read_form(rdr) { - Ok(f) => Ok(list(vec![symbol("with-meta"), f, meta])), - Err(e) => Err(e), - } - }, - Err(e) => Err(e), - } - }, - "@" => { - let _ = rdr.next(); - match read_form(rdr) { - Ok(f) => Ok(list(vec![symbol("deref"), f])), - Err(e) => Err(e), - } - }, - - ")" => err_str("unexected ')'"), - "(" => read_list(rdr), - - "]" => err_str("unexected ']'"), - "[" => read_vector(rdr), - - "}" => err_str("unexected '}'"), - "{" => read_hash_map(rdr), - - _ => read_atom(rdr) - } -} - -pub fn read_str(str :String) -> MalRet { - let tokens = tokenize(str); - if tokens.len() == 0 { - // any malval as the error slot means empty line - return err_val(_nil()) - } - //println!("tokens: {}", tokens); - let rdr = &mut Reader{tokens: tokens, position: 0}; - read_form(rdr) -} diff --git a/rust/src/readline.rs b/rust/src/readline.rs deleted file mode 100644 index 53caf8f9eb..0000000000 --- a/rust/src/readline.rs +++ /dev/null @@ -1,81 +0,0 @@ -// Based on: https://github.com/shaleh/rust-readline (MIT) -use libc; - -use std::ffi::{CStr, CString}; -use std::fs::{OpenOptions, File}; -use std::io::BufReader; -use std::io::prelude::*; -use std::str; - -mod ext_readline { - extern crate libc; - use self::libc::c_char; - #[link(name = "readline")] - extern { - pub fn add_history(line: *const c_char); - pub fn readline(p: *const c_char) -> *const c_char; - } -} - -pub fn add_history(line: &str) { - unsafe { - ext_readline::add_history(CString::new(line).unwrap().as_ptr()); - } -} - -pub fn readline(prompt: &str) -> Option { - let cprmt = CString::new(prompt).unwrap(); - unsafe { - let ptr = ext_readline::readline(cprmt.as_ptr()); - if ptr.is_null() { // user pressed Ctrl-D - None - } else { - let ret = str::from_utf8(CStr::from_ptr(ptr).to_bytes()); - let ret = ret.ok().map(|s| s.to_string()); - libc::free(ptr as *mut _); - return ret; - } - } -} - -// -------------------------------------------- - -static mut HISTORY_LOADED : bool = false; -static HISTORY_FILE: &'static str = "/home/joelm/.mal-history"; - -fn load_history() { - unsafe { - if HISTORY_LOADED { return; } - HISTORY_LOADED = true; - } - - let file = match File::open(HISTORY_FILE) { - Ok(f) => f, - Err(..) => return - }; - let file = BufReader::new(file); - for line in file.lines() { - let rt: &[_] = &['\r', '\n']; - let line2 = line.unwrap(); - let line3 = line2.trim_right_matches(rt); - add_history(line3); - } -} - -fn append_to_history(line: &str) { - let file = OpenOptions::new().append(true).write(true).create(true) - .open(HISTORY_FILE); - let mut file = match file { Ok(f) => f, Err(..) => return }; - let _ = file.write_all(line.as_bytes()); - let _ = file.write_all(b"\n"); -} - -pub fn mal_readline (prompt: &str) -> Option { - load_history(); - let line = readline(prompt); - if let Some(ref s) = line { - add_history(s); - append_to_history(s); - } - line -} diff --git a/rust/src/types.rs b/rust/src/types.rs deleted file mode 100644 index 0fdf8de21e..0000000000 --- a/rust/src/types.rs +++ /dev/null @@ -1,430 +0,0 @@ -#![allow(dead_code)] - -use std::rc::Rc; -use std::cell::RefCell; -use std::collections::HashMap; -use std::fmt; -use super::printer::{escape_str,pr_list}; -use super::env::{Env,env_new,env_bind}; - -use self::MalType::*; -use self::MalError::*; - -#[derive(Clone)] -#[allow(non_camel_case_types)] -pub enum MalType { - Nil, - True, - False, - Int(isize), - Strn(String), - Sym(String), - List(Vec, MalVal), - Vector(Vec, MalVal), - Hash_Map(HashMap, MalVal), - Func(fn(Vec) -> MalRet, MalVal), - MalFunc(MalFuncData, MalVal), - Atom(RefCell), -} - -pub type MalVal = Rc; - -#[derive(Debug)] -pub enum MalError { - ErrString(String), - ErrMalVal(MalVal), -} - -pub type MalRet = Result; - - -pub fn err_string(s: String) -> MalRet { - Err(ErrString(s)) -} - -pub fn err_str(s: &str) -> MalRet { - Err(ErrString(s.to_string())) -} - -pub fn err_val(mv: MalVal) -> MalRet { - Err(ErrMalVal(mv)) -} - -#[derive(Clone)] -pub struct MalFuncData { - pub eval: fn(MalVal, Env) -> MalRet, - pub exp: MalVal, - pub env: Env, - pub params: MalVal, - pub is_macro: bool, -} - -impl MalType { - pub fn pr_str(&self, print_readably: bool) -> String { - let _r = print_readably; - match *self { - Nil => "nil".to_string(), - True => "true".to_string(), - False => "false".to_string(), - Int(v) => v.to_string(), - Sym(ref v) => v.clone(), - Strn(ref v) => { - if v.starts_with("\u{29e}") { - format!(":{}", &v[2..]) - } else if print_readably { - escape_str(v) - } else { - v.clone() - } - }, - List(ref v,_) => { - pr_list(v, _r, "(", ")", " ") - }, - Vector(ref v,_) => { - pr_list(v, _r, "[", "]", " ") - }, - Hash_Map(ref v,_) => { - let mut res = String::new(); - res.push_str("{"); - for (i, (key, value)) in v.iter().enumerate() { - if i != 0 { res.push_str(" "); } - if key.starts_with("\u{29e}") { - res.push_str(":"); - res.push_str(&key[2..]) - } else if print_readably { - res.push_str(&escape_str(key)) - } else { - res.push_str(key) - } - res.push_str(" "); - res.push_str(&value.pr_str(_r)); - } - res.push_str("}"); - res - }, - // TODO: better native function representation - Func(_, _) => format!("#"), - MalFunc(ref mf,_) => format!("(fn* {:?} {:?})", mf.params, mf.exp), - Atom(ref v) => format!("(atom {:?})", &**v.borrow()), - } - } - - pub fn apply(&self, args:Vec) -> MalRet { - match *self { - Func(f,_) => f(args), - MalFunc(ref mf,_) => { - let mfc = mf.clone(); - let alst = list(args); - let new_env = env_new(Some(mfc.env.clone())); - match env_bind(&new_env, mfc.params, alst) { - Ok(_) => (mfc.eval)(mfc.exp, new_env), - Err(e) => err_string(e), - } - }, - _ => err_str("attempt to call non-function"), - } - - } -} - -impl PartialEq for MalType { - fn eq(&self, other: &MalType) -> bool { - match (self, other) { - (&Nil, &Nil) | - (&True, &True) | - (&False, &False) => true, - (&Int(ref a), &Int(ref b)) => a == b, - (&Strn(ref a), &Strn(ref b)) => a == b, - (&Sym(ref a), &Sym(ref b)) => a == b, - (&List(ref a,_), &List(ref b,_)) | - (&Vector(ref a,_), &Vector(ref b,_)) | - (&List(ref a,_), &Vector(ref b,_)) | - (&Vector(ref a,_), &List(ref b,_)) => a == b, - (&Hash_Map(ref a,_), &Hash_Map(ref b,_)) => a == b, - // TODO: fix this - (&Func(_,_), &Func(_,_)) => false, - (&MalFunc(_,_), &MalFunc(_,_)) => false, - _ => return false, - } - } -} - -impl fmt::Debug for MalType { - fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { - write!(f, "{}", self.pr_str(true)) - } -} - - -// Scalars -pub fn _nil() -> MalVal { Rc::new(Nil) } -pub fn nil_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to nil? call"); - } - match *a[0].clone() { - Nil => Ok(_true()), - _ => Ok(_false()), - } -} - -pub fn _true() -> MalVal { Rc::new(True) } -pub fn true_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to true? call"); - } - match *a[0].clone() { - True => Ok(_true()), - _ => Ok(_false()), - } -} - -pub fn _false() -> MalVal { Rc::new(False) } -pub fn false_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to false? call"); - } - match *a[0].clone() { - False => Ok(_true()), - _ => Ok(_false()), - } -} - -pub fn string_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to string? call"); - } - match *a[0].clone() { - Strn(ref s) => { - if s.starts_with("\u{29e}") { - Ok(_false()) - } else { - Ok(_true()) - } - }, - _ => Ok(_false()), - } -} - -pub fn _int(i: isize) -> MalVal { Rc::new(Int(i)) } -pub fn int_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to number? call"); - } - match *a[0] { - Int(_) => Ok(_true()), - _ => Ok(_false()), - } -} - - -// Symbols -pub fn symbol(strn: &str) -> MalVal { Rc::new(Sym(strn.to_string())) } -pub fn _symbol(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to symbol call"); - } - match *a[0].clone() { - Strn(ref s) => { - Ok(Rc::new(Sym(s.to_string()))) - }, - _ => return err_str("symbol called on non-string"), - } -} -pub fn symbol_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to symbol? call"); - } - match *a[0].clone() { - Sym(_) => Ok(_true()), - _ => Ok(_false()), - } -} - -// Keywords -pub fn _keyword(a: Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to keyword call"); - } - match *a[0] { - Strn(ref s) => Ok(Rc::new(Strn(format!("\u{29e}{}", s)))), - _ => err_str("keyword called on non-string"), - } -} -pub fn keyword_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to keyword? call"); - } - match *a[0].clone() { - Strn(ref s) => { - if s.starts_with("\u{29e}") { - Ok(_true()) - } else { - Ok(_false()) - } - }, - _ => Ok(_false()), - } -} - - -// Strings -pub fn strn(strn: &str) -> MalVal { Rc::new(Strn(strn.to_string())) } -pub fn string(strn: String) -> MalVal { Rc::new(Strn(strn)) } - -// Lists -pub fn list(seq: Vec) -> MalVal { Rc::new(List(seq,_nil())) } -pub fn listm(seq: Vec, meta: MalVal) -> MalVal { - Rc::new(List(seq,meta)) -} -pub fn listv(seq:Vec) -> MalRet { Ok(list(seq)) } -pub fn list_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to list? call"); - } - match *a[0].clone() { - List(_,_) => Ok(_true()), - _ => Ok(_false()), - } -} - -// Vectors -pub fn vector(seq: Vec) -> MalVal { Rc::new(Vector(seq,_nil())) } -pub fn vectorm(seq: Vec, meta: MalVal) -> MalVal { - Rc::new(Vector(seq,meta)) -} -pub fn vectorv(seq: Vec) -> MalRet { Ok(vector(seq)) } -pub fn vector_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to vector? call"); - } - match *a[0].clone() { - Vector(_,_) => Ok(_true()), - _ => Ok(_false()), - } -} - -// Hash Maps -pub fn hash_map(hm: HashMap) -> MalVal { - Rc::new(Hash_Map(hm,_nil())) -} -pub fn hash_mapm(hm: HashMap, meta: MalVal) -> MalVal { - Rc::new(Hash_Map(hm,meta)) -} -pub fn _assoc(hm: &HashMap, a:Vec) -> MalRet { - if a.len() % 2 == 1 { - return err_str("odd number of hash-map keys/values"); - } - let mut new_hm = hm.clone(); - let mut it = a.iter(); - loop { - let k = match it.next() { - Some(mv) => match *mv.clone() { - Strn(ref s) => s.to_string(), - _ => return err_str("key is not a string in hash-map call"), - }, - None => break, - }; - let v = it.next().unwrap(); - new_hm.insert(k, v.clone()); - } - Ok(Rc::new(Hash_Map(new_hm,_nil()))) -} -pub fn _dissoc(hm: &HashMap, a:Vec) -> MalRet { - let mut new_hm = hm.clone(); - let mut it = a.iter(); - loop { - let k = match it.next() { - Some(mv) => match *mv.clone() { - Strn(ref s) => s.to_string(), - _ => return err_str("key is not a string in hash-map call"), - }, - None => break, - }; - new_hm.remove(&k); - } - Ok(Rc::new(Hash_Map(new_hm,_nil()))) -} -pub fn hash_mapv(seq: Vec) -> MalRet { - let new_hm: HashMap = HashMap::new(); - _assoc(&new_hm, seq) -} -pub fn hash_map_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to map? call"); - } - match *a[0].clone() { - Hash_Map(_,_) => Ok(_true()), - _ => Ok(_false()), - } -} - -// Functions -pub fn func(f: fn(Vec) -> MalRet) -> MalVal { - Rc::new(Func(f, _nil())) -} -pub fn funcm(f: fn(Vec) -> MalRet, meta: MalVal) -> MalVal { - Rc::new(Func(f, meta)) -} -pub fn malfunc(eval: fn(MalVal, Env) -> MalRet, - exp: MalVal, - env: Env, - params: MalVal, - meta: MalVal) -> MalVal { - Rc::new(MalFunc(MalFuncData{eval: eval, - exp: exp, - env: env, - params: params, - is_macro: false},meta)) -} -pub fn malfuncd(mfd: MalFuncData, meta: MalVal) -> MalVal { - Rc::new(MalFunc(mfd,meta)) -} -pub fn fn_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to fn? call"); - } - match *a[0] { - Func(..) | MalFunc(MalFuncData { is_macro: false, .. }, _) => Ok(_true()), - _ => Ok(_false()), - } -} -pub fn macro_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to macro? call"); - } - match *a[0] { - MalFunc(MalFuncData { is_macro: true, .. }, _) => Ok(_true()), - _ => Ok(_false()), - } -} - - -// Atoms -pub fn atom_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to atom? call"); - } - match *a[0].clone() { - Atom(_) => Ok(_true()), - _ => Ok(_false()), - } -} -pub fn atom(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to atom call"); - } - Ok(Rc::new(Atom(RefCell::new(a[0].clone())))) -} - - -// General functions -pub fn sequential_q(a:Vec) -> MalRet { - if a.len() != 1 { - return err_str("Wrong arity to sequential? call"); - } - match *a[0].clone() { - List(_,_) | Vector(_,_) => Ok(_true()), - _ => Ok(_false()), - } -} diff --git a/rust/step0_repl.rs b/rust/step0_repl.rs new file mode 100644 index 0000000000..18eb94ff0d --- /dev/null +++ b/rust/step0_repl.rs @@ -0,0 +1,33 @@ +extern crate rustyline; + +use rustyline::error::ReadlineError; +use rustyline::Editor; + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + println!("{}", line); + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step1_read_print.rs b/rust/step1_read_print.rs new file mode 100644 index 0000000000..6d4c4f723b --- /dev/null +++ b/rust/step1_read_print.rs @@ -0,0 +1,53 @@ +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +#[allow(dead_code)] +mod types; +use types::{format_error}; +mod reader; +mod printer; +// TODO: figure out a way to avoid including env +#[allow(dead_code)] +mod env; + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match reader::read_str(line) { + Ok(mv) => { + println!("{}", mv.pr_str(true)); + }, + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step2_eval.rs b/rust/step2_eval.rs new file mode 100644 index 0000000000..729cee4d52 --- /dev/null +++ b/rust/step2_eval.rs @@ -0,0 +1,135 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +#[allow(dead_code)] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error,func}; +use types::MalVal::{Nil,Int,Sym,List,Vector,Hash}; +use types::MalErr::{ErrString}; +mod reader; +mod printer; +// TODO: figure out a way to avoid including env +#[allow(dead_code)] +mod env; + +pub type Env = FnvHashMap; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(sym) => { + Ok(env.get(sym) + .ok_or(ErrString(format!("'{}' not found", sym)))? + .clone()) + }, + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(ast: MalVal, env: Env) -> MalRet { + match ast.clone() { + List(l,_) => { + if l.len() == 0 { return Ok(ast); } + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + f.apply(el[1..].to_vec()) + }, + _ => { + error("expected a list") + } + } + }, + _ => eval_ast(&ast, &env), + } +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn int_op(op: fn(i64, i64) -> i64, a:MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Int(a0), Int(a1)) => Ok(Int(op(a0,a1))), + _ => error("invalid int_op args"), + } +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + let mut repl_env = Env::default(); + repl_env.insert("+".to_string(), func(|a:MalArgs|{int_op(|i,j|{i+j},a)})); + repl_env.insert("-".to_string(), func(|a:MalArgs|{int_op(|i,j|{i-j},a)})); + repl_env.insert("*".to_string(), func(|a:MalArgs|{int_op(|i,j|{i*j},a)})); + repl_env.insert("/".to_string(), func(|a:MalArgs|{int_op(|i,j|{i/j},a)})); + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step3_env.rs b/rust/step3_env.rs new file mode 100644 index 0000000000..24fffa03fb --- /dev/null +++ b/rust/step3_env.rs @@ -0,0 +1,159 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +#[allow(dead_code)] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error,func}; +use types::MalVal::{Nil,Int,Sym,List,Vector,Hash}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_get,env_set,env_sets}; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(ast: MalVal, env: Env) -> MalRet { + match ast.clone() { + List(l,_) => { + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + let let_env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&let_env, b.clone(), + eval(e.clone(), let_env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + eval(a2, let_env) + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + f.apply(el[1..].to_vec()) + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + } +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn int_op(op: fn(i64, i64) -> i64, a:MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Int(a0), Int(a1)) => Ok(Int(op(a0,a1))), + _ => error("invalid int_op args"), + } +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + let repl_env = env_new(None); + env_sets(&repl_env, "+", func(|a:MalArgs|{int_op(|i,j|{i+j},a)})); + env_sets(&repl_env, "-", func(|a:MalArgs|{int_op(|i,j|{i-j},a)})); + env_sets(&repl_env, "*", func(|a:MalArgs|{int_op(|i,j|{i*j},a)})); + env_sets(&repl_env, "/", func(|a:MalArgs|{int_op(|i,j|{i/j},a)})); + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step4_if_fn_do.rs b/rust/step4_if_fn_do.rs new file mode 100644 index 0000000000..9359e7fd22 --- /dev/null +++ b/rust/step4_if_fn_do.rs @@ -0,0 +1,182 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Sym,List,Vector,Hash,MalFunc}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(ast: MalVal, env: Env) -> MalRet { + match ast.clone() { + List(l,_) => { + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + let let_env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&let_env, b.clone(), + eval(e.clone(), let_env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + eval(a2, let_env) + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..].to_vec()), &env)? { + List(el,_) => Ok(el.last().unwrap_or(&Nil).clone()), + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + eval(l[3].clone(), env.clone()) + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + eval(l[2].clone(), env.clone()) + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + f.apply(el[1..].to_vec()) + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + } +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step5_tco.rs b/rust/step5_tco.rs new file mode 100644 index 0000000000..d483ff83bb --- /dev/null +++ b/rust/step5_tco.rs @@ -0,0 +1,209 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Sym,List,Vector,Hash,Func,MalFunc}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_bind,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + + ret = match ast.clone() { + List(l,_) => { + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&env, b.clone(), + eval(e.clone(), env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len()-1].to_vec()), &env)? { + List(_,_) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + }, + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_,_) => f.apply(args), + MalFunc{ast: mast, env: menv, params, ..} => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + }, + _ => error("attempt to call non-function"), + } + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + }; + + break; + + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step6_file.rs b/rust/step6_file.rs new file mode 100644 index 0000000000..02cd45dff0 --- /dev/null +++ b/rust/step6_file.rs @@ -0,0 +1,232 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Str,Sym,List,Vector,Hash,Func,MalFunc}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_bind,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + + ret = match ast.clone() { + List(l,_) => { + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&env, b.clone(), + eval(e.clone(), env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len()-1].to_vec()), &env)? { + List(_,_) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + }, + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_,_) => f.apply(args), + MalFunc{ast: mast, env: menv, params, ..} => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + }, + _ => error("attempt to call non-function"), + } + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + }; + + break; + + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", &repl_env); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")",f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step7_quote.rs b/rust/step7_quote.rs new file mode 100644 index 0000000000..163b5852bd --- /dev/null +++ b/rust/step7_quote.rs @@ -0,0 +1,274 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Str,Sym,List,Vector,Hash,Func,MalFunc}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_bind,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(ref v,_) | Vector(ref v,_) if v.len() > 0 => { + let a0 = &v[0]; + match a0 { + Sym(ref s) if s == "unquote" => v[1].clone(), + _ => { + match a0 { + List(ref v0,_) | Vector(ref v0,_) if v0.len() > 0 => { + match v0[0] { + Sym(ref s) if s == "splice-unquote" => { + list![Sym("concat".to_string()), + v0[1].clone(), + quasiquote(&list!(v[1..].to_vec()))] + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + }, + } + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + } + } + } + } + }, + _ => list![Sym("quote".to_string()), ast.clone()] + } +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + + ret = match ast.clone() { + List(l,_) => { + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&env, b.clone(), + eval(e.clone(), env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "quote" => { + Ok(l[1].clone()) + }, + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len()-1].to_vec()), &env)? { + List(_,_) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + }, + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_,_) => f.apply(args), + MalFunc{ast: mast, env: menv, params, ..} => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + }, + _ => error("attempt to call non-function"), + } + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + }; + + break; + + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", &repl_env); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")",f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step8_macros.rs b/rust/step8_macros.rs new file mode 100644 index 0000000000..70e03fe73e --- /dev/null +++ b/rust/step8_macros.rs @@ -0,0 +1,343 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Str,Sym,List,Vector,Hash,Func,MalFunc}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_bind,env_find,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(ref v,_) | Vector(ref v,_) if v.len() > 0 => { + let a0 = &v[0]; + match a0 { + Sym(ref s) if s == "unquote" => v[1].clone(), + _ => { + match a0 { + List(ref v0,_) | Vector(ref v0,_) if v0.len() > 0 => { + match v0[0] { + Sym(ref s) if s == "splice-unquote" => { + list![Sym("concat".to_string()), + v0[1].clone(), + quasiquote(&list!(v[1..].to_vec()))] + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + }, + } + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + } + } + } + } + }, + _ => list![Sym("quote".to_string()), ast.clone()] + } +} + +fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal,MalArgs)> { + match ast { + List(v,_) => { + match v[0] { + Sym(ref s) => { + match env_find(env, s) { + Some(e) => { + match env_get(&e, &v[0]) { + Ok(f @ MalFunc{is_macro: true, ..}) => { + Some((f, v[1..].to_vec())) + }, + _ => None, + } + }, + _ => None, + } + }, + _ => None, + } + }, + _ => None, + } +} + +fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { + let mut was_expanded = false; + while let Some((mf, args)) = is_macro_call(&ast, env) { + //println!("macroexpand 1: {:?}", ast); + ast = match mf.apply(args) { + Err(e) => return (false, Err(e)), + Ok(a) => a, + }; + //println!("macroexpand 2: {:?}", ast); + was_expanded = true; + } + ((was_expanded, Ok(ast))) +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + + ret = match ast.clone() { + List(l,_) => { + match macroexpand(ast.clone(), &env) { + (true, Ok(new_ast)) => { + ast = new_ast; + continue 'tco; + } + (_, Err(e)) => return Err(e), + _ => (), + } + + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&env, b.clone(), + eval(e.clone(), env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "quote" => { + Ok(l[1].clone()) + }, + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "defmacro!" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + let r = eval(a2, env.clone())?; + match r { + MalFunc{eval, ast, env, params, ..} => { + Ok(env_set(&env, a1.clone(), + MalFunc{eval: eval, ast: ast.clone(), env: env.clone(), + params: params.clone(), is_macro: true, + meta: Rc::new(Nil)})?) + }, + _ => error("set_macro on non-function"), + } + }, + Sym(ref a0sym) if a0sym == "macroexpand" => { + match macroexpand(l[1].clone(), &env) { + (_, Ok(new_ast)) => Ok(new_ast), + (_, e) => return e, + } + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len()-1].to_vec()), &env)? { + List(_,_) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + }, + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_,_) => f.apply(args), + MalFunc{ast: mast, env: menv, params, ..} => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + }, + _ => error("attempt to call non-function"), + } + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + }; + + break; + + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", &repl_env); + let _ = rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", &repl_env); + let _ = rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", &repl_env); + + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")",f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/step9_try.rs b/rust/step9_try.rs new file mode 100644 index 0000000000..5e362147da --- /dev/null +++ b/rust/step9_try.rs @@ -0,0 +1,364 @@ +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Str,Sym,List,Vector,Hash,Func,MalFunc}; +use types::MalErr::{ErrString,ErrMalVal}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_bind,env_find,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(ref v,_) | Vector(ref v,_) if v.len() > 0 => { + let a0 = &v[0]; + match a0 { + Sym(ref s) if s == "unquote" => v[1].clone(), + _ => { + match a0 { + List(ref v0,_) | Vector(ref v0,_) if v0.len() > 0 => { + match v0[0] { + Sym(ref s) if s == "splice-unquote" => { + list![Sym("concat".to_string()), + v0[1].clone(), + quasiquote(&list!(v[1..].to_vec()))] + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + }, + } + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + } + } + } + } + }, + _ => list![Sym("quote".to_string()), ast.clone()] + } +} + +fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal,MalArgs)> { + match ast { + List(v,_) => { + match v[0] { + Sym(ref s) => { + match env_find(env, s) { + Some(e) => { + match env_get(&e, &v[0]) { + Ok(f @ MalFunc{is_macro: true, ..}) => { + Some((f, v[1..].to_vec())) + }, + _ => None, + } + }, + _ => None, + } + }, + _ => None, + } + }, + _ => None, + } +} + +fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { + let mut was_expanded = false; + while let Some((mf, args)) = is_macro_call(&ast, env) { + //println!("macroexpand 1: {:?}", ast); + ast = match mf.apply(args) { + Err(e) => return (false, Err(e)), + Ok(a) => a, + }; + //println!("macroexpand 2: {:?}", ast); + was_expanded = true; + } + ((was_expanded, Ok(ast))) +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + + ret = match ast.clone() { + List(l,_) => { + match macroexpand(ast.clone(), &env) { + (true, Ok(new_ast)) => { + ast = new_ast; + continue 'tco; + } + (_, Err(e)) => return Err(e), + _ => (), + } + + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&env, b.clone(), + eval(e.clone(), env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "quote" => { + Ok(l[1].clone()) + }, + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "defmacro!" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + let r = eval(a2, env.clone())?; + match r { + MalFunc{eval, ast, env, params, ..} => { + Ok(env_set(&env, a1.clone(), + MalFunc{eval: eval, ast: ast.clone(), env: env.clone(), + params: params.clone(), is_macro: true, + meta: Rc::new(Nil)})?) + }, + _ => error("set_macro on non-function"), + } + }, + Sym(ref a0sym) if a0sym == "macroexpand" => { + match macroexpand(l[1].clone(), &env) { + (_, Ok(new_ast)) => Ok(new_ast), + (_, e) => return e, + } + }, + Sym(ref a0sym) if a0sym == "try*" => { + match eval(l[1].clone(), env.clone()) { + Err(ref e) if l.len() >= 3 => { + let exc = match e { + ErrMalVal(mv) => mv.clone(), + ErrString(s) => Str(s.to_string()), + }; + match l[2].clone() { + List(c,_) => { + let catch_env = env_bind(Some(env.clone()), + list!(vec![c[1].clone()]), + vec![exc])?; + eval(c[2].clone(), catch_env) + }, + _ => error("invalid catch block"), + } + }, + res => res, + } + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len()-1].to_vec()), &env)? { + List(_,_) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + }, + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_,_) => f.apply(args), + MalFunc{ast: mast, env: menv, params, ..} => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + }, + _ => error("attempt to call non-function"), + } + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + }; + + break; + + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", &repl_env); + let _ = rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", &repl_env); + let _ = rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", &repl_env); + + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")",f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/stepA_mal.rs b/rust/stepA_mal.rs new file mode 100644 index 0000000000..89e9135f65 --- /dev/null +++ b/rust/stepA_mal.rs @@ -0,0 +1,370 @@ +#![allow(non_snake_case)] + +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate regex; +extern crate itertools; +extern crate fnv; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use types::{MalVal,MalArgs,MalRet,MalErr,error,format_error}; +use types::MalVal::{Nil,Bool,Str,Sym,List,Vector,Hash,Func,MalFunc}; +use types::MalErr::{ErrString,ErrMalVal}; +mod reader; +mod printer; +mod env; +use env::{Env,env_new,env_bind,env_find,env_get,env_set,env_sets}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(ref v,_) | Vector(ref v,_) if v.len() > 0 => { + let a0 = &v[0]; + match a0 { + Sym(ref s) if s == "unquote" => v[1].clone(), + _ => { + match a0 { + List(ref v0,_) | Vector(ref v0,_) if v0.len() > 0 => { + match v0[0] { + Sym(ref s) if s == "splice-unquote" => { + list![Sym("concat".to_string()), + v0[1].clone(), + quasiquote(&list!(v[1..].to_vec()))] + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + }, + } + }, + _ => { + list![Sym("cons".to_string()), + quasiquote(a0), + quasiquote(&list!(v[1..].to_vec()))] + } + } + } + } + }, + _ => list![Sym("quote".to_string()), ast.clone()] + } +} + +fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal,MalArgs)> { + match ast { + List(v,_) => { + match v[0] { + Sym(ref s) => { + match env_find(env, s) { + Some(e) => { + match env_get(&e, &v[0]) { + Ok(f @ MalFunc{is_macro: true, ..}) => { + Some((f, v[1..].to_vec())) + }, + _ => None, + } + }, + _ => None, + } + }, + _ => None, + } + }, + _ => None, + } +} + +fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { + let mut was_expanded = false; + while let Some((mf, args)) = is_macro_call(&ast, env) { + //println!("macroexpand 1: {:?}", ast); + ast = match mf.apply(args) { + Err(e) => return (false, Err(e)), + Ok(a) => a, + }; + //println!("macroexpand 2: {:?}", ast); + was_expanded = true; + } + ((was_expanded, Ok(ast))) +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(list!(lst)) + }, + Vector(v,_) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { lst.push(eval(a.clone(), env.clone())?) } + Ok(vector!(lst)) + }, + Hash(hm,_) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k,v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm),Rc::new(Nil))) + }, + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + + ret = match ast.clone() { + List(l,_) => { + match macroexpand(ast.clone(), &env) { + (true, Ok(new_ast)) => { + ast = new_ast; + continue 'tco; + } + (_, Err(e)) => return Err(e), + _ => (), + } + + if l.len() == 0 { return Ok(ast); } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + }, + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds,_) | Vector(ref binds,_) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set(&env, b.clone(), + eval(e.clone(), env.clone())?); + }, + _ => { + return error("let* with non-Sym binding"); + } + } + } + }, + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "quote" => { + Ok(l[1].clone()) + }, + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + }, + Sym(ref a0sym) if a0sym == "defmacro!" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + let r = eval(a2, env.clone())?; + match r { + MalFunc{eval, ast, env, params, ..} => { + Ok(env_set(&env, a1.clone(), + MalFunc{eval: eval, ast: ast.clone(), env: env.clone(), + params: params.clone(), is_macro: true, + meta: Rc::new(Nil)})?) + }, + _ => error("set_macro on non-function"), + } + }, + Sym(ref a0sym) if a0sym == "macroexpand" => { + match macroexpand(l[1].clone(), &env) { + (_, Ok(new_ast)) => Ok(new_ast), + (_, e) => return e, + } + }, + Sym(ref a0sym) if a0sym == "try*" => { + match eval(l[1].clone(), env.clone()) { + Err(ref e) if l.len() >= 3 => { + let exc = match e { + ErrMalVal(mv) => mv.clone(), + ErrString(s) => Str(s.to_string()), + }; + match l[2].clone() { + List(c,_) => { + let catch_env = env_bind(Some(env.clone()), + list!(vec![c[1].clone()]), + vec![exc])?; + eval(c[2].clone(), catch_env) + }, + _ => error("invalid catch block"), + } + }, + res => res, + } + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len()-1].to_vec()), &env)? { + List(_,_) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + }, + _ => error("invalid do form"), + } + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + }, + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + }, + _ => Ok(Nil) + } + }, + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc{eval: eval, ast: Rc::new(a2), env: env, + params: Rc::new(a1), is_macro: false, + meta: Rc::new(Nil)}) + }, + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + }, + _ => { + match eval_ast(&ast, &env)? { + List(ref el,_) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_,_) => f.apply(args), + MalFunc{ast: mast, env: menv, params, ..} => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + }, + _ => error("attempt to call non-function"), + } + }, + _ => { + error("expected a list") + } + } + } + } + }, + _ => eval_ast(&ast, &env), + }; + + break; + + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + println!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! *host-language* \"rust\")", &repl_env); + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", &repl_env); + let _ = rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", &repl_env); + let _ = rep("(def! *gensym-counter* (atom 0))", &repl_env); + let _ = rep("(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))", &repl_env); + let _ = rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", &repl_env); + + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")",f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + let _ = rep("(println (str \"Mal [\" *host-language* \"]\"))", &repl_env); + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + }, + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break + } + } + } +} + +// vim: ts=2:sw=2:expandtab diff --git a/rust/tests/step5_tco.mal b/rust/tests/step5_tco.mal deleted file mode 100644 index 5cf775f657..0000000000 --- a/rust/tests/step5_tco.mal +++ /dev/null @@ -1,2 +0,0 @@ -;; Rust: skipping non-TCO recursion -;; Reason: unrecoverable stack overflow diff --git a/rust/types.rs b/rust/types.rs new file mode 100644 index 0000000000..d924f950ef --- /dev/null +++ b/rust/types.rs @@ -0,0 +1,232 @@ +use std::rc::Rc; +use std::cell::RefCell; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +use types::MalErr::{ErrString,ErrMalVal}; +use types::MalVal::{Nil,Bool,Int,Str,Sym,List,Vector,Hash,Func,MalFunc,Atom}; +use env::{Env,env_bind}; + +#[derive(Debug, Clone)] +pub enum MalVal { + Nil, + Bool(bool), + Int(i64), + //Float(f64), + Str(String), + Sym(String), + List(Rc>, Rc), + Vector(Rc>, Rc), + Hash(Rc>, Rc), + Func(fn(MalArgs) -> MalRet, Rc), + MalFunc { + eval: fn(ast: MalVal, env: Env) -> MalRet, + ast: Rc, + env: Env, + params: Rc, + is_macro: bool, + meta: Rc, + }, + Atom(Rc>), +} + +#[derive(Debug)] +pub enum MalErr { + ErrString(String), + ErrMalVal(MalVal), +} + +pub type MalArgs = Vec; +pub type MalRet = Result; + +// type utility macros + +macro_rules! list { + ($seq:expr) => {{ + List(Rc::new($seq),Rc::new(Nil)) + }}; + [$($args:expr),*] => {{ + let v: Vec = vec![$($args),*]; + List(Rc::new(v),Rc::new(Nil)) + }} +} + +macro_rules! vector { + ($seq:expr) => {{ + Vector(Rc::new($seq),Rc::new(Nil)) + }}; + [$($args:expr),*] => {{ + let v: Vec = vec![$($args),*]; + Vector(Rc::new(v),Rc::new(Nil)) + }} +} + +// type utility functions + +pub fn error(s: &str) -> MalRet { + Err(ErrString(s.to_string())) +} + +pub fn format_error(e: MalErr) -> String { + match e { + ErrString(s) => s.clone(), + ErrMalVal(mv) => mv.pr_str(true), + } +} + +pub fn atom(mv: &MalVal) -> MalVal { + Atom(Rc::new(RefCell::new(mv.clone()))) +} + +impl MalVal { + pub fn keyword(&self) -> MalRet { + match self { + Str(s) if s.starts_with("\u{29e}") => Ok(Str(s.to_string())), + Str(s) => Ok(Str(format!("\u{29e}{}", s))), + _ => error("invalid type for keyword"), + } + } + + pub fn empty_q(&self) -> MalRet { + match self { + List(l,_) | Vector(l,_) => Ok(Bool(l.len() == 0)), + Nil => Ok(Bool(true)), + _ => error("invalid type for empty?"), + } + } + + pub fn count(&self) -> MalRet { + match self { + List(l,_) | Vector(l,_) => Ok(Int(l.len() as i64)), + Nil => Ok(Int(0)), + _ => error("invalid type for count"), + } + } + + pub fn apply(&self, args: MalArgs) -> MalRet { + match *self { + Func(f,_) => f(args), + MalFunc{eval, ref ast, ref env, ref params, ..} => { + let a = &**ast; + let p = &**params; + let fn_env = env_bind(Some(env.clone()), p.clone(), args)?; + Ok(eval(a.clone(), fn_env)?) + } + _ => error("attempt to call non-function"), + } + } + + pub fn keyword_q(&self) -> bool { + match self { + Str(s) if s.starts_with("\u{29e}") => true, + _ => false, + } + } + + pub fn deref(&self) -> MalRet { + match self { + Atom(a) => Ok(a.borrow().clone()), + _ => error("attempt to deref a non-Atom"), + } + } + + pub fn reset_bang(&self, new: &MalVal) -> MalRet { + match self { + Atom(a) => { + *a.borrow_mut() = new.clone(); + Ok(new.clone()) + }, + _ => error("attempt to reset! a non-Atom"), + } + } + + pub fn swap_bang(&self, args: &MalArgs) -> MalRet { + match self { + Atom(a) => { + let f = &args[0]; + let mut fargs = args[1..].to_vec(); + fargs.insert(0, a.borrow().clone()); + *a.borrow_mut() = f.apply(fargs)?; + Ok(a.borrow().clone()) + }, + _ => error("attempt to swap! a non-Atom"), + } + } + + pub fn get_meta(&self) -> MalRet { + match self { + List(_,meta) | Vector(_,meta) | Hash(_,meta) => Ok((&**meta).clone()), + Func(_,meta) => Ok((&**meta).clone()), + MalFunc{meta,..} => Ok((&**meta).clone()), + _ => error("meta not supported by type"), + } + } + + pub fn with_meta(&mut self, new_meta: &MalVal) -> MalRet { + match self { + List(_, ref mut meta) | + Vector(_, ref mut meta) | + Hash(_, ref mut meta) | + Func(_,ref mut meta) | + MalFunc{ref mut meta, ..} => { + *meta = Rc::new((&*new_meta).clone()); + }, + _ => return error("with-meta not supported by type"), + }; + Ok(self.clone()) + } +} + +impl PartialEq for MalVal { + fn eq(&self, other: &MalVal) -> bool { + match (self, other) { + (Nil,Nil) => true, + (Bool(ref a),Bool(ref b)) => a == b, + (Int(ref a),Int(ref b)) => a == b, + (Str(ref a),Str(ref b)) => a == b, + (Sym(ref a),Sym(ref b)) => a == b, + (List(ref a,_),List(ref b,_)) | + (Vector(ref a,_),Vector(ref b,_)) | + (List(ref a,_),Vector(ref b,_)) | + (Vector(ref a,_),List(ref b,_)) => a == b, + (Hash(ref a,_),Hash(ref b,_)) => a == b, + (MalFunc{..}, MalFunc{..}) => false, + _ => false, + } + } +} + +pub fn func(f: fn(MalArgs) -> MalRet) -> MalVal { + Func(f, Rc::new(Nil)) +} + +pub fn _assoc(mut hm: FnvHashMap, kvs: MalArgs) -> MalRet { + if kvs.len() % 2 != 0 { + return error("odd number of elements") + } + for (k, v) in kvs.iter().tuples() { + match k { + Str(s) => { hm.insert(s.to_string(), v.clone()); }, + _ => { return error("key is not string") }, + } + } + Ok(Hash(Rc::new(hm),Rc::new(Nil))) +} + +pub fn _dissoc(mut hm: FnvHashMap, ks: MalArgs) -> MalRet { + for k in ks.iter() { + match k { + Str(ref s) => { hm.remove(s); }, + _ => { return error("key is not string") }, + } + } + Ok(Hash(Rc::new(hm),Rc::new(Nil))) +} + +pub fn hash_map(kvs: MalArgs) -> MalRet { + let hm: FnvHashMap = FnvHashMap::default(); + _assoc(hm, kvs) +} + +// vim: ts=2:sw=2:expandtab From 56d9fa6036a646c0dc819684761ab0ebec59a1ba Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 13 Jul 2018 15:24:18 -0500 Subject: [PATCH 0378/1998] scheme: enable foment to test if hangs are fixed --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 0079c27890..29a84b05f3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -81,7 +81,7 @@ matrix: - {env: IMPL=scheme scheme_MODE=chicken, services: [docker]} - {env: IMPL=scheme scheme_MODE=sagittarius, services: [docker]} - {env: IMPL=scheme scheme_MODE=cyclone, services: [docker]} -# - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} + - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} - {env: IMPL=skew, services: [docker]} - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7.3} - {env: IMPL=swift3, services: [docker]} From 0777a9a7620d8c499aaf810bbbaf2672761e52e1 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 14 Jul 2018 13:32:35 -0500 Subject: [PATCH 0379/1998] [travis] disable foment. Still hangs in perf. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 29a84b05f3..0079c27890 100644 --- a/.travis.yml +++ b/.travis.yml @@ -81,7 +81,7 @@ matrix: - {env: IMPL=scheme scheme_MODE=chicken, services: [docker]} - {env: IMPL=scheme scheme_MODE=sagittarius, services: [docker]} - {env: IMPL=scheme scheme_MODE=cyclone, services: [docker]} - - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} +# - {env: IMPL=scheme scheme_MODE=foment, services: [docker]} - {env: IMPL=skew, services: [docker]} - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7.3} - {env: IMPL=swift3, services: [docker]} From cd30e52b3158e9bb1d9a1ee4ea1cbfc2b1380b6a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 14 Jul 2018 19:27:11 -0500 Subject: [PATCH 0380/1998] rust: fix Dockerfile to include WORKDIR=/mal --- rust/Dockerfile | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/rust/Dockerfile b/rust/Dockerfile index fb1fdd69ee..6d0081e4df 100644 --- a/rust/Dockerfile +++ b/rust/Dockerfile @@ -1,3 +1,5 @@ -FROM rust +FROM rust:1.27.1 -ENV CARGO_HOME=/mal +ENV CARGO_HOME /mal + +WORKDIR /mal From 6da59ec2f48bdebabee68a2029877b8a7218edfe Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 16 Jul 2018 09:34:37 -0500 Subject: [PATCH 0381/1998] perf: fix perf3 to show total iters instead of / 3 The run-fn-for function was originally name run-fn and was hard-coded to run for 3 seconds. I forgot to replace the 3 with the max-secs variable. However, given that some implementations have less than 1 iteration per second, I'm just going to drop that division and report the iterations per max-seconds so that for the slowest implementations we have some relative comparison instead of all of them just reporting 0. Thanks to Tim Morgan for discovering this bug: https://github.com/kanaka/mal/commit/699f0ad23aca21076edb6a51838d879ca580ffd5 --- perf.mal | 2 +- tests/perf3.mal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/perf.mal b/perf.mal index 83bbc0da99..2fe9dd52b1 100644 --- a/perf.mal +++ b/perf.mal @@ -24,4 +24,4 @@ ;; Warm it up first (run-fn-for* fn 1000 0 0) ;; Now do the test - (/ (run-fn-for* fn (* 1000 max-secs) 0 0) 3)))) + (run-fn-for* fn (* 1000 max-secs) 0 0)))) diff --git a/tests/perf3.mal b/tests/perf3.mal index 5ac54146e3..1a4fbadecf 100644 --- a/tests/perf3.mal +++ b/tests/perf3.mal @@ -5,7 +5,7 @@ (def! atm (atom (list 0 1 2 3 4 5 6 7 8 9))) -(println "iters/s:" +(println "iters over 10 seconds:" (run-fn-for (fn* [] (do From 5ffa3314f97236147005455d4b85fb228f6a2db3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 16 Jul 2018 12:24:05 -0500 Subject: [PATCH 0382/1998] perf: simplify perf3 iter calc. Enable perf^mal. Since the iter count increases by 1 each time through the "loop", when we hit more than 10 seconds elapsed time we can just return the previous iter count rather than doing a percentage calculation. This fixes results for basic modes which couldn't do the percent calculation because itermediate values were greater than 32,768 which is the limit for basic MODES. Also, the mal implementation now runs and returns legit results so re-enable perf^impl. --- Makefile | 2 -- perf.mal | 10 +++++----- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index 62c9b330fa..de8f929226 100644 --- a/Makefile +++ b/Makefile @@ -125,8 +125,6 @@ test_EXCLUDES += test^plsql^step5 # too slow for 10,000 test_EXCLUDES += test^powershell^step5 # too slow for 10,000 test_EXCLUDES += $(if $(filter cpp,$(haxe_MODE)),test^haxe^step5,) # cpp finishes 10,000, segfaults at 100,000 -perf_EXCLUDES = mal # TODO: fix this - dist_EXCLUDES += mal # TODO: still need to implement dist dist_EXCLUDES += guile io julia matlab swift diff --git a/perf.mal b/perf.mal index 2fe9dd52b1..e4833bffe3 100644 --- a/perf.mal +++ b/perf.mal @@ -7,16 +7,16 @@ ret_FIXME)))) (def! run-fn-for* - (fn* [fn max-ms acc-ms iters] + (fn* [fn max-ms acc-ms last-iters] (let* [start (time-ms) _ (fn) elapsed (- (time-ms) start) - new-iters (+ 1 iters) + iters (+ 1 last-iters) new-acc-ms (+ acc-ms elapsed)] - ;(do (prn "here:" new-acc-ms "/" max-ms "iters:" new-iters) ) + ;(do (prn "new-acc-ms:" new-acc-ms "iters:" iters)) (if (>= new-acc-ms max-ms) - (/ (* max-ms iters) new-acc-ms) - (run-fn-for* fn max-ms new-acc-ms new-iters))))) + iters + (run-fn-for* fn max-ms new-acc-ms iters))))) (def! run-fn-for (fn* [fn max-secs] From 133221575478844ff8861faae6dddaa1f5b203be Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 16 Jul 2018 12:33:36 -0500 Subject: [PATCH 0383/1998] perf: more accurate iter count (last-iters). We should return the iter count prior to then final iteration because the final one was incomplete when the 10 seconds expired. --- perf.mal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perf.mal b/perf.mal index e4833bffe3..55f94092b4 100644 --- a/perf.mal +++ b/perf.mal @@ -15,7 +15,7 @@ new-acc-ms (+ acc-ms elapsed)] ;(do (prn "new-acc-ms:" new-acc-ms "iters:" iters)) (if (>= new-acc-ms max-ms) - iters + last-iters (run-fn-for* fn max-ms new-acc-ms iters))))) (def! run-fn-for From 17d2773245e58e287258bc92d39b52364d9f809a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 16 Jul 2018 17:45:55 -0500 Subject: [PATCH 0384/1998] Travis: trigger build after github push error. git push gave this error and the commit was successfully pushed but it didn't result in Travis starting a build: remote: Resolving deltas: 100% (2/2), completed with 2 local objects. remote: Unexpected system error after push was received. remote: These changes may not be reflected on github.com! remote: Your unique error code: 1d9d84300a34930b94914e59e9c3b381 To git@github.com:kanaka/mal.git 5ffa331..1332215 master -> master From 53c3bccc43fe621f64395ea08f17b8092e7c4af3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 16 Jul 2018 18:15:19 -0500 Subject: [PATCH 0385/1998] Travis: enable mal impl for perf test. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 0079c27890..94c0488c8c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -49,7 +49,7 @@ matrix: - {env: IMPL=logo, services: [docker]} - {env: IMPL=lua, services: [docker]} - {env: IMPL=make, services: [docker]} - - {env: IMPL=mal BUILD_IMPL=js NO_PERF=1, services: [docker]} + - {env: IMPL=mal BUILD_IMPL=js, services: [docker]} - {env: IMPL=matlab, services: [docker]} # Uses Octave - {env: IMPL=miniMAL, services: [docker]} - {env: IMPL=nasm, services: [docker]} From 5d52baf1acdef1aa70ff4c03cf3945a015f80814 Mon Sep 17 00:00:00 2001 From: Tim Morgan Date: Mon, 16 Jul 2018 18:41:12 -0500 Subject: [PATCH 0386/1998] Fix link to FAQ document --- process/guide.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/process/guide.md b/process/guide.md index 025995db4c..3e58b366ec 100644 --- a/process/guide.md +++ b/process/guide.md @@ -1669,9 +1669,9 @@ For extra information read [Peter Seibel's thorough discussion about * If you have created an implementation for a new target language (or a unique and interesting variant of an existing implementation), consider sending a pull request to add it into the main mal - repository. The [FAQ](FAQ.md#add_implementation) describes general - requirements for getting an implementation merged into the main - repository. + repository. The [FAQ](../docs/FAQ.md#will-you-add-my-new-implementation) + describes general requirements for getting an implementation merged + into the main repository. * Take your interpreter implementation and have it emit source code in the target language rather than immediately evaluating it. In other words, create a compiler. From a520ffd9a1cfe016f32ab92b94d92855a3a8a035 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 16 Jul 2018 19:10:00 -0500 Subject: [PATCH 0387/1998] Travis: re-active perf for erlang. Local testing shows that the test completes and doesn't hit OOM. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 94c0488c8c..ab99fe9077 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,7 +24,7 @@ matrix: - {env: IMPL=elisp, services: [docker]} - {env: IMPL=elixir, services: [docker]} - {env: IMPL=elm, services: [docker]} - - {env: IMPL=erlang NO_PERF=1, services: [docker]} # perf runs out of memory + - {env: IMPL=erlang, services: [docker]} # perf runs out of memory - {env: IMPL=es6, services: [docker]} - {env: IMPL=factor, services: [docker]} - {env: IMPL=fantom, services: [docker]} From 9581ba403eef4a7c8c35224886f4a497b75c8957 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 25 Aug 2018 17:30:33 -0500 Subject: [PATCH 0388/1998] Add link to Rust implementation by Tim Morgan. --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 150ad85edc..aa10fe1bab 100644 --- a/README.md +++ b/README.md @@ -891,6 +891,8 @@ cd rust cargo run --release --bin stepX_YYY ``` +There is also a separate implementation in [Rust by Tim Morgan](https://github.com/seven1m/mal-rust). + ### Scala ### Install scala and sbt (http://www.scala-sbt.org/0.13/tutorial/Installing-sbt-on-Linux.html): From 5185c56e92b9e6946d64d9148ac0a8accc85a200 Mon Sep 17 00:00:00 2001 From: Omar Roth Date: Sat, 27 Oct 2018 15:20:36 -0500 Subject: [PATCH 0389/1998] Update Crystal implementation --- README.md | 2 +- crystal/Makefile | 5 +- crystal/core.cr | 734 ++++++++++++++++++------------------ crystal/env.cr | 6 +- crystal/error.cr | 1 + crystal/printer.cr | 8 +- crystal/reader.cr | 16 +- crystal/readline.cr | 21 -- crystal/step0_repl.cr | 14 +- crystal/step1_read_print.cr | 6 +- crystal/step2_eval.cr | 27 +- crystal/step3_env.cr | 30 +- crystal/step4_if_fn_do.cr | 28 +- crystal/step5_tco.cr | 122 +++--- crystal/step6_file.cr | 126 +++---- crystal/step7_quote.cr | 138 +++---- crystal/step8_macros.cr | 157 ++++---- crystal/step9_try.cr | 187 +++++---- crystal/stepA_mal.cr | 187 +++++---- crystal/types.cr | 80 ++-- 20 files changed, 934 insertions(+), 961 deletions(-) delete mode 100644 crystal/readline.cr diff --git a/README.md b/README.md index aa10fe1bab..ecda6ebd5f 100644 --- a/README.md +++ b/README.md @@ -290,7 +290,7 @@ coffee ./stepX_YYY *The Crystal implementation of mal was created by [Linda_pp](https://github.com/rhysd)* -The Crystal implementation of mal has been tested with Crystal 0.18.4. +The Crystal implementation of mal has been tested with Crystal 0.26.1. ``` cd crystal diff --git a/crystal/Makefile b/crystal/Makefile index a26b02d13e..8373692259 100644 --- a/crystal/Makefile +++ b/crystal/Makefile @@ -2,7 +2,6 @@ STEPS = step0_repl.cr step1_read_print.cr step2_eval.cr step3_env.cr \ step4_if_fn_do.cr step5_tco.cr step6_file.cr step7_quote.cr \ step8_macros.cr step9_try.cr stepA_mal.cr -STEP0_DEPS = readline.cr STEP1_DEPS = $(STEP0_DEPS) reader.cr printer.cr STEP2_DEPS = $(STEP1_DEPS) types.cr STEP3_DEPS = $(STEP2_DEPS) env.cr @@ -19,7 +18,7 @@ mal: $(LAST_STEP_BIN) cp $< $@ $(STEP_BINS): %: %.cr - crystal compile --release $< + crystal build --release $< step0_repl: $(STEP0_DEPS) step1_read_print: $(STEP1_DEPS) @@ -30,7 +29,7 @@ step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal clean: rm -rf $(STEP_BINS) mal .crystal -stats: types.cr error.cr readline.cr reader.cr printer.cr env.cr core.cr stepA_mal.cr +stats: types.cr error.cr reader.cr printer.cr env.cr core.cr stepA_mal.cr @wc $^ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" stats-lisp: env.cr core.cr stepA_mal.cr diff --git a/crystal/core.cr b/crystal/core.cr index 2694cf8542..52b66c89e1 100644 --- a/crystal/core.cr +++ b/crystal/core.cr @@ -1,456 +1,454 @@ require "time" +require "readline" require "./types" require "./error" require "./printer" require "./reader" -require "./readline" module Mal + macro calc_op(op) + -> (args : Array(Mal::Type)) { + x, y = args[0].unwrap, args[1].unwrap + eval_error "invalid arguments for binary operator {{op.id}}" unless x.is_a?(Int64) && y.is_a?(Int64) + Mal::Type.new(x {{op.id}} y) + } + end -macro calc_op(op) - -> (args : Array(Mal::Type)) { - x, y = args[0].unwrap, args[1].unwrap - eval_error "invalid arguments for binary operator {{op.id}}" unless x.is_a?(Int64) && y.is_a?(Int64) - Mal::Type.new(x {{op.id}} y) - } -end - -def self.list(args) - args.to_mal -end + def self.list(args) + args.to_mal + end -def self.list?(args) - args.first.unwrap.is_a? Mal::List -end + def self.list?(args) + args.first.unwrap.is_a? Mal::List + end -def self.empty?(args) - a = args.first.unwrap - a.is_a?(Array) ? a.empty? : false -end + def self.empty?(args) + a = args.first.unwrap + a.is_a?(Array) ? a.empty? : false + end -def self.count(args) - a = args.first.unwrap - case a - when Array - a.size.to_i64 - when Nil - 0i64 - else - eval_error "invalid argument for function 'count'" + def self.count(args) + a = args.first.unwrap + case a + when Array + a.size.to_i64 + when Nil + 0i64 + else + eval_error "invalid argument for function 'count'" + end end -end -def self.pr_str_(args) - args.map{|a| pr_str(a)}.join(" ") -end + def self.pr_str_(args) + args.map { |a| pr_str(a) }.join(" ") + end -def self.str(args) - args.map{|a| pr_str(a, false)}.join -end + def self.str(args) + args.map { |a| pr_str(a, false) }.join + end -def self.prn(args) - puts self.pr_str_(args) - nil -end + def self.prn(args) + puts self.pr_str_(args) + nil + end -def self.println(args) - puts args.map{|a| pr_str(a, false)}.join(" ") - nil -end + def self.println(args) + puts args.map { |a| pr_str(a, false) }.join(" ") + nil + end -def self.read_string(args) - head = args.first.unwrap - eval_error "argument of read-str must be string" unless head.is_a? String - read_str head -end + def self.read_string(args) + head = args.first.unwrap + eval_error "argument of read-str must be string" unless head.is_a? String + read_str head + end -def self.slurp(args) - head = args.first.unwrap - eval_error "argument of slurp must be string" unless head.is_a? String - begin - File.read head - rescue e : Errno - eval_error "no such file" + def self.slurp(args) + head = args.first.unwrap + eval_error "argument of slurp must be string" unless head.is_a? String + begin + File.read head + rescue e : Errno + eval_error "no such file" + end end -end -def self.cons(args) - head, tail = args[0] as Mal::Type, args[1].unwrap - eval_error "2nd arg of cons must be list" unless tail.is_a? Array - ([head] + tail).to_mal -end + def self.cons(args) + head, tail = args[0].as(Mal::Type), args[1].unwrap + eval_error "2nd arg of cons must be list" unless tail.is_a? Array + ([head] + tail).to_mal + end -def self.concat(args) - args.each_with_object(Mal::List.new) do |arg, list| - a = arg.unwrap - eval_error "arguments of concat must be list" unless a.is_a?(Array) - a.each{|e| list << e} + def self.concat(args) + args.each_with_object(Mal::List.new) do |arg, list| + a = arg.unwrap + eval_error "arguments of concat must be list" unless a.is_a?(Array) + a.each { |e| list << e } + end end -end -def self.nth(args) - a0, a1 = args[0].unwrap, args[1].unwrap - eval_error "1st argument of nth must be list or vector" unless a0.is_a? Array - eval_error "2nd argument of nth must be integer" unless a1.is_a? Int64 - a0[a1] -end + def self.nth(args) + a0, a1 = args[0].unwrap, args[1].unwrap + eval_error "1st argument of nth must be list or vector" unless a0.is_a? Array + eval_error "2nd argument of nth must be integer" unless a1.is_a? Int64 + a0[a1] + end -def self.first(args) - a0 = args[0].unwrap + def self.first(args) + a0 = args[0].unwrap - return nil if a0.nil? - eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array - a0.empty? ? nil : a0.first -end + return nil if a0.nil? + eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array + a0.empty? ? nil : a0.first + end -def self.rest(args) - a0 = args[0].unwrap + def self.rest(args) + a0 = args[0].unwrap - return Mal::List.new if a0.nil? - eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array - return Mal::List.new if a0.empty? - a0[1..-1].to_mal -end + return Mal::List.new if a0.nil? + eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array + return Mal::List.new if a0.empty? + a0[1..-1].to_mal + end -def self.apply(args) - eval_error "apply must take at least 2 arguments" unless args.size >= 2 + def self.apply(args) + eval_error "apply must take at least 2 arguments" unless args.size >= 2 - head = args.first.unwrap - last = args.last.unwrap + head = args.first.unwrap + last = args.last.unwrap - eval_error "last argument of apply must be list or vector" unless last.is_a? Array + eval_error "last argument of apply must be list or vector" unless last.is_a? Array - case head - when Mal::Closure - head.fn.call(args[1..-2] + last) - when Mal::Func - head.call(args[1..-2] + last) - else - eval_error "1st argument of apply must be function or closure" + case head + when Mal::Closure + head.fn.call(args[1..-2] + last) + when Mal::Func + head.call(args[1..-2] + last) + else + eval_error "1st argument of apply must be function or closure" + end end -end -def self.map(args) - func = args.first.unwrap - list = args[1].unwrap + def self.map(args) + func = args.first.unwrap + list = args[1].unwrap - eval_error "2nd argument of map must be list or vector" unless list.is_a? Array + eval_error "2nd argument of map must be list or vector" unless list.is_a? Array - f = case func - when Mal::Closure then func.fn - when Mal::Func then func - else eval_error "1st argument of map must be function" - end + f = case func + when Mal::Closure then func.fn + when Mal::Func then func + else eval_error "1st argument of map must be function" + end - list.each_with_object(Mal::List.new) do |elem, mapped| - mapped << f.call([elem]) + list.each_with_object(Mal::List.new) do |elem, mapped| + mapped << f.call([elem]) + end end -end - -def self.nil_value?(args) - args.first.unwrap.nil? -end -def self.true?(args) - a = args.first.unwrap - a.is_a?(Bool) && a -end - -def self.false?(args) - a = args.first.unwrap - a.is_a?(Bool) && !a -end - -def self.symbol?(args) - args.first.unwrap.is_a?(Mal::Symbol) -end + def self.nil_value?(args) + args.first.unwrap.nil? + end -def self.symbol(args) - head = args.first.unwrap - eval_error "1st argument of symbol function must be string" unless head.is_a? String - Mal::Symbol.new head -end + def self.true?(args) + a = args.first.unwrap + a.is_a?(Bool) && a + end -def self.string?(args) - head = args.first.unwrap - head.is_a?(String) && (head.empty? || head[0] != '\u029e') -end + def self.false?(args) + a = args.first.unwrap + a.is_a?(Bool) && !a + end -def self.keyword(args) - head = args.first.unwrap - eval_error "1st argument of symbol function must be string" unless head.is_a? String - "\u029e" + head -end + def self.symbol?(args) + args.first.unwrap.is_a?(Mal::Symbol) + end -def self.keyword?(args) - head = args.first.unwrap - head.is_a?(String) && !head.empty? && head[0] == '\u029e' -end + def self.symbol(args) + head = args.first.unwrap + eval_error "1st argument of symbol function must be string" unless head.is_a? String + Mal::Symbol.new head + end -def self.number?(args) - args.first.unwrap.is_a?(Int64) -end + def self.string?(args) + head = args.first.unwrap + head.is_a?(String) && (head.empty? || head[0] != '\u029e') + end -def self.fn?(args) - return false if args.first.macro? - head = args.first.unwrap - head.is_a?(Mal::Func) || head.is_a?(Mal::Closure) -end + def self.keyword(args) + head = args.first.unwrap + eval_error "1st argument of symbol function must be string" unless head.is_a? String + "\u029e" + head + end -def self.macro?(args) - args.first.macro? -end + def self.keyword?(args) + head = args.first.unwrap + head.is_a?(String) && !head.empty? && head[0] == '\u029e' + end -def self.vector(args) - args.to_mal(Mal::Vector) -end + def self.number?(args) + args.first.unwrap.is_a?(Int64) + end -def self.vector?(args) - args.first.unwrap.is_a? Mal::Vector -end + def self.fn?(args) + return false if args.first.macro? + head = args.first.unwrap + head.is_a?(Mal::Func) || head.is_a?(Mal::Closure) + end -def self.hash_map(args) - eval_error "hash-map must take even number of arguments" unless args.size.even? - map = Mal::HashMap.new - args.each_slice(2) do |kv| - k = kv[0].unwrap - eval_error "key must be string" unless k.is_a? String - map[k] = kv[1] + def self.macro?(args) + args.first.macro? end - map -end -def self.map?(args) - args.first.unwrap.is_a? Mal::HashMap -end + def self.vector(args) + args.to_mal(Mal::Vector) + end -def self.assoc(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - eval_error "assoc must take a list and even number of arguments" unless (args.size - 1).even? + def self.vector?(args) + args.first.unwrap.is_a? Mal::Vector + end - map = Mal::HashMap.new - head.each{|k, v| map[k] = v} + def self.hash_map(args) + eval_error "hash-map must take even number of arguments" unless args.size.even? + map = Mal::HashMap.new + args.each_slice(2) do |kv| + k = kv[0].unwrap + eval_error "key must be string" unless k.is_a? String + map[k] = kv[1] + end + map + end - args[1..-1].each_slice(2) do |kv| - k = kv[0].unwrap - eval_error "key must be string" unless k.is_a? String - map[k] = kv[1] + def self.map?(args) + args.first.unwrap.is_a? Mal::HashMap end - map -end + def self.assoc(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + eval_error "assoc must take a list and even number of arguments" unless (args.size - 1).even? -def self.dissoc(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + map = Mal::HashMap.new + head.each { |k, v| map[k] = v } - map = Mal::HashMap.new - head.each{|k,v| map[k] = v} + args[1..-1].each_slice(2) do |kv| + k = kv[0].unwrap + eval_error "key must be string" unless k.is_a? String + map[k] = kv[1] + end - args[1..-1].each do |arg| - key = arg.unwrap - eval_error "key must be string" unless key.is_a? String - map.delete key + map end - map -end + def self.dissoc(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap -def self.get(args) - a0, a1 = args[0].unwrap, args[1].unwrap - return nil unless a0.is_a? Mal::HashMap - eval_error "2nd argument of get must be string" unless a1.is_a? String + map = Mal::HashMap.new + head.each { |k, v| map[k] = v } - # a0[a1]? isn't available because type ofa0[a1] is infered NoReturn - a0.has_key?(a1) ? a0[a1] : nil -end + args[1..-1].each do |arg| + key = arg.unwrap + eval_error "key must be string" unless key.is_a? String + map.delete key + end -def self.contains?(args) - a0, a1 = args[0].unwrap, args[1].unwrap - eval_error "1st argument of get must be hashmap" unless a0.is_a? Mal::HashMap - eval_error "2nd argument of get must be string" unless a1.is_a? String - a0.has_key? a1 -end + map + end -def self.keys(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - head.keys.each_with_object(Mal::List.new){|e,l| l << Mal::Type.new(e)} -end + def self.get(args) + a0, a1 = args[0].unwrap, args[1].unwrap + return nil unless a0.is_a? Mal::HashMap + eval_error "2nd argument of get must be string" unless a1.is_a? String -def self.vals(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - head.values.to_mal -end + # a0[a1]? isn't available because type ofa0[a1] is infered NoReturn + a0.has_key?(a1) ? a0[a1] : nil + end -def self.sequential?(args) - args.first.unwrap.is_a? Array -end + def self.contains?(args) + a0, a1 = args[0].unwrap, args[1].unwrap + eval_error "1st argument of get must be hashmap" unless a0.is_a? Mal::HashMap + eval_error "2nd argument of get must be string" unless a1.is_a? String + a0.has_key? a1 + end -def self.readline(args) - head = args.first.unwrap - eval_error "1st argument of readline must be string" unless head.is_a? String - my_readline head -end + def self.keys(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + head.keys.each_with_object(Mal::List.new) { |e, l| l << Mal::Type.new(e) } + end -def self.meta(args) - m = args.first.meta - m.nil? ? nil : m -end + def self.vals(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + head.values.to_mal + end -def self.with_meta(args) - t = args.first.dup - t.meta = args[1] - t -end + def self.sequential?(args) + args.first.unwrap.is_a? Array + end -def self.atom(args) - Mal::Atom.new args.first -end + def self.readline(args) + head = args.first.unwrap + eval_error "1st argument of readline must be string" unless head.is_a? String + Readline.readline(head, true) + end -def self.atom?(args) - args.first.unwrap.is_a? Mal::Atom -end + def self.meta(args) + m = args.first.meta + m.nil? ? nil : m + end -def self.deref(args) - head = args.first.unwrap - eval_error "1st argument of deref must be atom" unless head.is_a? Mal::Atom - head.val -end + def self.with_meta(args) + t = args.first.dup + t.meta = args[1] + t + end -def self.reset!(args) - head = args.first.unwrap - eval_error "1st argument of reset! must be atom" unless head.is_a? Mal::Atom - head.val = args[1] -end + def self.atom(args) + Mal::Atom.new args.first + end -def self.swap!(args) - atom = args.first.unwrap - eval_error "1st argument of swap! must be atom" unless atom.is_a? Mal::Atom + def self.atom?(args) + args.first.unwrap.is_a? Mal::Atom + end - a = [atom.val] + args[2..-1] + def self.deref(args) + head = args.first.unwrap + eval_error "1st argument of deref must be atom" unless head.is_a? Mal::Atom + head.val + end - func = args[1].unwrap - case func - when Mal::Func - atom.val = func.call a - when Mal::Closure - atom.val = func.fn.call a - else - eval_error "2nd argumetn of swap! must be function" + def self.reset!(args) + head = args.first.unwrap + eval_error "1st argument of reset! must be atom" unless head.is_a? Mal::Atom + head.val = args[1] end -end -def self.conj(args) - seq = args.first.unwrap - case seq - when Mal::List - (args[1..-1].reverse + seq).to_mal - when Mal::Vector - (seq + args[1..-1]).to_mal(Mal::Vector) - else - eval_error "1st argument of conj must be list or vector" + def self.swap!(args) + atom = args.first.unwrap + eval_error "1st argument of swap! must be atom" unless atom.is_a? Mal::Atom + + a = [atom.val] + args[2..-1] + + func = args[1].unwrap + case func + when Mal::Func + atom.val = func.call a + when Mal::Closure + atom.val = func.fn.call a + else + eval_error "2nd argumetn of swap! must be function" + end end -end -def self.seq(args) - obj = args.first.unwrap - case obj - when nil - nil - when Mal::List - return nil if obj.empty? - obj - when Mal::Vector - return nil if obj.empty? - obj.to_mal - when String - return nil if obj.empty? - obj.split("").each_with_object(Mal::List.new){|e,l| l << Mal::Type.new(e)} - else - eval_error "argument of seq must be list or vector or string or nil" + def self.conj(args) + seq = args.first.unwrap + case seq + when Mal::List + (args[1..-1].reverse + seq).to_mal + when Mal::Vector + (seq + args[1..-1]).to_mal(Mal::Vector) + else + eval_error "1st argument of conj must be list or vector" + end end -end -def self.time_ms(args) - Time.now.epoch_ms.to_i64 -end + def self.seq(args) + obj = args.first.unwrap + case obj + when nil + nil + when Mal::List + return nil if obj.empty? + obj + when Mal::Vector + return nil if obj.empty? + obj.to_mal + when String + return nil if obj.empty? + obj.split("").each_with_object(Mal::List.new) { |e, l| l << Mal::Type.new(e) } + else + eval_error "argument of seq must be list or vector or string or nil" + end + end -# Note: -# Simply using ->self.some_func doesn't work -macro func(name) - -> (args : Array(Mal::Type)) { Mal::Type.new self.{{name.id}}(args) } -end + def self.time_ms(args) + Time.now.epoch_ms.to_i64 + end -macro rel_op(op) --> (args : Array(Mal::Type)) { Mal::Type.new (args[0] {{op.id}} args[1]) } -end + # Note: + # Simply using ->self.some_func doesn't work + macro func(name) + -> (args : Array(Mal::Type)) { Mal::Type.new self.{{name.id}}(args) } + end -NS = { - "+" => calc_op(:+), - "-" => calc_op(:-), - "*" => calc_op(:*), - "/" => calc_op(:/), - "list" => func(:list), - "list?" => func(:list?), - "empty?" => func(:empty?), - "count" => func(:count), - "=" => rel_op(:==), - "<" => rel_op(:<), - ">" => rel_op(:>), - "<=" => rel_op(:<=), - ">=" => rel_op(:>=), - "pr-str" => func(:pr_str_), - "str" => func(:str), - "prn" => func(:prn), - "println" => func(:println), - "read-string" => func(:read_string), - "slurp" => func(:slurp), - "cons" => func(:cons), - "concat" => func(:concat), - "nth" => func(:nth), - "first" => func(:first), - "rest" => func(:rest), - "throw" => -> (args : Array(Mal::Type)) { raise Mal::RuntimeException.new args[0] }, - "apply" => func(:apply), - "map" => func(:map), - "nil?" => func(:nil_value?), - "true?" => func(:true?), - "false?" => func(:false?), - "symbol?" => func(:symbol?), - "symbol" => func(:symbol), - "string?" => func(:string?), - "keyword" => func(:keyword), - "keyword?" => func(:keyword?), - "number?" => func(:number?), - "fn?" => func(:fn?), - "macro?" => func(:macro?), - "vector" => func(:vector), - "vector?" => func(:vector?), - "hash-map" => func(:hash_map), - "map?" => func(:map?), - "assoc" => func(:assoc), - "dissoc" => func(:dissoc), - "get" => func(:get), - "contains?" => func(:contains?), - "keys" => func(:keys), - "vals" => func(:vals), - "sequential?" => func(:sequential?), - "readline" => func(:readline), - "meta" => func(:meta), - "with-meta" => func(:with_meta), - "atom" => func(:atom), - "atom?" => func(:atom?), - "deref" => func(:deref), - "deref" => func(:deref), - "reset!" => func(:reset!), - "swap!" => func(:swap!), - "conj" => func(:conj), - "seq" => func(:seq), - "time-ms" => func(:time_ms), -} of String => Mal::Func + macro rel_op(op) + -> (args : Array(Mal::Type)) { Mal::Type.new (args[0] {{op.id}} args[1]) } + end + NS = { + "+" => calc_op(:+), + "-" => calc_op(:-), + "*" => calc_op(:*), + "/" => calc_op(:/), + "list" => func(:list), + "list?" => func(:list?), + "empty?" => func(:empty?), + "count" => func(:count), + "=" => rel_op(:==), + "<" => rel_op(:<), + ">" => rel_op(:>), + "<=" => rel_op(:<=), + ">=" => rel_op(:>=), + "pr-str" => func(:pr_str_), + "str" => func(:str), + "prn" => func(:prn), + "println" => func(:println), + "read-string" => func(:read_string), + "slurp" => func(:slurp), + "cons" => func(:cons), + "concat" => func(:concat), + "nth" => func(:nth), + "first" => func(:first), + "rest" => func(:rest), + "throw" => ->(args : Array(Mal::Type)) { raise Mal::RuntimeException.new args[0] }, + "apply" => func(:apply), + "map" => func(:map), + "nil?" => func(:nil_value?), + "true?" => func(:true?), + "false?" => func(:false?), + "symbol?" => func(:symbol?), + "symbol" => func(:symbol), + "string?" => func(:string?), + "keyword" => func(:keyword), + "keyword?" => func(:keyword?), + "number?" => func(:number?), + "fn?" => func(:fn?), + "macro?" => func(:macro?), + "vector" => func(:vector), + "vector?" => func(:vector?), + "hash-map" => func(:hash_map), + "map?" => func(:map?), + "assoc" => func(:assoc), + "dissoc" => func(:dissoc), + "get" => func(:get), + "contains?" => func(:contains?), + "keys" => func(:keys), + "vals" => func(:vals), + "sequential?" => func(:sequential?), + "readline" => func(:readline), + "meta" => func(:meta), + "with-meta" => func(:with_meta), + "atom" => func(:atom), + "atom?" => func(:atom?), + "deref" => func(:deref), + "deref" => func(:deref), + "reset!" => func(:reset!), + "swap!" => func(:swap!), + "conj" => func(:conj), + "seq" => func(:seq), + "time-ms" => func(:time_ms), + } of String => Mal::Func end diff --git a/crystal/env.cr b/crystal/env.cr index 572ceea34a..9c7a46253a 100644 --- a/crystal/env.cr +++ b/crystal/env.cr @@ -2,7 +2,6 @@ require "./types" require "./error" module Mal - class Env property data @@ -23,10 +22,10 @@ module Mal if sym.str == "&" eval_error "missing variable parameter name" if binds.size == idx - next_param = binds[idx+1].unwrap + next_param = binds[idx + 1].unwrap eval_error "bind name must be symbol" unless next_param.is_a? Mal::Symbol var_args = Mal::List.new - exprs[idx..-1].each{|e| var_args << e} if idx < exprs.size + exprs[idx..-1].each { |e| var_args << e } if idx < exprs.size @data[next_param.str] = Mal::Type.new var_args break end @@ -64,5 +63,4 @@ module Mal e.data[key] end end - end diff --git a/crystal/error.cr b/crystal/error.cr index b308a8a2c3..fb8f56c623 100644 --- a/crystal/error.cr +++ b/crystal/error.cr @@ -9,6 +9,7 @@ module Mal class RuntimeException < Exception getter :thrown + def initialize(@thrown : Type) super() end diff --git a/crystal/printer.cr b/crystal/printer.cr index cb9bf3611b..b6aeaab4fd 100644 --- a/crystal/printer.cr +++ b/crystal/printer.cr @@ -5,17 +5,17 @@ def pr_str(value, print_readably = true) when Nil then "nil" when Bool then value.to_s when Int64 then value.to_s - when Mal::List then "(#{value.map{|v| pr_str(v, print_readably) as String}.join(" ")})" - when Mal::Vector then "[#{value.map{|v| pr_str(v, print_readably) as String}.join(" ")}]" + when Mal::List then "(#{value.map { |v| pr_str(v, print_readably).as(String) }.join(" ")})" + when Mal::Vector then "[#{value.map { |v| pr_str(v, print_readably).as(String) }.join(" ")}]" when Mal::Symbol then value.str.to_s when Mal::Func then "" when Mal::Closure then "" when Mal::HashMap # step1_read_print.cr requires specifying type - "{#{value.map{|k, v| "#{pr_str(k, print_readably)} #{pr_str(v, print_readably)}" as String}.join(" ")}}" + "{#{value.map { |k, v| "#{pr_str(k, print_readably)} #{pr_str(v, print_readably)}".as(String) }.join(" ")}}" when String case - when value.empty?() + when value.empty? print_readably ? value.inspect : value when value[0] == '\u029e' ":#{value[1..-1]}" diff --git a/crystal/reader.cr b/crystal/reader.cr index 34b469220c..3fbbd7c97a 100644 --- a/crystal/reader.cr +++ b/crystal/reader.cr @@ -30,7 +30,7 @@ class Reader def read_sequence(init, open, close) token = self.next parse_error "expected '#{open}', got EOF" unless token - parse_error "expected '#{open}', got #{token}" unless token[0] == open + parse_error "expected '#{open}', got #{token}" unless token[0] == open loop do token = peek @@ -81,11 +81,11 @@ class Reader when token == "true" then true when token == "false" then false when token == "nil" then nil - when token[0] == '"' then token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", - "\\n" => "\n", - "\\\\" => "\\"}) - when token[0] == ':' then "\u029e#{token[1..-1]}" - else Mal::Symbol.new token + when token[0] == '"' then token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", + "\\n" => "\n", + "\\\\" => "\\"}) + when token[0] == ':' then "\u029e#{token[1..-1]}" + else Mal::Symbol.new token end end @@ -118,12 +118,11 @@ class Reader else read_atom end end - end def tokenize(str) regex = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/ - str.scan(regex).map{|m| m[1]}.reject(&.empty?) + str.scan(regex).map { |m| m[1] }.reject(&.empty?) end def read_str(str) @@ -136,4 +135,3 @@ def read_str(str) end end end - diff --git a/crystal/readline.cr b/crystal/readline.cr deleted file mode 100644 index e57099a954..0000000000 --- a/crystal/readline.cr +++ /dev/null @@ -1,21 +0,0 @@ -# Note: -# Crystal already has "readline" library. -# I implemented a subset of it again for practice. - -@[Link("readline")] -lib LibReadline - fun readline(prompt : UInt8*) : UInt8* - fun add_history(line : UInt8*) -end - -def my_readline(prompt = "") - line = LibReadline.readline(prompt) - if line - LibReadline.add_history(line) - String.new(line) - else - nil - end -ensure - LibC.free(line as Void*) if line -end diff --git a/crystal/step0_repl.cr b/crystal/step0_repl.cr index e1fe58a398..a9c67d68f2 100755 --- a/crystal/step0_repl.cr +++ b/crystal/step0_repl.cr @@ -1,26 +1,26 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" # Note: # Employed downcase names because Crystal prohibits uppercase names for methods def read(x) - x + x end def eval(x) - x + x end def print(x) - x + x end def rep(x) - read(eval(print(x))) + read(eval(print(x))) end -while line = my_readline("user> ") - puts rep(line) +while line = Readline.readline("user> ") + puts rep(line) end diff --git a/crystal/step1_read_print.cr b/crystal/step1_read_print.cr index 9da58c35fc..cdc05d57e1 100755 --- a/crystal/step1_read_print.cr +++ b/crystal/step1_read_print.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" @@ -15,7 +15,7 @@ module Mal end def eval(x) - x + x end def print(result) @@ -27,7 +27,7 @@ module Mal end end -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step2_eval.cr b/crystal/step2_eval.cr index f93b957e73..eeef93c360 100755 --- a/crystal/step2_eval.cr +++ b/crystal/step2_eval.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -16,7 +16,7 @@ module Mal end def num_func(func) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { x, y = args[0].unwrap, args[1].unwrap eval_error "invalid arguments" unless x.is_a?(Int64) && y.is_a?(Int64) Mal::Type.new func.call(x, y) @@ -24,7 +24,7 @@ module Mal end def eval_ast(a, env) - return a.map{|n| eval(n, env) as Mal::Type} if a.is_a? Mal::List + return a.map { |n| eval(n, env).as(Mal::Type) } if a.is_a? Mal::List return a unless a ast = a.unwrap @@ -36,11 +36,12 @@ module Mal eval_error "'#{ast.str}' not found" end when Mal::List - ast.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + ast.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - ast.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + ast.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Mal::HashMap - ast.each{|k, v| ast[k] = eval(v, env)} + ast.each { |k, v| ast[k] = eval(v, env) } + ast else ast end @@ -74,18 +75,18 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = { - "+" => Mal.num_func(->(x : Int64, y : Int64){ x + y }), - "-" => Mal.num_func(->(x : Int64, y : Int64){ x - y }), - "*" => Mal.num_func(->(x : Int64, y : Int64){ x * y }), - "/" => Mal.num_func(->(x : Int64, y : Int64){ x / y }), +REPL_ENV = { + "+" => Mal.num_func(->(x : Int64, y : Int64) { x + y }), + "-" => Mal.num_func(->(x : Int64, y : Int64) { x - y }), + "*" => Mal.num_func(->(x : Int64, y : Int64) { x * y }), + "/" => Mal.num_func(->(x : Int64, y : Int64) { x / y }), } of String => Mal::Func -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step3_env.cr b/crystal/step3_env.cr index 62543e81e4..171dd89a2f 100755 --- a/crystal/step3_env.cr +++ b/crystal/step3_env.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -14,24 +14,24 @@ def eval_error(msg) end def num_func(func) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { x, y = args[0].unwrap, args[1].unwrap eval_error "invalid arguments" unless x.is_a?(Int64) && y.is_a?(Int64) Mal::Type.new func.call(x, y) } end -$repl_env = Mal::Env.new nil -$repl_env.set("+", Mal::Type.new num_func(->(x : Int64, y : Int64){ x + y })) -$repl_env.set("-", Mal::Type.new num_func(->(x : Int64, y : Int64){ x - y })) -$repl_env.set("*", Mal::Type.new num_func(->(x : Int64, y : Int64){ x * y })) -$repl_env.set("/", Mal::Type.new num_func(->(x : Int64, y : Int64){ x / y })) +REPL_ENV = Mal::Env.new nil +REPL_ENV.set("+", Mal::Type.new num_func(->(x : Int64, y : Int64) { x + y })) +REPL_ENV.set("-", Mal::Type.new num_func(->(x : Int64, y : Int64) { x - y })) +REPL_ENV.set("*", Mal::Type.new num_func(->(x : Int64, y : Int64) { x * y })) +REPL_ENV.set("/", Mal::Type.new num_func(->(x : Int64, y : Int64) { x / y })) module Mal extend self def eval_ast(a, env) - return a.map{|n| eval(n, env) } if a.is_a? Array + return a.map { |n| eval(n, env) } if a.is_a? Array Mal::Type.new case ast = a.unwrap when Mal::Symbol @@ -41,12 +41,12 @@ module Mal eval_error "'#{ast.str}' not found" end when Mal::List - ast.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + ast.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - ast.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + ast.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Mal::HashMap new_map = Mal::HashMap.new - ast.each{|k, v| new_map[k] = eval(v, env)} + ast.each { |k, v| new_map[k] = eval(v, env) } new_map else ast @@ -71,7 +71,7 @@ module Mal eval_error "wrong number of argument for 'def!'" unless ast.size == 3 a1 = ast[1].unwrap eval_error "1st argument of 'def!' must be symbol" unless a1.is_a?(Mal::Symbol) - env.set(a1.str, eval(ast[2], env) as Mal::Type) + env.set(a1.str, eval(ast[2], env).as(Mal::Type)) when "let*" eval_error "wrong number of argument for 'def!'" unless ast.size == 3 @@ -93,7 +93,7 @@ module Mal args = eval_ast(ast, env) if f.is_a?(Mal::Type) && (f2 = f.unwrap).is_a?(Mal::Func) - f2.call(args as Array(Mal::Type)) + f2.call(args.as(Array(Mal::Type))) else eval_error "expected function symbol as the first symbol of list" end @@ -105,11 +105,11 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step4_if_fn_do.cr b/crystal/step4_if_fn_do.cr index de3e65bbd6..c20f1300d2 100755 --- a/crystal/step4_if_fn_do.cr +++ b/crystal/step4_if_fn_do.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -15,14 +15,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Mal::List + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List val = ast.unwrap @@ -34,11 +34,11 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Mal::HashMap - val.each{|k, v| val[k] = eval(v, env)} + val.each { |k, v| val[k] = eval(v, env) } val else val @@ -48,7 +48,7 @@ module Mal def eval_invocation(list, env) f = eval(list.first, env).unwrap eval_error "expected function symbol as the first symbol of list" unless f.is_a? Mal::Func - f.call eval_ast(list[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) + f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) end def read(str) @@ -58,7 +58,7 @@ module Mal def eval(ast, env) list = ast.unwrap - return eval_ast(ast, env) unless list.is_a? Mal::List + return eval_ast(ast, env) unless list.is_a? Mal::List return gen_type Mal::List if list.empty? head = list.first.unwrap @@ -96,7 +96,7 @@ module Mal when Nil list.size >= 4 ? eval(list[3], env) : nil when false - list.size >= 4 ? eval(list[3], env) : nil + list.size >= 4 ? eval(list[3], env) : nil else eval(list[2], env) end @@ -117,15 +117,15 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } Mal.rep "(def! not (fn* (a) (if a false true)))" -while line = my_readline("user> ") +while line = Readline.readline("user> ") begin puts Mal.rep(line) rescue e diff --git a/crystal/step5_tco.cr b/crystal/step5_tco.cr index 061293fc3f..e56db4a6b9 100755 --- a/crystal/step5_tco.cr +++ b/crystal/step5_tco.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -15,14 +15,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Mal::List + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List val = ast.unwrap @@ -34,13 +34,13 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Array(Mal::Type) - val.map{|n| eval(n, env)} + val.map { |n| eval(n, env).as(Mal::Type) } when Mal::HashMap - val.each{|k, v| val[k] = eval(v, env)} + val.each { |k, v| val[k] = eval(v, env) } val else val @@ -51,9 +51,9 @@ module Mal f = eval(list.first, env).unwrap case f when Mal::Closure - f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) + f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) when Mal::Func - f.call eval_ast(list[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) + f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) else eval_error "expected function as the first argument" end @@ -94,55 +94,55 @@ module Mal end return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new){|i,l| l << i}, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - # Note: - # If writing lambda expression here directly, compiler will fail to infer type of 'list'. (Error 'Nil for empty?') - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list" - end - Mal::Closure.new(list[2], params, env, func_of(env, list[1].unwrap, list[2])) + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) else - invoke_list list + list[2] end + next # TCO + when "fn*" + # Note: + # If writing lambda expression here directly, compiler will fail to infer type of 'list'. (Error 'Nil for empty?') + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list" + end + Mal::Closure.new(list[2], params, env, func_of(env, list[1].unwrap, list[2])) + else + invoke_list list + end end end @@ -151,15 +151,15 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } Mal.rep "(def! not (fn* (a) (if a false true)))" -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step6_file.cr b/crystal/step6_file.cr index 594ed9279c..9997a2f7fa 100755 --- a/crystal/step6_file.cr +++ b/crystal/step6_file.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -15,14 +15,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Mal::List + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List val = ast.unwrap @@ -34,13 +34,13 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Array(Mal::Type) - val.map{|n| eval(n, env)} + val.map { |n| eval(n, env).as(Mal::Type) } when Mal::HashMap - val.each{|k, v| val[k] = eval(v, env)} + val.each { |k, v| val[k] = eval(v, env) } val else val @@ -51,9 +51,9 @@ module Mal f = eval(list.first, env).unwrap case f when Mal::Closure - f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) + f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) when Mal::Func - f.call eval_ast(list[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) + f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) else eval_error "expected function as the first argument" end @@ -94,53 +94,53 @@ module Mal end return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new){|i,l| l << i}, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) else - invoke_list(list, env) + list[2] end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + else + invoke_list(list, env) + end end end @@ -149,22 +149,22 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} -$repl_env.set("eval", Mal::Type.new -> (args: Array(Mal::Type)){ Mal.eval(args[0], $repl_env) }) +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) Mal.rep "(def! not (fn* (a) (if a false true)))" Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" -$argv = Mal::List.new -$repl_env.set("*ARGV*", Mal::Type.new $argv) +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) unless ARGV.empty? if ARGV.size > 1 ARGV[1..-1].each do |a| - $argv << Mal::Type.new(a) + argv << Mal::Type.new(a) end end @@ -172,7 +172,7 @@ unless ARGV.empty? exit end -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step7_quote.cr b/crystal/step7_quote.cr index a1d5708ff3..92d2ab44ec 100755 --- a/crystal/step7_quote.cr +++ b/crystal/step7_quote.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -15,14 +15,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Mal::List + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List val = ast.unwrap @@ -34,13 +34,13 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Array(Mal::Type) - val.map{|n| eval(n, env)} + val.map { |n| eval(n, env).as(Mal::Type) } when Mal::HashMap - val.each{|k, v| val[k] = eval(v, env)} + val.each { |k, v| val[k] = eval(v, env) } val else val @@ -70,14 +70,14 @@ module Mal # ("unquote" ...) when head.is_a?(Mal::Symbol) && head.str == "unquote" list[1] - # (("splice-unquote" ...) ...) + # (("splice-unquote" ...) ...) when is_pair(head) && (arg0 = head.first.unwrap).is_a?(Mal::Symbol) && arg0.str == "splice-unquote" - tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new){|e,l| l << e} + tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new) { |e, l| l << e } Mal::Type.new( Mal::List.new << gen_type(Mal::Symbol, "concat") << head[1] << quasiquote(tail) ) else - tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new){|e,l| l << e} + tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new) { |e, l| l << e } Mal::Type.new( Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(list.first) << quasiquote(tail) ) @@ -115,58 +115,58 @@ module Mal end return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new){|i,l| l << i}, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) else - invoke_list(list, env) + list[2] end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + else + invoke_list(list, env) + end end end @@ -175,22 +175,22 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} -$repl_env.set("eval", Mal::Type.new -> (args: Array(Mal::Type)){ Mal.eval(args[0], $repl_env) }) +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) Mal.rep "(def! not (fn* (a) (if a false true)))" Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" -$argv = Mal::List.new -$repl_env.set("*ARGV*", Mal::Type.new $argv) +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) unless ARGV.empty? if ARGV.size > 1 ARGV[1..-1].each do |a| - $argv << Mal::Type.new(a) + argv << Mal::Type.new(a) end end @@ -202,7 +202,7 @@ unless ARGV.empty? exit end -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step8_macros.cr b/crystal/step8_macros.cr index 5f1c63af7f..061649b9af 100755 --- a/crystal/step8_macros.cr +++ b/crystal/step8_macros.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -15,14 +15,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Mal::List + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List val = ast.unwrap @@ -34,13 +34,13 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Array(Mal::Type) - val.map{|n| eval(n, env)} + val.map { |n| eval(n, env).as(Mal::Type) } when Mal::HashMap - val.each{|k, v| val[k] = eval(v, env)} + val.each { |k, v| val[k] = eval(v, env) } val else val @@ -70,14 +70,14 @@ module Mal # ("unquote" ...) when head.is_a?(Mal::Symbol) && head.str == "unquote" list[1] - # (("splice-unquote" ...) ...) + # (("splice-unquote" ...) ...) when pair?(head) && (arg0 = head.first.unwrap).is_a?(Mal::Symbol) && arg0.str == "splice-unquote" - tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new){|e,l| l << e} + tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new) { |e, l| l << e } Mal::Type.new( Mal::List.new << gen_type(Mal::Symbol, "concat") << head[1] << quasiquote(tail) ) else - tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new){|e,l| l << e} + tail = Mal::Type.new list[1..-1].each_with_object(Mal::List.new) { |e, l| l << e } Mal::Type.new( Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(list.first) << quasiquote(tail) ) @@ -99,10 +99,9 @@ module Mal def macroexpand(ast, env) while macro_call?(ast, env) - # Already checked in macro_call? - list = ast.unwrap as Mal::List - func_sym = list[0].unwrap as Mal::Symbol + list = ast.unwrap.as(Mal::List) + func_sym = list[0].unwrap.as(Mal::Symbol) func = env.get(func_sym.str).unwrap case func @@ -151,65 +150,65 @@ module Mal return invoke_list(list, env) unless head.is_a? Mal::Symbol return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new){|i,l| l << i}, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list or vector: #{params}" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - when "defmacro!" - eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env).tap{|n| n.is_macro = true}) - when "macroexpand" - macroexpand(list[1], env) + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) else - invoke_list(list, env) + list[2] + end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list or vector: #{params}" end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + when "defmacro!" + eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) + when "macroexpand" + macroexpand(list[1], env) + else + invoke_list(list, env) + end end end @@ -218,25 +217,25 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} -$repl_env.set("eval", Mal::Type.new -> (args: Array(Mal::Type)){ Mal.eval(args[0], $repl_env) }) +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) Mal.rep "(def! not (fn* (a) (if a false true)))" Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" Mal.rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" Mal.rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" -$argv = Mal::List.new -$repl_env.set("*ARGV*", Mal::Type.new $argv) +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) unless ARGV.empty? if ARGV.size > 1 ARGV[1..-1].each do |a| - $argv << Mal::Type.new(a) + argv << Mal::Type.new(a) end end @@ -248,7 +247,7 @@ unless ARGV.empty? exit end -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/step9_try.cr b/crystal/step9_try.cr index 74685d4ae5..4853cc80f3 100755 --- a/crystal/step9_try.cr +++ b/crystal/step9_try.cr @@ -1,6 +1,6 @@ #! /usr/bin/env crystal run -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -15,14 +15,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Mal::List + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List val = ast.unwrap @@ -34,13 +34,13 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Array(Mal::Type) - val.map{|n| eval(n, env)} + val.map { |n| eval(n, env).as(Mal::Type) } when Mal::HashMap - val.each{|k, v| val[k] = eval(v, env)} + val.each { |k, v| val[k] = eval(v, env) } val else val @@ -70,7 +70,7 @@ module Mal # ("unquote" ...) when head.is_a?(Mal::Symbol) && head.str == "unquote" list[1] - # (("splice-unquote" ...) ...) + # (("splice-unquote" ...) ...) when pair?(head) && (arg0 = head.first.unwrap).is_a?(Mal::Symbol) && arg0.str == "splice-unquote" tail = Mal::Type.new list[1..-1].to_mal Mal::Type.new( @@ -99,10 +99,9 @@ module Mal def macroexpand(ast, env) while macro_call?(ast, env) - # Already checked in macro_call? - list = ast.unwrap as Mal::List - func_sym = list[0].unwrap as Mal::Symbol + list = ast.unwrap.as(Mal::List) + func_sym = list[0].unwrap.as(Mal::Symbol) func = env.get(func_sym.str).unwrap case func @@ -151,82 +150,82 @@ module Mal return invoke_list(list, env) unless head.is_a? Mal::Symbol return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].to_mal, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list or vector: #{params}" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - when "defmacro!" - eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env).tap{|n| n.is_macro = true}) - when "macroexpand" - macroexpand(list[1], env) - when "try*" - catch_list = list[2].unwrap - return eval(list[1], env) unless catch_list.is_a? Mal::List - - catch_head = catch_list.first.unwrap - return eval(list[1], env) unless catch_head.is_a? Mal::Symbol - return eval(list[1], env) unless catch_head.str == "catch*" - - begin - eval(list[1], env) - rescue e : Mal::RuntimeException - new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) - eval(catch_list[2], new_env) - rescue e - new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) - eval(catch_list[2], new_env) - end + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].to_mal, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) else - invoke_list(list, env) + list[2] end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list or vector: #{params}" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + when "defmacro!" + eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) + when "macroexpand" + macroexpand(list[1], env) + when "try*" + catch_list = list[2].unwrap + return eval(list[1], env) unless catch_list.is_a? Mal::List + + catch_head = catch_list.first.unwrap + return eval(list[1], env) unless catch_head.is_a? Mal::Symbol + return eval(list[1], env) unless catch_head.str == "catch*" + + begin + eval(list[1], env) + rescue e : Mal::RuntimeException + new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) + eval(catch_list[2], new_env) + rescue e + new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) + eval(catch_list[2], new_env) + end + else + invoke_list(list, env) + end end end @@ -235,25 +234,25 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} -$repl_env.set("eval", Mal::Type.new -> (args: Array(Mal::Type)){ Mal.eval(args[0], $repl_env) }) +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) Mal.rep "(def! not (fn* (a) (if a false true)))" Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" Mal.rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" Mal.rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" -$argv = Mal::List.new -$repl_env.set("*ARGV*", Mal::Type.new $argv) +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) unless ARGV.empty? if ARGV.size > 1 ARGV[1..-1].each do |a| - $argv << Mal::Type.new(a) + argv << Mal::Type.new(a) end end @@ -265,7 +264,7 @@ unless ARGV.empty? exit end -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/stepA_mal.cr b/crystal/stepA_mal.cr index baaa8a6c9c..f71be26aa3 100755 --- a/crystal/stepA_mal.cr +++ b/crystal/stepA_mal.cr @@ -2,7 +2,7 @@ require "colorize" -require "./readline" +require "readline" require "./reader" require "./printer" require "./types" @@ -17,14 +17,14 @@ module Mal extend self def func_of(env, binds, body) - -> (args : Array(Mal::Type)) { + ->(args : Array(Mal::Type)) { new_env = Mal::Env.new(env, binds, args) eval(body, new_env) - } as Mal::Func + }.as(Mal::Func) end def eval_ast(ast, env) - return ast.map{|n| eval(n, env) as Mal::Type} if ast.is_a? Array + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Array val = ast.unwrap @@ -36,12 +36,12 @@ module Mal eval_error "'#{val.str}' not found" end when Mal::List - val.each_with_object(Mal::List.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } when Mal::Vector - val.each_with_object(Mal::Vector.new){|n, l| l << eval(n, env)} + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } when Mal::HashMap new_map = Mal::HashMap.new - val.each{|k, v| new_map[k] = eval(v, env)} + val.each { |k, v| new_map[k] = eval(v, env) } new_map else val @@ -71,7 +71,7 @@ module Mal # ("unquote" ...) when head.is_a?(Mal::Symbol) && head.str == "unquote" list[1] - # (("splice-unquote" ...) ...) + # (("splice-unquote" ...) ...) when pair?(head) && (arg0 = head.first.unwrap).is_a?(Mal::Symbol) && arg0.str == "splice-unquote" tail = Mal::Type.new list[1..-1].to_mal Mal::Type.new( @@ -101,10 +101,9 @@ module Mal def macroexpand(ast, env) while macro_call?(ast, env) - # Already checked in macro_call? - list = ast.unwrap as Mal::List - func_sym = list[0].unwrap as Mal::Symbol + list = ast.unwrap.as(Mal::List) + func_sym = list[0].unwrap.as(Mal::Symbol) func = env.get(func_sym.str).unwrap case func @@ -122,7 +121,7 @@ module Mal macro invoke_list(l, env) f = eval({{l}}.first, {{env}}).unwrap - args = eval_ast({{l}}[1..-1], {{env}}) as Array + args = eval_ast({{l}}[1..-1], {{env}}).as(Array) case f when Mal::Closure @@ -158,82 +157,82 @@ module Mal return invoke_list(list, env) unless head.is_a? Mal::Symbol return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].to_mal, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list or vector: #{params}" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - when "defmacro!" - eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env).tap{|n| n.is_macro = true}) - when "macroexpand" - macroexpand(list[1], env) - when "try*" - catch_list = list[2].unwrap - return eval(list[1], env) unless catch_list.is_a? Mal::List - - catch_head = catch_list.first.unwrap - return eval(list[1], env) unless catch_head.is_a? Mal::Symbol - return eval(list[1], env) unless catch_head.str == "catch*" - - begin - eval(list[1], env) - rescue e : Mal::RuntimeException - new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) - eval(catch_list[2], new_env) - rescue e - new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) - eval(catch_list[2], new_env) - end + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].to_mal, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) else - invoke_list(list, env) + list[2] end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list or vector: #{params}" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + when "defmacro!" + eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) + when "macroexpand" + macroexpand(list[1], env) + when "try*" + catch_list = list[2].unwrap + return eval(list[1], env) unless catch_list.is_a? Mal::List + + catch_head = catch_list.first.unwrap + return eval(list[1], env) unless catch_head.is_a? Mal::Symbol + return eval(list[1], env) unless catch_head.str == "catch*" + + begin + eval(list[1], env) + rescue e : Mal::RuntimeException + new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) + eval(catch_list[2], new_env) + rescue e + new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) + eval(catch_list[2], new_env) + end + else + invoke_list(list, env) + end end end @@ -242,13 +241,13 @@ module Mal end def rep(str) - print(eval(read(str), $repl_env)) + print(eval(read(str), REPL_ENV)) end end -$repl_env = Mal::Env.new nil -Mal::NS.each{|k,v| $repl_env.set(k, Mal::Type.new(v))} -$repl_env.set("eval", Mal::Type.new -> (args: Array(Mal::Type)){ Mal.eval(args[0], $repl_env) }) +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) Mal.rep "(def! not (fn* (a) (if a false true)))" Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" Mal.rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" @@ -257,13 +256,13 @@ Mal.rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* Mal.rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))" Mal.rep("(def! *host-language* \"crystal\")") -$argv = Mal::List.new -$repl_env.set("*ARGV*", Mal::Type.new $argv) +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) unless ARGV.empty? if ARGV.size > 1 ARGV[1..-1].each do |a| - $argv << Mal::Type.new(a) + argv << Mal::Type.new(a) end end @@ -277,7 +276,7 @@ end Mal.rep("(println (str \"Mal [\" *host-language* \"]\"))") -while line = my_readline("user> ") +while line = Readline.readline("user> ", true) begin puts Mal.rep(line) rescue e diff --git a/crystal/types.cr b/crystal/types.cr index 0c879f923f..10c36da5fa 100644 --- a/crystal/types.cr +++ b/crystal/types.cr @@ -1,50 +1,14 @@ require "./printer" module Mal - class Symbol - property :str - def initialize(@str : String) - end - - def ==(other : Symbol) - @str == other.str - end - end - - class List < Array(Type) - end - - class Vector < Array(Type) - end - - class HashMap < Hash(String, Type) - end - - class Atom - property :val - def initialize(@val : Type) - end - - def ==(rhs : Atom) - @val == rhs.val - end - end - - class Closure - property :ast, :params, :env, :fn - def initialize(@ast : Type, @params : List | Vector, @env : Env, @fn : Func) - end - end - class Type alias Func = (Array(Type) -> Type) - alias ValueType = Nil | Bool | Int64 | String | Symbol | List | Vector | HashMap | Func | Closure | Atom property :is_macro, :meta def initialize(@val : ValueType) @is_macro = false - @meta = nil as Type? + @meta = nil.as(Type | Nil) end def initialize(other : Type) @@ -96,6 +60,45 @@ module Mal rel_op :<, :>, :<=, :>= end + class Symbol + property :str + + def initialize(@str : String) + end + + def ==(other : Symbol) + @str == other.str + end + end + + class List < Array(Type) + end + + class Vector < Array(Type) + end + + class HashMap < Hash(String, Type) + end + + class Atom + property :val + + def initialize(@val : Type) + end + + def ==(rhs : Atom) + @val == rhs.val + end + end + + class Closure + property :ast, :params, :env, :fn + + def initialize(@ast : Type, @params : Array(Mal::Type) | List | Vector, @env : Env, @fn : Func) + end + end + + alias Type::ValueType = Nil | Bool | Int64 | String | Symbol | List | Vector | HashMap | Func | Closure | Atom alias Func = Type::Func end @@ -105,7 +108,6 @@ end class Array def to_mal(t = Mal::List) - each_with_object(t.new){|e, l| l << e} + each_with_object(t.new) { |e, l| l << e } end end - From 9bd2b1ef868fd3621c73355b966fd336762a67f3 Mon Sep 17 00:00:00 2001 From: Vitaly Shukela Date: Sat, 10 Nov 2018 00:24:56 +0300 Subject: [PATCH 0390/1998] Add link to my Rust implementation I assume this README serves as a wiki for collecting impls. --- README.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index ecda6ebd5f..9e6585e6a7 100644 --- a/README.md +++ b/README.md @@ -891,7 +891,10 @@ cd rust cargo run --release --bin stepX_YYY ``` -There is also a separate implementation in [Rust by Tim Morgan](https://github.com/seven1m/mal-rust). +Alternative out-of-tee Rust implementations: + +* [by Tim Morgan](https://github.com/seven1m/mal-rust). +* [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). ### Scala ### From e10ceff503b702b513ab61233bde06ef00281df1 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 28 Nov 2018 17:12:17 -0600 Subject: [PATCH 0391/1998] Update JS impls: use ffi-napi and Ubuntu 18.04 --- .gitignore | 3 +++ clojure/Dockerfile | 11 +++++++---- clojure/package.json | 4 ++-- clojure/project.clj | 2 +- clojure/src/mal/node_readline.js | 2 +- clojure/src/mal/readline.cljs | 2 +- coffee/Dockerfile | 12 +++++------- coffee/node_readline.coffee | 2 +- coffee/package.json | 4 ++-- crystal/Dockerfile | 4 ++-- elm/Dockerfile | 14 +++++++++----- elm/node_readline.js | 2 +- elm/package.json | 2 +- es6/Dockerfile | 8 ++++---- es6/core.mjs | 8 +++++--- es6/node_readline.js | 2 +- es6/package.json | 6 +++--- es6/run | 2 +- es6/step0_repl.mjs | 3 ++- es6/step1_read_print.mjs | 3 ++- es6/step2_eval.mjs | 3 ++- es6/step3_env.mjs | 3 ++- es6/step4_if_fn_do.mjs | 3 ++- es6/step5_tco.mjs | 3 ++- es6/step6_file.mjs | 3 ++- es6/step7_quote.mjs | 3 ++- es6/step8_macros.mjs | 3 ++- es6/step9_try.mjs | 3 ++- es6/stepA_mal.mjs | 3 ++- haxe/Dockerfile | 10 ++++------ haxe/node_readline.js | 2 +- haxe/package.json | 2 +- js/Dockerfile | 11 ++++------- js/node_readline.js | 2 +- js/package.json | 2 +- livescript/Dockerfile | 8 ++++---- livescript/node_readline.js | 2 +- livescript/package.json | 4 ++-- miniMAL/Dockerfile | 10 ++++------ miniMAL/node_readline.js | 2 +- miniMAL/package.json | 2 +- ts/Dockerfile | 12 +++++++++--- ts/node_readline.ts | 2 +- ts/package.json | 4 ++-- 44 files changed, 109 insertions(+), 89 deletions(-) diff --git a/.gitignore b/.gitignore index a7558f61af..f3eac16c45 100644 --- a/.gitignore +++ b/.gitignore @@ -71,6 +71,8 @@ haxe/*.js java/mal.jar java/target/ java/dependency-reduced-pom.xml +.npm/ +.node-gyp/ js/mal.js js/web/mal.js kotlin/*.jar @@ -103,6 +105,7 @@ ps/mal.ps python/mal.pyz r/mal.r ruby/mal.rb +.cargo/ rust/target/ rust/Cargo.lock rust/.cargo diff --git a/clojure/Dockerfile b/clojure/Dockerfile index 5060a80322..2d1dea49a3 100644 --- a/clojure/Dockerfile +++ b/clojure/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:17.10 +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -40,12 +40,15 @@ ENV LEIN_JVM_OPTS -Duser.home=/mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 8.X -RUN curl -sL https://deb.nodesource.com/setup_8.x | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - -# Install nodejs. +# Install nodejs RUN apt-get -y install nodejs +ENV NPM_CONFIG_CACHE /mal/.npm + ## Install ffi and lumo-cljs modules globally #RUN npm install -g ffi lumo-cljs diff --git a/clojure/package.json b/clojure/package.json index e2248254f0..904cd367e2 100644 --- a/clojure/package.json +++ b/clojure/package.json @@ -3,7 +3,7 @@ "version": "0.0.1", "description": "Make a Lisp (mal) language implemented in ClojureScript", "dependencies": { - "ffi": "2.2.x", - "lumo-cljs": "1.7.x" + "ffi-napi": "2.4.x", + "lumo-cljs": "1.9.x" } } diff --git a/clojure/project.clj b/clojure/project.clj index f2eea933b3..5bb5f960d0 100644 --- a/clojure/project.clj +++ b/clojure/project.clj @@ -1,7 +1,7 @@ (defproject mal "0.0.1-SNAPSHOT" :description "Make-A-Lisp" - :dependencies [[org.clojure/clojure "1.8.0-RC4"] + :dependencies [[org.clojure/clojure "1.9.0"] [org.clojure/tools.reader "0.8.3"] [net.n01se/clojure-jna "1.0.0"]] diff --git a/clojure/src/mal/node_readline.js b/clojure/src/mal/node_readline.js index dc64e3f642..6042eaa0af 100644 --- a/clojure/src/mal/node_readline.js +++ b/clojure/src/mal/node_readline.js @@ -6,7 +6,7 @@ var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); var rlwrap = {}; // namespace for this module in web context -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/clojure/src/mal/readline.cljs b/clojure/src/mal/readline.cljs index 88f3117a24..ea21874541 100644 --- a/clojure/src/mal/readline.cljs +++ b/clojure/src/mal/readline.cljs @@ -1,3 +1,3 @@ (ns mal.readline) -(def readline (.-readline (js/require "./src/mal/node_readline.js"))) +(def readline (.-readline (js/require "../src/mal/node_readline.js"))) diff --git a/coffee/Dockerfile b/coffee/Dockerfile index 895a5634bc..075c304e7f 100644 --- a/coffee/Dockerfile +++ b/coffee/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -24,18 +24,16 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 0.12 stable -RUN curl -sL https://deb.nodesource.com/setup_0.12 | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs -# Link common name -RUN ln -sf nodejs /usr/bin/node - ENV NPM_CONFIG_CACHE /mal/.npm # CoffeeScript specific -RUN npm install -g coffee-script +RUN npm install -g coffeescript RUN touch /.coffee_history && chmod go+w /.coffee_history diff --git a/coffee/node_readline.coffee b/coffee/node_readline.coffee index 87c8d3765a..fecddc80f2 100644 --- a/coffee/node_readline.coffee +++ b/coffee/node_readline.coffee @@ -6,7 +6,7 @@ HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history') rlwrap = {} # namespace for this module in web context -ffi = require('ffi') +ffi = require('ffi-napi') fs = require('fs') rllib = ffi.Library(RL_LIB, { diff --git a/coffee/package.json b/coffee/package.json index d28b74bdd0..9850858436 100644 --- a/coffee/package.json +++ b/coffee/package.json @@ -3,7 +3,7 @@ "version": "0.0.1", "description": "Make a Lisp (mal) language implemented in CoffeeScript", "dependencies": { - "ffi": "1.3.x", - "coffee-script": "~1.8" + "ffi-napi": "2.4.x", + "coffeescript": "~1.8" } } diff --git a/crystal/Dockerfile b/crystal/Dockerfile index 1c24bbd64d..0d023752f4 100644 --- a/crystal/Dockerfile +++ b/crystal/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -25,6 +25,6 @@ WORKDIR /mal RUN apt-get -y install g++ # Crystal -RUN apt-get -y install apt-transport-https +RUN apt-get -y install apt-transport-https gnupg RUN curl http://dist.crystal-lang.org/apt/setup.sh | bash RUN apt-get -y install crystal diff --git a/elm/Dockerfile b/elm/Dockerfile index 5b3bc3e271..b0553bd56b 100644 --- a/elm/Dockerfile +++ b/elm/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:xenial +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -21,14 +21,18 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -# For building node modules and pulling elm packages -RUN apt-get -y install g++ netbase +# For building node modules +RUN apt-get -y install g++ -# Add nodesource apt repo config for 7.X -RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs +# For pulling elm packages +RUN apt-get -y install netbase + ENV HOME /mal ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/elm/node_readline.js b/elm/node_readline.js index e59a62bd1e..0a50f91f36 100644 --- a/elm/node_readline.js +++ b/elm/node_readline.js @@ -6,7 +6,7 @@ var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); var rlwrap = {}; // namespace for this module in web context -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/elm/package.json b/elm/package.json index dfbc2c7c58..67d412784d 100644 --- a/elm/package.json +++ b/elm/package.json @@ -4,7 +4,7 @@ "description": "", "main": "bootstrap.js", "dependencies": { - "ffi": "2.0.x" + "ffi-napi": "2.4.x" }, "devDependencies": { "elm": "^0.18.0" diff --git a/es6/Dockerfile b/es6/Dockerfile index ddcadb5b86..f7677e91c8 100644 --- a/es6/Dockerfile +++ b/es6/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:xenial +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -24,11 +24,11 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 7.X -RUN curl -sL https://deb.nodesource.com/setup_8.x | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs -# Link common name ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/es6/core.mjs b/es6/core.mjs index 64a7436aa4..d99c3c5df0 100644 --- a/es6/core.mjs +++ b/es6/core.mjs @@ -1,15 +1,17 @@ import { _equal_Q, _clone, _keyword, _keyword_Q } from './types' import { _list_Q, Vector, _assoc_BANG, Atom } from './types' import { pr_str } from './printer' -import { readline } from './node_readline' +import rl from './node_readline' +const readline = rl.readline import { read_str } from './reader' +import { readFileSync } from 'fs' function _error(e) { throw new Error(e) } // String functions function slurp(f) { - if (typeof require !== 'undefined') { - return require('fs').readFileSync(f, 'utf-8') + if (typeof process !== 'undefined') { + return readFileSync(f, 'utf-8') } else { var req = new XMLHttpRequest() req.open('GET', f, false) diff --git a/es6/node_readline.js b/es6/node_readline.js index 9e2fb864ba..500f892211 100644 --- a/es6/node_readline.js +++ b/es6/node_readline.js @@ -4,7 +4,7 @@ var RL_LIB = "libreadline"; // NOTE: libreadline is GPL var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/es6/package.json b/es6/package.json index 627da97fec..850dff0917 100644 --- a/es6/package.json +++ b/es6/package.json @@ -3,10 +3,10 @@ "version": "0.0.1", "description": "Make a Lisp (mal) language implemented in ES6 (ECMAScript 6 / ECMAScript 2015)", "dependencies": { - "@std/esm": "^0.11.0", - "ffi": "2.0.x" + "esm": "3.0.x", + "ffi-napi": "2.4.x" }, - "@std/esm": { + "esm": { "cjs": true } } diff --git a/es6/run b/es6/run index a6c8bf8387..ad5a837b2a 100755 --- a/es6/run +++ b/es6/run @@ -1,2 +1,2 @@ #!/bin/bash -exec node -r @std/esm $(dirname $0)/${STEP:-stepA_mal}.mjs "${@}" +exec node -r esm $(dirname $0)/${STEP:-stepA_mal}.mjs "${@}" diff --git a/es6/step0_repl.mjs b/es6/step0_repl.mjs index 6679a09262..6eaca056fa 100644 --- a/es6/step0_repl.mjs +++ b/es6/step0_repl.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline // read const READ = str => str diff --git a/es6/step1_read_print.mjs b/es6/step1_read_print.mjs index 6ff1cee7d5..8af709fade 100644 --- a/es6/step1_read_print.mjs +++ b/es6/step1_read_print.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step2_eval.mjs b/es6/step2_eval.mjs index 40abe093e8..f49b78ad6a 100644 --- a/es6/step2_eval.mjs +++ b/es6/step2_eval.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step3_env.mjs b/es6/step3_env.mjs index 0026b3472b..034315a814 100644 --- a/es6/step3_env.mjs +++ b/es6/step3_env.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step4_if_fn_do.mjs b/es6/step4_if_fn_do.mjs index 4fe1f90e29..e3c7073030 100644 --- a/es6/step4_if_fn_do.mjs +++ b/es6/step4_if_fn_do.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step5_tco.mjs b/es6/step5_tco.mjs index 7bcb778980..bf83f4a69d 100644 --- a/es6/step5_tco.mjs +++ b/es6/step5_tco.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q, _malfunc, _malfunc_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step6_file.mjs b/es6/step6_file.mjs index 7396197d57..1053976a33 100644 --- a/es6/step6_file.mjs +++ b/es6/step6_file.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q, _malfunc, _malfunc_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step7_quote.mjs b/es6/step7_quote.mjs index 947c3a2194..31642da170 100644 --- a/es6/step7_quote.mjs +++ b/es6/step7_quote.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q, _malfunc, _malfunc_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step8_macros.mjs b/es6/step8_macros.mjs index 9aa6e1cc9c..e106975c23 100644 --- a/es6/step8_macros.mjs +++ b/es6/step8_macros.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q, _malfunc, _malfunc_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/step9_try.mjs b/es6/step9_try.mjs index ede914d984..389c1c8db9 100644 --- a/es6/step9_try.mjs +++ b/es6/step9_try.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q, _malfunc, _malfunc_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/es6/stepA_mal.mjs b/es6/stepA_mal.mjs index c883980ebe..a86199385e 100644 --- a/es6/stepA_mal.mjs +++ b/es6/stepA_mal.mjs @@ -1,4 +1,5 @@ -import { readline } from './node_readline' +import rl from './node_readline.js' +const readline = rl.readline import { _list_Q, _malfunc, _malfunc_Q } from './types' import { BlankException, read_str } from './reader' import { pr_str } from './printer' diff --git a/haxe/Dockerfile b/haxe/Dockerfile index 545c7a612a..a0b55723c8 100644 --- a/haxe/Dockerfile +++ b/haxe/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -27,15 +27,13 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 0.12 stable -RUN curl -sL https://deb.nodesource.com/setup_0.12 | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs -# Link common name -RUN ln -sf nodejs /usr/bin/node - ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/haxe/node_readline.js b/haxe/node_readline.js index 2045d66632..80885cf27b 100644 --- a/haxe/node_readline.js +++ b/haxe/node_readline.js @@ -6,7 +6,7 @@ var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); var rlwrap = {}; // namespace for this module in web context -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/haxe/package.json b/haxe/package.json index 34fc239904..e84e49ad95 100644 --- a/haxe/package.json +++ b/haxe/package.json @@ -3,6 +3,6 @@ "version": "0.0.1", "description": "Make a Lisp (mal) language implemented in Haxe/Javascript", "dependencies": { - "ffi": "1.3.x" + "ffi-napi": "2.4.x" } } diff --git a/js/Dockerfile b/js/Dockerfile index 0559f7a9ad..f7677e91c8 100644 --- a/js/Dockerfile +++ b/js/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -24,14 +24,11 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 0.12 stable -RUN curl -sL https://deb.nodesource.com/setup_0.12 | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs -# Link common name -RUN ln -sf nodejs /usr/bin/node - ENV NPM_CONFIG_CACHE /mal/.npm - diff --git a/js/node_readline.js b/js/node_readline.js index dc64e3f642..6042eaa0af 100644 --- a/js/node_readline.js +++ b/js/node_readline.js @@ -6,7 +6,7 @@ var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); var rlwrap = {}; // namespace for this module in web context -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/js/package.json b/js/package.json index 4eec27025a..e6246a8cbd 100644 --- a/js/package.json +++ b/js/package.json @@ -3,6 +3,6 @@ "version": "0.0.1", "description": "Make a Lisp (mal) language implemented in Javascript", "dependencies": { - "ffi": "2.0.x" + "ffi-napi": "2.4.x" } } diff --git a/livescript/Dockerfile b/livescript/Dockerfile index edfa6948c6..f7677e91c8 100644 --- a/livescript/Dockerfile +++ b/livescript/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:xenial +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -24,11 +24,11 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 7.X -RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs ENV NPM_CONFIG_CACHE /mal/.npm - diff --git a/livescript/node_readline.js b/livescript/node_readline.js index e59a62bd1e..0a50f91f36 100644 --- a/livescript/node_readline.js +++ b/livescript/node_readline.js @@ -6,7 +6,7 @@ var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); var rlwrap = {}; // namespace for this module in web context -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/livescript/package.json b/livescript/package.json index af94704c1e..fe5b58944b 100644 --- a/livescript/package.json +++ b/livescript/package.json @@ -4,11 +4,11 @@ "description": "", "main": "index.js", "dependencies": { - "ffi": "2.0.x", + "ffi-napi": "2.4.x", "prelude-ls": "^1.1.2" }, "devDependencies": { - "livescript": "^1.5.0" + "livescript": "^1.6.0" }, "scripts": { "test": "echo \"Error: no test specified\" && exit 1" diff --git a/miniMAL/Dockerfile b/miniMAL/Dockerfile index 152c82a201..fa54933ccb 100644 --- a/miniMAL/Dockerfile +++ b/miniMAL/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:xenial +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -24,15 +24,13 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 7.X -RUN curl -sL https://deb.nodesource.com/setup_7.x | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs -# Link common name -RUN ln -sf nodejs /usr/bin/node - ENV NPM_CONFIG_CACHE /mal/.npm # install miniMAL diff --git a/miniMAL/node_readline.js b/miniMAL/node_readline.js index dc64e3f642..6042eaa0af 100644 --- a/miniMAL/node_readline.js +++ b/miniMAL/node_readline.js @@ -6,7 +6,7 @@ var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); var rlwrap = {}; // namespace for this module in web context -var ffi = require('ffi'), +var ffi = require('ffi-napi'), fs = require('fs'); var rllib = ffi.Library(RL_LIB, { diff --git a/miniMAL/package.json b/miniMAL/package.json index 0c87452b7e..bd9e2cf659 100644 --- a/miniMAL/package.json +++ b/miniMAL/package.json @@ -4,6 +4,6 @@ "description": "Make a Lisp (mal) language implemented in miniMAL", "dependencies": { "minimal-lisp": "1.0.2", - "ffi": "2.0.x" + "ffi-napi": "2.4.x" } } diff --git a/ts/Dockerfile b/ts/Dockerfile index 1bb0452dc9..f7677e91c8 100644 --- a/ts/Dockerfile +++ b/ts/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:xenial +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -21,8 +21,14 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -RUN apt-get -y install build-essential -RUN curl -sL https://deb.nodesource.com/setup_6.x | bash - +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs RUN apt-get -y install nodejs ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/ts/node_readline.ts b/ts/node_readline.ts index cc0af945d8..6018c92cec 100644 --- a/ts/node_readline.ts +++ b/ts/node_readline.ts @@ -1,5 +1,5 @@ import * as path from "path"; -import * as ffi from "ffi"; +import * as ffi from "ffi-napi"; import * as fs from "fs"; // IMPORTANT: choose one diff --git a/ts/package.json b/ts/package.json index 162c75250c..6a5bd97ede 100644 --- a/ts/package.json +++ b/ts/package.json @@ -19,10 +19,10 @@ "test:stepA": "cd .. && make 'test^ts^stepA'" }, "dependencies": { - "ffi": "^2.2.0" + "ffi-napi": "^2.4.0" }, "devDependencies": { - "@types/ffi": "0.0.19", + "@types/ffi-napi": "2.4.0", "@types/node": "^7.0.5", "typescript": "^2.2.1", "typescript-formatter": "^4.1.2" From 16e0a5e6f2e2ef101e9d86c3fffe2d04efbb18c4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 28 Nov 2018 20:45:28 -0600 Subject: [PATCH 0392/1998] mal: update Dockerfile to Ubuntu 18.04 and node 10 --- mal/Dockerfile | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/mal/Dockerfile b/mal/Dockerfile index 0559f7a9ad..f7677e91c8 100644 --- a/mal/Dockerfile +++ b/mal/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -24,14 +24,11 @@ WORKDIR /mal # For building node modules RUN apt-get -y install g++ -# Add nodesource apt repo config for 0.12 stable -RUN curl -sL https://deb.nodesource.com/setup_0.12 | bash - +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - # Install nodejs RUN apt-get -y install nodejs -# Link common name -RUN ln -sf nodejs /usr/bin/node - ENV NPM_CONFIG_CACHE /mal/.npm - From b5ec219b4920fe9d6218f96f36dfe600b4ffddc0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 28 Nov 2018 21:33:56 -0600 Subject: [PATCH 0393/1998] awk: fix ignored escaped 'u' warning. --- awk/reader.awk | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/awk/reader.awk b/awk/reader.awk index 6dcaf804f0..934c2f27e0 100644 --- a/awk/reader.awk +++ b/awk/reader.awk @@ -1,10 +1,10 @@ function reader_read_string(token, v, r) { token = substr(token, 1, length(token) - 1) - gsub(/\\\\/, "\u029e", token) + gsub(/\\\\/, "\xf7", token) gsub(/\\"/, "\"", token) gsub(/\\n/, "\n", token) - gsub("\u029e", "\\", token) + gsub("\xf7", "\\", token) return token } From 96c09dcd40b3759f3aaa8a9393444938a1a42269 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 28 Nov 2018 21:04:44 -0600 Subject: [PATCH 0394/1998] runtest.py: more generic prompt matching. --- runtest.py | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/runtest.py b/runtest.py index 1f9dd7033c..bd1d24b513 100755 --- a/runtest.py +++ b/runtest.py @@ -145,7 +145,7 @@ def read_to_prompt(self, prompts, timeout): match = regexp.search(self.buf) if match: end = match.end() - buf = self.buf[0:end-len(prompt)] + buf = self.buf[0:match.start()] self.buf = self.buf[end:] self.last_prompt = prompt return buf @@ -254,7 +254,7 @@ def assert_prompt(runner, prompts, timeout): # Wait for the initial prompt try: - assert_prompt(r, ['user> ', 'mal-user> '], args.start_timeout) + assert_prompt(r, ['[^\s()<>]+> '], args.start_timeout) except: _, exc, _ = sys.exc_info() log("\nException: %s" % repr(exc)) @@ -299,8 +299,7 @@ def assert_prompt(runner, prompts, timeout): r.writeline(t.form) try: test_cnt += 1 - res = r.read_to_prompt(['\r\nuser> ', '\nuser> ', - '\r\nmal-user> ', '\nmal-user> '], + res = r.read_to_prompt(['\r\n[^\s()<>]+> ', '\n[^\s()<>]+> '], timeout=args.test_timeout) #print "%s,%s,%s" % (idx, repr(p.before), repr(p.after)) if t.ret == "*" or res in expected: From f6f5d4f2a3b708d9f272dfef82d21c54a2642cc0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 29 Nov 2018 00:39:53 -0600 Subject: [PATCH 0395/1998] runtest.py: process output/errors as regex match. Update output test data to be regex compatible. --- runtest.py | 28 +++++++++++++++++------- tests/step1_read_print.mal | 13 ++++++----- tests/step2_eval.mal | 3 ++- tests/step3_env.mal | 2 +- tests/step4_if_fn_do.mal | 44 +++++++++++++++++++------------------- tests/step6_file.mal | 2 +- tests/step9_try.mal | 12 +++++------ 7 files changed, 60 insertions(+), 44 deletions(-) diff --git a/runtest.py b/runtest.py index bd1d24b513..6e2a495e76 100755 --- a/runtest.py +++ b/runtest.py @@ -215,15 +215,19 @@ def next(self): self.line_num += 1 self.data.pop(0) break - elif line[0:2] == "; ": + elif line[0:2] == ";/": self.out = self.out + line[2:] + sep self.line_num += 1 self.data.pop(0) else: - self.ret = "*" + self.ret = "" break - if self.ret: break + if self.ret != None: break + if self.out[-2:] == sep and not self.ret: + # If there is no return value, output should not end in + # separator + self.out = self.out[0:-2] return self.form args = parser.parse_args(sys.argv[1:]) @@ -293,8 +297,11 @@ def assert_prompt(runner, prompts, timeout): # The repeated form is to get around an occasional OS X issue # where the form is repeated. # https://github.com/kanaka/mal/issues/30 - expected = ["%s%s%s%s" % (t.form, sep, t.out, t.ret), - "%s%s%s%s%s%s" % (t.form, sep, t.form, sep, t.out, t.ret)] + expects = ["%s%s%s%s" % (re.escape(t.form), sep, + t.out, re.escape(t.ret)), + "%s%s%s%s%s%s" % (re.escape(t.form), sep, + re.escape(t.form), sep, + t.out, re.escape(t.ret))] r.writeline(t.form) try: @@ -302,7 +309,11 @@ def assert_prompt(runner, prompts, timeout): res = r.read_to_prompt(['\r\n[^\s()<>]+> ', '\n[^\s()<>]+> '], timeout=args.test_timeout) #print "%s,%s,%s" % (idx, repr(p.before), repr(p.after)) - if t.ret == "*" or res in expected: + if (t.ret == "" and t.out == ""): + log(" -> SUCCESS (result ignored)") + pass_cnt += 1 + elif (re.search(expects[0], res, re.S) or + re.search(expects[1], res, re.S)): log(" -> SUCCESS") pass_cnt += 1 else: @@ -314,11 +325,12 @@ def assert_prompt(runner, prompts, timeout): log(" -> FAIL (line %d):" % t.line_num) fail_cnt += 1 fail_type = "" - log(" Expected : %s" % repr(expected[0])) + log(" Expected : %s" % repr(expects[0])) log(" Got : %s" % repr(res)) failed_test = """%sFAILED TEST (line %d): %s -> [%s,%s]: Expected : %s - Got : %s""" % (fail_type, t.line_num, t.form, repr(t.out), t.ret, repr(expected[0]), repr(res)) + Got : %s""" % (fail_type, t.line_num, t.form, repr(t.out), + t.ret, repr(expects[0]), repr(res)) failures.append(failed_test) except: _, exc, _ = sys.exc_info() diff --git a/tests/step1_read_print.mal b/tests/step1_read_print.mal index a4d40a0503..266b016033 100644 --- a/tests/step1_read_print.mal +++ b/tests/step1_read_print.mal @@ -75,15 +75,18 @@ false ;=>"" ;; Testing reader errors -;;; TODO: fix these so they fail correctly (1 2 -; expected ')', got EOF +;/.*(EOF|end of input|unbalanced).* [1 2 -; expected ']', got EOF +;/.*(EOF|end of input|unbalanced).* + +;;; These should throw some error with no return value "abc -; expected '"', got EOF +;/.+ (1 "abc -; expected ')', got EOF +;/.+ +(1 "abc" +;/.+ ;; Testing read of quoting '1 diff --git a/tests/step2_eval.mal b/tests/step2_eval.mal index c92fa844ca..16a3589a3a 100644 --- a/tests/step2_eval.mal +++ b/tests/step2_eval.mal @@ -20,8 +20,9 @@ (/ (- (+ 515 (* -87 311)) 296) 27) ;=>-994 +;;; This should throw an error with no return value (abc 1 2 3) -; .*\'abc\' not found.* +;/.+ ;; Testing empty list () diff --git a/tests/step3_env.mal b/tests/step3_env.mal index ebd2e8ab7e..1539e5625e 100644 --- a/tests/step3_env.mal +++ b/tests/step3_env.mal @@ -31,7 +31,7 @@ MYNUM ;; Check env lookup non-fatal error (abc 1 2 3) -; .*\'abc\' not found.* +;/.*\'?abc\'? not found.* ;; Check that error aborts def! (def! w 123) (def! w (abc)) diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal index 1117818d4b..991b44b730 100644 --- a/tests/step4_if_fn_do.mal +++ b/tests/step4_if_fn_do.mal @@ -173,14 +173,14 @@ ;; Testing do form (do (prn "prn output1")) -; "prn output1" +;/"prn output1" ;=>nil (do (prn "prn output2") 7) -; "prn output2" +;/"prn output2" ;=>7 (do (prn "prn output1") (prn "prn output2") (+ 1 2)) -; "prn output1" -; "prn output2" +;/"prn output1" +;/"prn output2" ;=>3 (do (def! a 6) 7 (+ a 8)) @@ -341,69 +341,69 @@ a ;; Testing prn (prn) -; +;/ ;=>nil (prn "") -; "" +;/"" ;=>nil (prn "abc") -; "abc" +;/"abc" ;=>nil (prn "abc def" "ghi jkl") -; "abc def" "ghi jkl" +;/"abc def" "ghi jkl" (prn "\"") -; "\"" +;/"\\"" ;=>nil (prn "abc\ndef\nghi") -; "abc\ndef\nghi" +;/"abc\\ndef\\nghi" ;=>nil (prn "abc\\def\\ghi") -; "abc\\def\\ghi" +;/"abc\\\\def\\\\ghi" nil (prn (list 1 2 "abc" "\"") "def") -; (1 2 "abc" "\"") "def" +;/\(1 2 "abc" "\\""\) "def" ;=>nil ;; Testing println (println) -; +;/ ;=>nil (println "") -; +;/ ;=>nil (println "abc") -; abc +;/abc ;=>nil (println "abc def" "ghi jkl") -; abc def ghi jkl +;/abc def ghi jkl (println "\"") -; " +;/" ;=>nil (println "abc\ndef\nghi") -; abc -; def -; ghi +;/abc +;/def +;/ghi ;=>nil (println "abc\\def\\ghi") -; abc\def\ghi +;/abc\\def\\ghi ;=>nil (println (list 1 2 "abc" "\"") "def") -; (1 2 abc ") def +;/\(1 2 abc "\) def ;=>nil ;>>> optional=True diff --git a/tests/step6_file.mal b/tests/step6_file.mal index c024e0d629..486725ee4b 100644 --- a/tests/step6_file.mal +++ b/tests/step6_file.mal @@ -99,7 +99,7 @@ ;; Testing comments in a file (load-file "../tests/incB.mal") -; "incB.mal finished" +;/"incB.mal finished" ;=>"incB.mal return string" (inc4 7) ;=>11 diff --git a/tests/step9_try.mal b/tests/step9_try.mal index d50250ecca..5108914994 100644 --- a/tests/step9_try.mal +++ b/tests/step9_try.mal @@ -5,11 +5,11 @@ ;=>123 (try* (abc 1 2) (catch* exc (prn "exc is:" exc))) -; "exc is:" "'abc' not found" +;/"exc is:" "'abc' not found" ;=>nil (try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7))) -; "exc:" "my exception" +;/"exc:" "my exception" ;=>7 ;;; Test that throw is a function: @@ -48,10 +48,10 @@ (apply + 4 (list 5)) ;=>9 (apply prn (list 1 2 "3" (list))) -; 1 2 "3" () +;/1 2 "3" \(\) ;=>nil (apply prn 1 2 (list "3" (list))) -; 1 2 "3" () +;/1 2 "3" \(\) ;=>nil (apply list (list)) ;=>() @@ -124,7 +124,7 @@ (apply + 4 [5]) ;=>9 (apply prn 1 2 ["3" 4]) -; 1 2 "3" 4 +;/1 2 "3" 4 ;=>nil (apply list []) ;=>() @@ -307,7 +307,7 @@ ;; ;; Testing throwing non-strings (try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7))) -; "err:" (1 2 3) +;/"err:" \(1 2 3\) ;=>7 ;; From 9e2a4ab0f995c1f2b151c98fb5b032600f202a92 Mon Sep 17 00:00:00 2001 From: Joel Martin & Chouser Date: Fri, 30 Nov 2018 14:54:21 -0600 Subject: [PATCH 0396/1998] forth: fix errors/reporting in steps 1-8. --- forth/core.fs | 7 +++++++ forth/step0_repl.fs | 10 ++++++---- forth/step1_read_print.fs | 23 +++++++++++++++++------ forth/step2_eval.fs | 28 ++++++++++++++++++---------- forth/step3_env.fs | 26 ++++++++++++++++++-------- forth/step4_if_fn_do.fs | 26 ++++++++++++++++++-------- forth/step5_tco.fs | 26 ++++++++++++++++++-------- forth/step6_file.fs | 26 ++++++++++++++++++-------- forth/step7_quote.fs | 26 ++++++++++++++++++-------- forth/step8_macros.fs | 26 ++++++++++++++++++-------- forth/step9_try.fs | 35 ++++++++++++++++------------------- forth/stepA_mal.fs | 35 ++++++++++++++++------------------- 12 files changed, 188 insertions(+), 106 deletions(-) diff --git a/forth/core.fs b/forth/core.fs index 593229c93f..6b48c53287 100644 --- a/forth/core.fs +++ b/forth/core.fs @@ -80,6 +80,13 @@ defcore str ( argv argc ) defcore read-string drop @ unpack-str read-str ;; defcore slurp drop @ unpack-str slurp-file MalString. ;; +create core-buff 128 allot +defcore readline ( argv argc -- mal-string ) + drop @ unpack-str type stdout flush-file drop + core-buff 128 stdin read-line throw + if core-buff swap MalString. else drop mal-nil endif ;; + + defcore cons ( argv[item,coll] argc ) drop dup @ swap cell+ @ ( item coll ) to-list conj ;; diff --git a/forth/step0_repl.fs b/forth/step0_repl.fs index 2483c12c84..f69a97d849 100644 --- a/forth/step0_repl.fs +++ b/forth/step0_repl.fs @@ -15,9 +15,11 @@ create buff 128 allot begin ." user> " buff 128 stdin read-line throw - while - buff swap - rep type cr + while ( num-bytes-read ) + dup 0 <> if + buff swap + rep type cr + endif repeat ; -read-lines \ No newline at end of file +read-lines diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs index 9e42995bbb..5d0ee31353 100644 --- a/forth/step1_read_print.fs +++ b/forth/step1_read_print.fs @@ -21,12 +21,23 @@ create buff 128 allot stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute safe-type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; read-lines diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs index 68e189e051..ba8f30b52d 100644 --- a/forth/step2_eval.fs +++ b/forth/step2_eval.fs @@ -60,10 +60,7 @@ MalSymbol 0 sym env get dup 0= if drop - ." Symbol '" - sym pr-str safe-type - ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str endif ;; drop @@ -111,12 +108,23 @@ create buff 128 allot stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute safe-type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; read-lines diff --git a/forth/step3_env.fs b/forth/step3_env.fs index fcc40a3d76..939afce4da 100644 --- a/forth/step3_env.fs +++ b/forth/step3_env.fs @@ -94,8 +94,7 @@ MalSymbol sym env env/get-addr dup 0= if drop - ." Symbol '" sym pr-str safe-type ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str else @ endif ;; @@ -145,12 +144,23 @@ create buff 128 allot stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute safe-type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; read-lines diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs index 2ecde297f3..56e1e4535e 100644 --- a/forth/step4_if_fn_do.fs +++ b/forth/step4_if_fn_do.fs @@ -154,8 +154,7 @@ MalSymbol sym env env/get-addr dup 0= if drop - ." Symbol '" sym pr-str safe-type ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str else @ endif ;; @@ -205,12 +204,23 @@ create buff 128 allot stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute safe-type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; read-lines diff --git a/forth/step5_tco.fs b/forth/step5_tco.fs index e5c92f1d31..499149de85 100644 --- a/forth/step5_tco.fs +++ b/forth/step5_tco.fs @@ -165,8 +165,7 @@ MalSymbol sym env env/get-addr dup 0= if drop - ." Symbol '" sym pr-str safe-type ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str else @ endif ;; @@ -216,12 +215,23 @@ create buff 128 allot stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute safe-type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; read-lines diff --git a/forth/step6_file.fs b/forth/step6_file.fs index cca5b4eb54..d2573204c8 100644 --- a/forth/step6_file.fs +++ b/forth/step6_file.fs @@ -170,8 +170,7 @@ MalSymbol sym env env/get-addr dup 0= if drop - ." Symbol '" sym pr-str safe-type ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str else @ endif ;; @@ -249,12 +248,23 @@ s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\"))) stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; : main ( -- ) diff --git a/forth/step7_quote.fs b/forth/step7_quote.fs index 75af3f10a7..51bd4bfafe 100644 --- a/forth/step7_quote.fs +++ b/forth/step7_quote.fs @@ -212,8 +212,7 @@ MalSymbol sym env env/get-addr dup 0= if drop - ." Symbol '" sym pr-str safe-type ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str else @ endif ;; @@ -291,12 +290,23 @@ s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\"))) stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; : main ( -- ) diff --git a/forth/step8_macros.fs b/forth/step8_macros.fs index 68f80524ec..9c230769a1 100644 --- a/forth/step8_macros.fs +++ b/forth/step8_macros.fs @@ -237,8 +237,7 @@ MalSymbol sym env env/get-addr dup 0= if drop - ." Symbol '" sym pr-str safe-type ." ' not found." cr - 1 throw + 0 0 s" ' not found" sym pr-str s" '" ...throw-str else @ endif ;; @@ -318,12 +317,23 @@ s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute type - catch ?dup 0= if safe-type else ." Caught error " . endif - cr - stack-leak-detect <> if ." --stack leak--" cr endif + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif repeat ; : main ( -- ) diff --git a/forth/step9_try.fs b/forth/step9_try.fs index b16c2ac157..a5626da86a 100644 --- a/forth/step9_try.fs +++ b/forth/step9_try.fs @@ -346,11 +346,6 @@ defcore map ( argv argc -- list ) cell +loop here>MalList ;; -defcore readline ( argv argc -- mal-string ) - drop @ unpack-str type stdout flush-file drop - buff 128 stdin read-line throw - if buff swap MalString. else drop mal-nil endif ;; - s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop @@ -361,20 +356,22 @@ s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif endif repeat ; diff --git a/forth/stepA_mal.fs b/forth/stepA_mal.fs index 394b638477..38dcdb6bd8 100644 --- a/forth/stepA_mal.fs +++ b/forth/stepA_mal.fs @@ -353,11 +353,6 @@ defcore map ( argv argc -- list ) cell +loop here>MalList ;; -defcore readline ( argv argc -- mal-string ) - drop @ unpack-str type stdout flush-file drop - buff 128 stdin read-line throw - if buff swap MalString. else drop mal-nil endif ;; - s\" (def! *host-language* \"forth\")" rep 2drop s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop @@ -372,20 +367,22 @@ s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs stack-leak-detect buff 128 stdin read-line throw while ( num-bytes-read ) - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif endif repeat ; From 970935dac9fd91cc08ff4a61126cfa886d2282f6 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 29 Nov 2018 00:41:47 -0600 Subject: [PATCH 0397/1998] awk, bash, c, coffee, js: fix errors. --- awk/reader.awk | 4 ++-- bash/reader.sh | 10 +++++++--- bash/step1_read_print.sh | 2 +- c/step2_eval.c | 4 +++- coffee/reader.coffee | 3 ++- js/reader.js | 5 ++++- js/step2_eval.js | 6 +++++- js/tests/stepA_mal.mal | 2 +- 8 files changed, 25 insertions(+), 11 deletions(-) diff --git a/awk/reader.awk b/awk/reader.awk index 934c2f27e0..905ef52d13 100644 --- a/awk/reader.awk +++ b/awk/reader.awk @@ -46,7 +46,7 @@ function reader_read_list(reader, type, end, idx, len, ret) } types_heap[idx]["len"] = len types_release(type idx) - return "!\"expect " end ", got EOF" + return "!\"expected '" end "', got EOF" } function reader_read_hash(reader, idx, key, val) @@ -79,7 +79,7 @@ function reader_read_hash(reader, idx, key, val) types_heap[idx][key] = val } types_release("{" idx) - return "!\"expect }, got EOF" + return "!\"expected '}', got EOF" } function reader_read_abbrev(reader, symbol, val, idx) diff --git a/bash/reader.sh b/bash/reader.sh index fa6064ce73..7b163285ef 100644 --- a/bash/reader.sh +++ b/bash/reader.sh @@ -13,7 +13,11 @@ READ_ATOM () { case "${token}" in [0-9]*) _number "${token}" ;; -[0-9]*) _number "${token}" ;; - \"*) token="${token:1:-1}" + \"*) if [ "${token: -1}" != "\"" ]; then + _error "expected '\"', got EOF" + return + fi + token="${token:1:-1}" token="${token//\\\\/${__keyw}}" token="${token//\\\"/\"}" token="${token//\\n/$'\n'}" @@ -46,7 +50,7 @@ READ_SEQ () { while [[ "${token}" != "${end}" ]]; do if [[ ! "${token}" ]]; then r= - _error "exepected '${end}', got EOF" + _error "expected '${end}', got EOF" return fi READ_FORM @@ -118,7 +122,7 @@ TOKENIZE () { chunk=$(( chunk + ${chunksz} )) fi (( ${#str} == 0 )) && break - [[ "${str}" =~ ^^([][{}\(\)^@])|^(~@)|(\"(\\.|[^\\\"])*\")|^(;[^$'\n']*)|^([~\'\`])|^([^][ ~\`\'\";{}\(\)^@\,]+)|^[,]|^[[:space:]]+ ]] + [[ "${str}" =~ ^^([][{}\(\)^@])|^(~@)|(\"(\\.|[^\\\"])*\"?)|^(;[^$'\n']*)|^([~\'\`])|^([^][ ~\`\'\";{}\(\)^@\,]+)|^[,]|^[[:space:]]+ ]] match=${BASH_REMATCH[0]} str="${str:${#match}}" token="${match//$'\n'/}" diff --git a/bash/step1_read_print.sh b/bash/step1_read_print.sh index 881c0c3ee7..8011fa6b86 100755 --- a/bash/step1_read_print.sh +++ b/bash/step1_read_print.sh @@ -21,7 +21,7 @@ EVAL () { # print PRINT () { if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes + _pr_str "${__ERROR}" no r="Error: ${r}" __ERROR= else diff --git a/c/step2_eval.c b/c/step2_eval.c index 3417e32747..d075842455 100644 --- a/c/step2_eval.c +++ b/c/step2_eval.c @@ -34,7 +34,9 @@ MalVal *eval_ast(MalVal *ast, GHashTable *env) { if (ast->type == MAL_SYMBOL) { //g_print("EVAL symbol: %s\n", ast->val.string); // TODO: check if not found - return g_hash_table_lookup(env, ast->val.string); + MalVal *res = g_hash_table_lookup(env, ast->val.string); + assert(res, "'%s' not found", ast->val.string); + return res; } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); diff --git a/coffee/reader.coffee b/coffee/reader.coffee index c6fb7d9179..f0253eb685 100644 --- a/coffee/reader.coffee +++ b/coffee/reader.coffee @@ -11,7 +11,7 @@ class Reader @ tokenize = (str) -> - re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g + re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g results = [] while (match = re.exec(str)[1]) != "" continue if match[0] == ';' @@ -23,6 +23,7 @@ read_atom = (rdr) -> if token.match /^-?[0-9]+$/ then parseInt token,10 else if token.match /^-?[0-9][0-9.]*$/ then parseFloat token,10 else if token[0] == '"' + throw new Error "expected '\"', got EOF" if token[-1..-1] != '"' token.slice(1, token.length-1) .replace(/\\(.)/g, (_, c) -> if c == 'n' then '\n' else c) else if token[0] == ':' then types._keyword(token[1..]) diff --git a/js/reader.js b/js/reader.js index b147c13b8a..864b973e5b 100644 --- a/js/reader.js +++ b/js/reader.js @@ -15,7 +15,7 @@ Reader.prototype.next = function() { return this.tokens[this.position++]; } Reader.prototype.peek = function() { return this.tokens[this.position]; } function tokenize(str) { - var re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g; + var re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; var results = []; while ((match = re.exec(str)[1]) != '') { if (match[0] === ';') { continue; } @@ -32,6 +32,9 @@ function read_atom (reader) { } else if (token.match(/^-?[0-9][0-9.]*$/)) { return parseFloat(token,10); // float } else if (token[0] === "\"") { + if (token.slice(-1) !== "\"") { + throw new Error("expected '\"', got EOF"); + } return token.slice(1,token.length-1) .replace(/\\(.)/g, function (_, c) { return c === "n" ? "\n" : c}) } else if (token[0] === ":") { diff --git a/js/step2_eval.js b/js/step2_eval.js index 42a60d2ab7..3b1adbd648 100644 --- a/js/step2_eval.js +++ b/js/step2_eval.js @@ -13,7 +13,11 @@ function READ(str) { // eval function eval_ast(ast, env) { if (types._symbol_Q(ast)) { - return env[ast]; + if (ast in env) { + return env[ast]; + } else { + throw new Error("'" + ast.value + "' not found"); + } } else if (types._list_Q(ast)) { return ast.map(function(a) { return EVAL(a, env); }); } else if (types._vector_Q(ast)) { diff --git a/js/tests/stepA_mal.mal b/js/tests/stepA_mal.mal index d23a1b2bc6..4502bfff26 100644 --- a/js/tests/stepA_mal.mal +++ b/js/tests/stepA_mal.mal @@ -27,7 +27,7 @@ ;=>60 (. "console.log" "abc" 123 '(4 5 6) {"kk" "vv"} (= 1 1) nil) -; abc 123 [ 4, 5, 6 ] { kk: 'vv' } true null +; abc 123 \[ 4, 5, 6 \] \{ kk: 'vv' \} true null ;=>nil (js-eval "myobj = { v: 10, myfunc: function(a,b,c) { return a * b * c * this.v; } }") From 2adfa11c9853706d0a3db77704c1cc49a1526d4e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 29 Nov 2018 15:31:50 -0600 Subject: [PATCH 0398/1998] ada, d, elixir, es6, factor, haxe: fix errors. --- ada/reader.adb | 4 ++-- d/reader.d | 4 ++-- elixir/lib/mal/reader.ex | 5 ++++- es6/reader.mjs | 5 ++++- factor/lib/reader/reader.factor | 2 +- haxe/reader/Reader.hx | 5 ++++- 6 files changed, 17 insertions(+), 8 deletions(-) diff --git a/ada/reader.adb b/ada/reader.adb index f2c2640fac..d4f32810ce 100644 --- a/ada/reader.adb +++ b/ada/reader.adb @@ -254,7 +254,7 @@ package body Reader is loop if Is_Null (MTA) then - return New_Error_Mal_Type (Str => "expected '" & Close & "'"); + return New_Error_Mal_Type (Str => "expected '" & Close & "', got EOF"); end if; exit when Deref (MTA).Sym_Type = Sym and then @@ -386,7 +386,7 @@ package body Reader is exception when String_Error => - return New_Error_Mal_Type (Str => "expected '""'"); + return New_Error_Mal_Type (Str => "expected '""', got EOF"); end Read_Str; diff --git a/d/reader.d b/d/reader.d index ac33b84656..2f6ed44911 100644 --- a/d/reader.d +++ b/d/reader.d @@ -103,7 +103,7 @@ MalType read_atom(Reader reader) MalType[] read_items(Reader reader, string start, string end) { auto open_paren = reader.next(); - if (open_paren != start) throw new Exception("expected '" ~ start ~ "'"); + if (open_paren != start) throw new Exception("expected '" ~ start ~ "', got EOF"); string token; MalType[] res; @@ -111,7 +111,7 @@ MalType[] read_items(Reader reader, string start, string end) { if (token is null) { - throw new Exception("expected '" ~ end ~ "'"); + throw new Exception("expected '" ~ end ~ "', got EOF"); } res ~= read_form(reader); } diff --git a/elixir/lib/mal/reader.ex b/elixir/lib/mal/reader.ex index 82ecc8d7d6..867042909c 100644 --- a/elixir/lib/mal/reader.ex +++ b/elixir/lib/mal/reader.ex @@ -11,7 +11,7 @@ defmodule Mal.Reader do end def tokenize(input) do - regex = ~r/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/ + regex = ~r/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ Regex.scan(regex, input, capture: :all_but_first) |> List.flatten |> List.delete_at(-1) # Remove the last match, which is an empty string @@ -88,6 +88,9 @@ defmodule Mal.Reader do |> Code.string_to_quoted |> elem(1) + String.starts_with?(token, "\"") -> + throw({:error, "expected '\"', got EOF"}) + integer?(token) -> Integer.parse(token) |> elem(0) diff --git a/es6/reader.mjs b/es6/reader.mjs index ae23ddf084..597e739494 100644 --- a/es6/reader.mjs +++ b/es6/reader.mjs @@ -12,7 +12,7 @@ class Reader { } function tokenize(str) { - const re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g + const re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g let match = null let results = [] while ((match = re.exec(str)[1]) != '') { @@ -30,6 +30,9 @@ function read_atom (reader) { } else if (token.match(/^-?[0-9][0-9.]*$/)) { return parseFloat(token,10) // float } else if (token[0] === "\"") { + if (token.slice(-1) !== "\"") { + throw new Error("expected '\"', got EOF"); + } return token.slice(1,token.length-1) .replace(/\\(.)/g, (_, c) => c === "n" ? "\n" : c) } else if (token[0] === ":") { diff --git a/factor/lib/reader/reader.factor b/factor/lib/reader/reader.factor index 767241ae26..2c4092a04a 100644 --- a/factor/lib/reader/reader.factor +++ b/factor/lib/reader/reader.factor @@ -34,7 +34,7 @@ DEFER: read-form :: read-sequence ( seq closer exemplar -- seq maltype ) seq [ [ - [ "expected " closer append throw ] + [ "expected " closer ", got EOF" append throw ] [ dup first closer = ] if-empty ] [ read-form , diff --git a/haxe/reader/Reader.hx b/haxe/reader/Reader.hx index 3955a3d4d5..d06f8008fe 100644 --- a/haxe/reader/Reader.hx +++ b/haxe/reader/Reader.hx @@ -27,7 +27,7 @@ class Reader { // Static functions grouped with Reader class static function tokenize(str:String) { - var re = ~/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g; + var re = ~/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; var tokens = new Array(); var pos = 0; while (re.matchSub(str, pos)) { @@ -45,6 +45,7 @@ class Reader { static function read_atom(rdr:Reader) { var re_int = ~/^-?[0-9][0-9]*$/; var re_str = ~/^".*"$/; + var re_str_bad = ~/^".*$/; var token = rdr.next(); return switch (token) { case "nil": @@ -72,6 +73,8 @@ class Reader { "\n"), "\""), "\\")); + case _ if (re_str.match(token)): + throw 'expected \'"\', got EOF'; case _: MalSymbol(token); } From 5f80c83f9d6d10cd683b1e0ba6a09f04cba44fc2 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 29 Nov 2018 15:32:27 -0600 Subject: [PATCH 0399/1998] lua, nasm, perl, rexx, vimscript: fix errors. --- lua/reader.lua | 5 ++++- lua/step1_read_print.lua | 1 + nasm/reader.asm | 2 +- perl/reader.pm | 13 +++++++++---- rexx/reader.rexx | 6 +++++- rexx/step1_read_print.rexx | 9 ++++++--- vimscript/reader.vim | 12 ++++++++---- 7 files changed, 34 insertions(+), 14 deletions(-) diff --git a/lua/reader.lua b/lua/reader.lua index 261f3ecbc3..34e4239a74 100644 --- a/lua/reader.lua +++ b/lua/reader.lua @@ -24,7 +24,7 @@ end function M.tokenize(str) local results = {} local re_pos = 1 - local re = rex.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)", rex.flags().EXTENDED) + local re = rex.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)", rex.flags().EXTENDED) while true do local s, e, t = re:exec(str, re_pos) if not s or s > e then break end @@ -44,6 +44,9 @@ function M.read_atom(rdr) if int_re:exec(token) then return tonumber(token) elseif float_re:exec(token) then return tonumber(token) elseif string.sub(token,1,1) == '"' then + if string.sub(token,-1) ~= '"' then + throw("expected '\"', got EOF") + end local sval = string.sub(token,2,string.len(token)-1) sval = string.gsub(sval, '\\\\', '\177') sval = string.gsub(sval, '\\"', '"') diff --git a/lua/step1_read_print.lua b/lua/step1_read_print.lua index 46d71f5cac..424001c026 100755 --- a/lua/step1_read_print.lua +++ b/lua/step1_read_print.lua @@ -2,6 +2,7 @@ local readline = require('readline') local utils = require('utils') +local types = require('types') local reader = require('reader') local printer = require('printer') diff --git a/nasm/reader.asm b/nasm/reader.asm index 8c040b5418..d0dfe20966 100644 --- a/nasm/reader.asm +++ b/nasm/reader.asm @@ -13,7 +13,7 @@ section .data ;; Error message strings - static error_string_unexpected_end, db "Error: Unexpected end of input. Could be a missing )", 10 + static error_string_unexpected_end, db "Error: Unexpected end of input (EOF). Could be a missing ) or ]", 10 static error_string_bracket_not_brace, db "Error: Expecting '}' but got ')'" ;; Symbols for comparison diff --git a/perl/reader.pm b/perl/reader.pm index a4196badb0..55616d6e7f 100644 --- a/perl/reader.pm +++ b/perl/reader.pm @@ -22,7 +22,7 @@ use Data::Dumper; sub tokenize { my($str) = @_; - my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g; + my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; return grep {! /^;|^$/} @tokens; } @@ -31,12 +31,15 @@ sub read_atom { my $token = $rdr->next(); given ($token) { when(/^-?[0-9]+$/) { return Integer->new($token) } - when(/^"/) { + when(/^".*"$/) { my %escaped_chars = ( "\\\\" => "\\", "\\\"" => "\"", "\\n" => "\n" ); my $str = substr $token, 1, -1; $str =~ s/\\./$escaped_chars{$&}/ge; return String->new($str) } + when(/^".*/) { + die "expected '\"', got EOF"; + } when(/^:/) { return _keyword(substr($token,1)) } when(/^nil$/) { return $nil } when(/^true$/) { return $true } @@ -55,10 +58,12 @@ sub read_list { if ($token ne $start) { die "expected '$start'"; } - while (($token = $rdr->peek()) ne $end) { - if (! defined $token) { + while (1) { + $token = $rdr->peek(); + if (! defined($token)) { die "expected '$end', got EOF"; } + last if ($token eq $end); push(@lst, read_form($rdr)); } $rdr->next(); diff --git a/rexx/reader.rexx b/rexx/reader.rexx index 3b992f9679..619e034a89 100644 --- a/rexx/reader.rexx +++ b/rexx/reader.rexx @@ -119,7 +119,7 @@ read_atom: procedure expose values. tokens. pos /* read_atom() */ return new_symbol(token) end -read_sequence: procedure expose values. tokens. pos /* read_sequence(type, end_char) */ +read_sequence: procedure expose values. tokens. pos err /* read_sequence(type, end_char) */ type = arg(1) end_char = arg(2) pos = pos + 1 /* Consume the open paren */ @@ -133,6 +133,10 @@ read_sequence: procedure expose values. tokens. pos /* read_sequence(type, end_c else seq = seq || " " || element token = tokens.pos + if token == "" then do + err = "expected '" || end_char || "', got EOF" + return "ERR" + end end pos = pos + 1 /* Consume the close paren */ return new_seq(type, seq) diff --git a/rexx/step1_read_print.rexx b/rexx/step1_read_print.rexx index eb697ff075..3101d67286 100644 --- a/rexx/step1_read_print.rexx +++ b/rexx/step1_read_print.rexx @@ -5,7 +5,7 @@ exit #include "reader.rexx" #include "printer.rexx" -read: procedure expose values. /* read(str) */ +read: procedure expose values. err /* read(str) */ return read_str(arg(1)) eval: procedure expose values. /* eval(exp, env) */ @@ -14,8 +14,11 @@ eval: procedure expose values. /* eval(exp, env) */ print: procedure expose values. /* print(exp) */ return pr_str(arg(1), 1) -rep: procedure expose values. /* rep(str) */ - return print(eval(read(arg(1), ""))) +rep: procedure expose values. env. err /* rep(str) */ + ast = read(arg(1)) + if ast == "ERR" then return "ERR" + exp = eval(ast) + return print(exp) main: values. = "" diff --git a/vimscript/reader.vim b/vimscript/reader.vim index f22debe6db..ed1a694cd1 100644 --- a/vimscript/reader.vim +++ b/vimscript/reader.vim @@ -24,6 +24,7 @@ function Tokenize(str) \ "\\~@\\|" . \ "[\\[\\]{}()'`~^@]\\|" . \ "\"\\%(\\\\.\\|[^\\\\\"]\\)*\"\\|" . + \ "\"\\%(\\\\.\\|[^\\\\\"]\\)*\\|" . \ ";[^\\n]*\\|" . \ "[^[:blank:]\\n\\[\\]{}('\"`,;)]*" . \ "\\)" @@ -66,6 +67,8 @@ function ReadAtom(rdr) return FloatNew(str2float(token)) elseif token =~ "^\".*\"$" return StringNew(ParseString(token)) + elseif token =~ "^\".*$" + throw "expected '\"', got EOF" elseif token =~ "^:" return KeywordNew(token[1:-1]) elseif token == "nil" @@ -87,11 +90,12 @@ function ReadTokensList(rdr, start, last) endif let token = a:rdr.peek() while token != a:last - if token == "" - throw "expected '" . a:last . "', got EOF" - endif call add(elements, ReadForm(a:rdr)) - let token = a:rdr.peek() + try + let token = a:rdr.peek() + catch + throw "expected '" . a:last . "', got EOF" + endtry endwhile call a:rdr.nexttoken() return elements From ae6e2220b3ae7d41febf3c386ccfb2d345dfd3de Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 29 Nov 2018 17:09:28 -0600 Subject: [PATCH 0400/1998] guile, hy, java, make, matlab, miniMAL: fix errors --- guile/reader.scm | 4 ++-- hy/step3_env.hy | 11 ++++++----- java/src/main/java/mal/step3_env.java | 2 ++ make/reader.mk | 8 ++++---- matlab/reader.m | 4 ++-- miniMAL/reader.json | 2 +- 6 files changed, 17 insertions(+), 14 deletions(-) diff --git a/guile/reader.scm b/guile/reader.scm index 38cebbe066..f6eabd5a2b 100644 --- a/guile/reader.scm +++ b/guile/reader.scm @@ -38,7 +38,7 @@ (define (delim-read reader delim) (let lp((next (reader 'peek)) (ret '())) (cond - ((null? next) (throw 'mal-error (format #f "expected '~a'" delim))) + ((null? next) (throw 'mal-error (format #f "expected '~a', got EOF" delim))) ((string=? next delim) (reader 'next) (reverse ret)) (else (let* ((cur (read_form reader)) @@ -85,7 +85,7 @@ ((eqv? (string-ref token 0) #\") (if (eqv? (string-ref token (- (string-length token) 1)) #\") (with-input-from-string token read) - (throw 'mal-error "expected '\"'"))) + (throw 'mal-error "expected '\"', got EOF"))) ((string-match "^:(.*)" token) => (lambda (m) (string->keyword (match:substring m 1)))) ((string=? "nil" token) nil) diff --git a/hy/step3_env.hy b/hy/step3_env.hy index 94c9fad380..62ef837e59 100755 --- a/hy/step3_env.hy +++ b/hy/step3_env.hy @@ -57,14 +57,15 @@ (pr-str exp True)) ;; repl -(def repl-env {'+ + - '- - - '* * - '/ (fn [a b] (int (/ a b)))}) - +(def repl-env (env-new)) (defn REP [str] (PRINT (EVAL (READ str) repl-env))) +(env-set repl-env '+ +) +(env-set repl-env '- -) +(env-set repl-env '* *) +(env-set repl-env '/ /) + (defmain [&rest args] ;; indented to match later steps (while True diff --git a/java/src/main/java/mal/step3_env.java b/java/src/main/java/mal/step3_env.java index d3e221b334..65649718b8 100644 --- a/java/src/main/java/mal/step3_env.java +++ b/java/src/main/java/mal/step3_env.java @@ -144,6 +144,8 @@ public static void main(String[] args) throws MalThrowable { System.out.println(PRINT(RE(repl_env, line))); } catch (MalContinue e) { continue; + } catch (MalException e) { + System.out.println("Error: " + printer._pr_str(e.getValue(), false)); } catch (MalThrowable t) { System.out.println("Error: " + t.getMessage()); continue; diff --git a/make/reader.mk b/make/reader.mk index 6f2707c029..3f620a1171 100755 --- a/make/reader.mk +++ b/make/reader.mk @@ -108,7 +108,7 @@ $(foreach ch,$(word 1,$($(1))),\ ,\ $(call READ_FORM,$(1))\ $(call READ_UNTIL,$(1),$(2),$(3))),\ - $(call _error,Expected '$(3)'))) + $(call _error,Expected '$(3)'$(COMMA) got EOF))) endef define DROP_UNTIL @@ -163,7 +163,7 @@ $(foreach ch,$(word 1,$($(1))),\ $(call do,$(call _assoc_seq!,$(thm),$(strip $(call READ_UNTIL,$(1),$(_RC),$(RCURLY)))))\ $(eval $(if $(filter $(_RC),$(word 1,$($(1)))),\ $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(RCURLY)')))\ + $(call _error,Expected '$(RCURLY)'$(COMMA) got EOF)))\ $(thm)),\ $(if $(filter $(_RP),$(ch)),\ $(call _error,Unexpected '$(RPAREN)'),\ @@ -174,7 +174,7 @@ $(foreach ch,$(word 1,$($(1))),\ $(call do,$(call _conj!,$(tlist),$(item)))))\ $(eval $(if $(filter $(_RP),$(word 1,$($(1)))),\ $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(RPAREN)')))\ + $(call _error,Expected '$(RPAREN)'$(COMMA) got EOF)))\ $(tlist)),\ $(if $(filter $(RBRACKET),$(ch)),\ $(call _error,Unexpected '$(RBRACKET)'),\ @@ -185,7 +185,7 @@ $(foreach ch,$(word 1,$($(1))),\ $(call do,$(call _conj!,$(tvec),$(item)))))\ $(eval $(if $(filter $(RBRACKET),$(word 1,$($(1)))),\ $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(RBRACKET)')))\ + $(call _error,Expected '$(RBRACKET)'$(COMMA) got EOF)))\ $(tvec)),\ $(call READ_ATOM,$(1)))))))))))))))) $(call READ_SPACES,$(1)) diff --git a/matlab/reader.m b/matlab/reader.m index 8cea773ac4..937c9534dd 100644 --- a/matlab/reader.m +++ b/matlab/reader.m @@ -39,12 +39,12 @@ seq = {}; token = rdr.next(); if not(strcmp(token, start)) - error(sprintf('expected ''%s''', start)); + error(sprintf('expected ''%s'', got EOF', start)); end token = rdr.peek(); while true if eq(token, false) - error(sprintf('expected ''%s''', last)); + error(sprintf('expected ''%s'', got EOF', last)); end if strcmp(token, last), break, end seq{end+1} = reader.read_form(rdr); diff --git a/miniMAL/reader.json b/miniMAL/reader.json index 830158e96e..dafa691f8c 100644 --- a/miniMAL/reader.json +++ b/miniMAL/reader.json @@ -61,7 +61,7 @@ ["`", []], ["cons", ["read-form", "rdr"], ["read-list-entries", "rdr", "start", "end"]]], - ["throw", ["str", ["`", "expected "], "end"]]]]]], + ["throw", ["str", ["`", "expected "], "end", ["`", ", got EOF"]]]]]]], ["def", "read-list", ["fn", ["rdr", "start", "end"], ["let", ["token", ["rdr-next", "rdr"]], From 2492836307768600f5529e8fbbdc4e1ff296f732 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 29 Nov 2018 17:10:01 -0600 Subject: [PATCH 0401/1998] plpgsql, racket, tcl, yorick: fix errors. --- plpgsql/reader.sql | 4 ++-- racket/reader.rkt | 4 ++-- tcl/reader.tcl | 4 ++-- yorick/reader.i | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/plpgsql/reader.sql b/plpgsql/reader.sql index 2368df23e3..cf1d8fdb5c 100644 --- a/plpgsql/reader.sql +++ b/plpgsql/reader.sql @@ -68,12 +68,12 @@ BEGIN token := tokens[p]; p := p + 1; IF token <> first THEN - RAISE EXCEPTION 'expected ''%''', first; + RAISE EXCEPTION 'expected ''%'', got EOF', first; END IF; items := ARRAY[]::integer[]; LOOP IF p > array_length(tokens, 1) THEN - RAISE EXCEPTION 'expected ''%''', last; + RAISE EXCEPTION 'expected ''%'', got EOF', last; END IF; token := tokens[p]; IF token = last THEN EXIT; END IF; diff --git a/racket/reader.rkt b/racket/reader.rkt index 6ff34cfb99..1e7f5fa779 100644 --- a/racket/reader.rkt +++ b/racket/reader.rkt @@ -42,7 +42,7 @@ (define (read_list_entries rdr end) (let ([tok (send rdr peek)]) (cond - [(eq? tok '()) (raise (string-append "expected '" end "'"))] + [(eq? tok '()) (raise (string-append "expected '" end "', got EOF"))] [(equal? end tok) '()] [else (cons (read_form rdr) (read_list_entries rdr end))]))) @@ -53,7 +53,7 @@ (let ([lst (read_list_entries rdr end)]) (send rdr next) lst) - (raise (string-append "expected '" start "'"))))) + (raise (string-append "expected '" start "', got EOF"))))) (define (read_form rdr) (let ([token (send rdr peek)]) diff --git a/tcl/reader.tcl b/tcl/reader.tcl index 16f21d9284..b5b4a6f297 100644 --- a/tcl/reader.tcl +++ b/tcl/reader.tcl @@ -31,14 +31,14 @@ proc tokenize str { proc read_tokens_list {reader start_char end_char} { set token [$reader next] if {$token != $start_char} { - error "expected '$start_char'" + error "expected '$start_char', got EOF" } set elements {} set token [$reader peek] while {$token != $end_char} { if {$token == ""} { - error "expected '$end_char'" + error "expected '$end_char', got EOF" } lappend elements [read_form $reader] set token [$reader peek] diff --git a/yorick/reader.i b/yorick/reader.i index b6bb15e92f..6da51d4041 100644 --- a/yorick/reader.i +++ b/yorick/reader.i @@ -71,14 +71,14 @@ func read_seq(rdr, start_char, end_char) { token = reader_next(rdr) if (token != start_char) { - return MalError(message=("expected '" + start_char + "'")) + return MalError(message=("expected '" + start_char + "', got EOF")) } elements = [] token = reader_peek(rdr) while (token != end_char) { if (token == string(0)) { - return MalError(message=("expected '" + end_char + "'")) + return MalError(message=("expected '" + end_char + "', got EOF")) } e = read_form(rdr) if (structof(e) == MalError) return e From b16fe73ec1ce93fb5ebcdea5208892d525aa27a5 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 13 Oct 2018 00:26:38 -0500 Subject: [PATCH 0402/1998] wasm: Steps 0-3 ported from basic. Preprocessor. Needs wace from https://github.com/kanaka/wac to run. wastpp.py processes the listed modules and outputs a single combined module. It finds inline strings and hoists them to the top into a data section and creates pointer variables into that memory and replaces the inline strings with pointer lookups. --- .gitignore | 2 + Makefile | 3 +- wasm/Dockerfile | 19 ++ wasm/Makefile | 24 ++ wasm/debug.wast | 194 ++++++++++++++++ wasm/env.wast | 90 ++++++++ wasm/mem.wast | 461 +++++++++++++++++++++++++++++++++++++ wasm/printer.wast | 148 ++++++++++++ wasm/reader.wast | 321 ++++++++++++++++++++++++++ wasm/run | 2 + wasm/step0_repl.wast | 41 ++++ wasm/step1_read_print.wast | 81 +++++++ wasm/step2_eval.wast | 269 ++++++++++++++++++++++ wasm/step3_env.wast | 329 ++++++++++++++++++++++++++ wasm/types.wast | 202 ++++++++++++++++ wasm/util.wast | 275 ++++++++++++++++++++++ wasm/wastpp.py | 123 ++++++++++ 17 files changed, 2583 insertions(+), 1 deletion(-) create mode 100644 wasm/Dockerfile create mode 100644 wasm/Makefile create mode 100644 wasm/debug.wast create mode 100644 wasm/env.wast create mode 100644 wasm/mem.wast create mode 100644 wasm/printer.wast create mode 100644 wasm/reader.wast create mode 100755 wasm/run create mode 100644 wasm/step0_repl.wast create mode 100644 wasm/step1_read_print.wast create mode 100644 wasm/step2_eval.wast create mode 100644 wasm/step3_env.wast create mode 100644 wasm/types.wast create mode 100644 wasm/util.wast create mode 100755 wasm/wastpp.py diff --git a/.gitignore b/.gitignore index f3eac16c45..d5c41ff45f 100644 --- a/.gitignore +++ b/.gitignore @@ -144,3 +144,5 @@ elm/elm-stuff elm/*.js !elm/node_readline.js !elm/bootstrap.js +wasm/*.wat +wasm/*.wasm diff --git a/Makefile b/Makefile index de8f929226..c7febc3eed 100644 --- a/Makefile +++ b/Makefile @@ -83,7 +83,7 @@ IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d d guile haskell haxe hy io java js julia kotlin livescript logo lua make mal \ matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp plpgsql \ plsql powershell ps python r racket rexx rpython ruby rust scala scheme skew \ - swift swift3 tcl ts vb vhdl vimscript yorick + swift swift3 tcl ts vb vhdl vimscript wasm yorick EXTENSION = .mal @@ -241,6 +241,7 @@ ts_STEP_TO_PROG = ts/$($(1)).js vb_STEP_TO_PROG = vb/$($(1)).exe vhdl_STEP_TO_PROG = vhdl/$($(1)) vimscript_STEP_TO_PROG = vimscript/$($(1)).vim +wasm_STEP_TO_PROG = wasm/$($(1)).wasm yorick_STEP_TO_PROG = yorick/$($(1)).i diff --git a/wasm/Dockerfile b/wasm/Dockerfile new file mode 100644 index 0000000000..a40c6fe035 --- /dev/null +++ b/wasm/Dockerfile @@ -0,0 +1,19 @@ +FROM ubuntu:18.04 + +RUN dpkg --add-architecture i386 && \ + apt-get -y update && \ + apt-get -y install \ + git-core cmake g++ lib32gcc-8-dev \ + libsdl2-dev:i386 libsdl2-image-dev:i386 \ + libedit-dev:i386 + +# TODO: merge up +RUN apt-get -y install python + +RUN git clone https://github.com/WebAssembly/binaryen/ && \ + cd binaryen && \ + cmake . && make && \ + make install + +# TODO: merge up +RUN apt-get -y install freeglut3-dev:i386 lib32gcc-7-dev libreadline-dev:i386 diff --git a/wasm/Makefile b/wasm/Makefile new file mode 100644 index 0000000000..46650e42fb --- /dev/null +++ b/wasm/Makefile @@ -0,0 +1,24 @@ +STEP0_DEPS = util.wast +STEP1_DEPS = $(STEP0_DEPS) types.wast mem.wast debug.wast reader.wast printer.wast +STEP2_DEPS = $(STEP1_DEPS) +STEP3_DEPS = $(STEP2_DEPS) env.wast + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +all: $(foreach s,$(STEPS),$(s).wasm) + +%.wasm: + ./wastpp.py $^ > $*.wat + wasm-as $*.wat -o $@ + +step0_repl.wasm: $(STEP0_DEPS) step0_repl.wast +step1_read_print.wasm: $(STEP1_DEPS) step1_read_print.wast +step2_eval.wasm: $(STEP2_DEPS) step2_eval.wast +step3_env.wasm: $(STEP3_DEPS) step3_env.wast + +.PHONY: clean + +clean: + rm -f *.wat *.wasm diff --git a/wasm/debug.wast b/wasm/debug.wast new file mode 100644 index 0000000000..18e5fa1c35 --- /dev/null +++ b/wasm/debug.wast @@ -0,0 +1,194 @@ +(module $debug + + (func $PR_VALUE (param $fmt i32) (param $mv i32) + (local $temp i32) + (set_local $temp (call $pr_str (get_local $mv))) + (call $printf_1 (get_local $fmt) (call $to_String (get_local $temp))) + (call $RELEASE (get_local $temp)) + ) + + (func $PR_MEMORY_VALUE (param $idx i32) (result i32) + (local $mv i32) + (local $type i32) + (local $size i32) + (local $val0 i32) + ;;; mv = mem + idx + (set_local $mv (call $MalVal_ptr (get_local $idx))) + (set_local $type (call $TYPE (get_local $mv))) + (set_local $size (call $MalVal_size (get_local $mv))) + (set_local $val0 (call $MalVal_val (get_local $idx) (i32.const 0))) + + ;;; printf(" %3d: type: %2d", idx, type) + (call $printf_2 (STRING " 0x%x: type: %d") + (get_local $idx) (get_local $type)) + + (if (i32.eq (get_local $type) (i32.const 15)) + (then + ;;; printf(", size: %2d", size) + (call $printf_1 (STRING ", size: %d") (get_local $size))) + (else + ;;; printf(", refs: %2d", (mv->refcnt_type - type)>>5) + (call $printf_1 (STRING ", refs: %d") (call $REFS (get_local $mv))))) + + ;;; printf(", [ %3d | %3d", mv->refcnt_type, val0) + (call $printf_2 (STRING ", [ 0x%x | 0x%x") + (call $MalVal_refcnt_type (get_local $idx)) + (get_local $val0)) + + (if (i32.eq (get_local $size) (i32.const 2)) + (then + (call $print (STRING " | --- | --- ]"))) + (else + ;;; printf(" | %3d", mv->val[1]) + (call $printf_1 (STRING " | 0x%x") + (call $MalVal_val (get_local $idx) (i32.const 1))) + (if (i32.eq (get_local $size) (i32.const 3)) + (then + (call $print (STRING " | --- ]"))) + (else + ;;; printf(" | %3d ]", mv->val[2]) + (call $printf_1 (STRING " | 0x%x ]") + (call $MalVal_val (get_local $idx) (i32.const 2))))))) + + ;;; printf(" >> ") + (call $print (STRING " >> ")) + + (block $done (block $unknown + (block (block (block (block (block (block (block (block + (block (block (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 $unknown (get_local $type))) + ;; 0: nil + (call $print (STRING "nil")) + (br $done)) + ;; 1: boolean + (if (i32.eq (get_local $val0) (i32.const 0)) + ;; true + (call $print (STRING "false")) + ;; false + (call $print (STRING "true"))) + (br $done)) + ;; 2: integer + (call $printf_1 (STRING "%d") (get_local $val0)) + (br $done)) + ;; 3: float/ERROR + (call $print (STRING " *** GOT FLOAT *** ")) + (br $done)) + ;; 4: string/kw + (call $printf_1 (STRING "'%s'") (call $to_String (get_local $mv))) + (br $done)) + ;; 5: symbol + (call $print (call $to_String (get_local $mv))) + (br $done)) + ;; 6: list + (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) + (then + (call $print (STRING "()"))) + (else + ;;; printf("(... %d ...), next: %d\n", mv->val[1], mv->val[0]) + (call $printf_2 (STRING "(... 0x%x ...), next: 0x%x") + (call $MalVal_val (get_local $idx) (i32.const 1)) + (call $MalVal_val (get_local $idx) (i32.const 0))))) + (br $done)) + ;; 7: vector + (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) + (then + (call $print (STRING "[]"))) + (else + ;;; printf("[... %d ...], next: %d\n", mv->val[1], mv->val[0])val + (call $printf_2 (STRING "[... %d ...], next: %d") + (call $MalVal_val (get_local $idx) (i32.const 1)) + (call $MalVal_val (get_local $idx) (i32.const 0))))) + (br $done)) + ;; 8: hashmap + (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) + (then + (call $print (STRING "{}"))) + (else + ;;; printf("{... '%s'(%d) : %d ...}\n", + ;; to_String(mem + mv->val[1]), mv->val[1], mv->val[2]) + (call $printf_3 (STRING "{... '%s'(%d) : %d ...}") + (call $to_String + (call $MalVal_ptr + (call $MalVal_val (get_local $idx) (i32.const 1)))) + (call $MalVal_val (get_local $idx) (i32.const 1)) + (call $MalVal_val (get_local $idx) (i32.const 2))))) + (br $done)) + ;; 9: function + (call $print (STRING "function")) + (br $done)) + ;; 10: mal function + (call $print (STRING "mal function")) + (br $done)) + ;; 11: macro fn + (call $print (STRING "macro fn")) + (br $done)) + ;; 12: atom + (call $print (STRING "atom")) + (br $done)) + ;; 13: environment + (call $print (STRING "environment")) + (br $done)) + ;; 14: metadata + (call $print (STRING "metadata")) + (br $done)) + ;; 15: FREE + (call $printf_1 (STRING "FREE next: 0x%x") (get_local $val0)) + (if (i32.eq (get_local $idx) (get_global $mem_free_list)) + (call $print (STRING " (free start)"))) + (if (i32.eq (get_local $val0) (get_global $mem_unused_start)) + (call $print (STRING " (free end)"))) + (br $done)) + ;; 16: unknown + (call $print (STRING "unknown")) + ) + + (drop (call $putchar (i32.const 0xA))) + + (i32.add (get_local $size) (get_local $idx)) + ) + + (func $PR_MEMORY (param $start i32) (param $end i32) + (local $idx i32) + (if (i32.lt_s (get_local $start) (i32.const 0)) + (set_local $start (get_global $mem_user_start))) + (if (i32.lt_s (get_local $end) (i32.const 0)) + (set_local $end (get_global $mem_unused_start))) + ;;; printf("Values - (mem) showing %d -> %d", start, end) + ;;; printf(" (unused start: %d, free list: %d):\n", + ;;; mem_unused_start, mem_free_list) + (call $printf_4 (STRING "Values - (mem) showing 0x%x -> 0x%x (unused start: 0x%x, free list: 0x%x):\n") + (get_local $start) + (get_local $end) + (get_global $mem_unused_start) + (get_global $mem_free_list)) + + (if (i32.le_s (get_local $end) (get_local $start)) + (then + (call $print (STRING " ---\n")) + (set_local $end (get_global $mem_unused_start))) + (else + (set_local $idx (get_local $start)) + ;;; while (idx < end) + (block $loopvals_exit + (loop $loopvals + (if (i32.ge_s (get_local $idx) (get_local $end)) + (br $loopvals_exit)) + (set_local $idx (call $PR_MEMORY_VALUE (get_local $idx))) + (br $loopvals) + ) + ))) + ) + + (func $PR_MEMORY_RAW (param $start i32) (param $end i32) + (block $loop_exit + (loop $loop + (if (i32.ge_u (get_local $start) (get_local $end)) + (br $loop_exit)) + (call $printf_2 (STRING "0x%x 0x%x\n") + (get_local $start) (i32.load (get_local $start))) + (set_local $start (i32.add (i32.const 4) (get_local $start))) + (br $loop) + ) + ) + ) +) diff --git a/wasm/env.wast b/wasm/env.wast new file mode 100644 index 0000000000..9e36586062 --- /dev/null +++ b/wasm/env.wast @@ -0,0 +1,90 @@ +(module $env + + (func $ENV_NEW (param $outer i32) (result i32) + (local $data i32) + (local $env i32) + + ;; allocate the data hashmap + (set_local $data (call $HASHMAP)) + + (set_local $env (call $ALLOC (get_global $ENVIRONMENT_T) + (get_local $data) (get_local $outer) (i32.const 0))) + ;; environment takes ownership + (call $RELEASE (get_local $data)) + (get_local $env) + ) + + (func $ENV_SET (param $env i32) (param $key i32) (param $value i32) + (result i32) + (local $data i32) + (set_local $data (call $MEM_VAL0_ptr (get_local $env))) + (i32.store (call $VAL0_ptr (get_local $env)) + (call $MalVal_index + (call $ASSOC1 (get_local $data) + (get_local $key) (get_local $value)))) + (get_local $value) + ) + + (func $ENV_SET_S (param $env i32) (param $key i32) (param $value i32) + (result i32) + (local $data i32) + (set_local $data (call $MEM_VAL0_ptr (get_local $env))) + (i32.store (call $VAL0_ptr (get_local $env)) + (call $MalVal_index + (call $ASSOC1_S (get_local $data) + (get_local $key) (get_local $value)))) + (get_local $value) + ) + + (func $ENV_FIND (param $env i32) (param $key i32) (result i64) + (local $res i32) + (local $data i32) + (local $found_res i64) + + (set_local $res (i32.const 0)) + + (block $done + (loop $loop + (set_local $data (call $MEM_VAL0_ptr (get_local $env))) + (set_local $found_res (call $HASHMAP_GET (get_local $data) + (get_local $key))) + ;;; if (found) + (if (i32.wrap/i64 (i64.shr_u (get_local $found_res) + (i64.const 32))) + (then + (set_local $res (i32.wrap/i64 (get_local $found_res))) + (br $done))) + (set_local $env (call $MEM_VAL1_ptr (get_local $env))) + (if (i32.eq (get_local $env) (get_global $NIL)) + (then + (set_local $env (i32.const 0)) + (br $done))) + (br $loop) + ) + ) + + ;; combine res/env as hi 32/low 32 of i64 + (i64.or + (i64.shl_u (i64.extend_u/i32 (get_local $res)) + (i64.const 32)) + (i64.extend_u/i32 (get_local $env))) + ) + + (func $ENV_GET (param $env i32) (param $key i32) (result i32) + (local $res i32) + (local $res_env i64) + (set_local $res (i32.const 0)) + + (set_local $res_env (call $ENV_FIND (get_local $env) (get_local $key))) + (set_local $env (i32.wrap/i64 (get_local $res_env))) + (set_local $res (i32.wrap/i64 (i64.shr_u (get_local $res_env) + (i64.const 32)))) + + (if (i32.eqz (get_local $env)) + (then + (call $THROW_STR_1 (STRING "'%s' not found") + (call $to_String (get_local $key))) + (return (get_local $res)))) + (return (call $INC_REF (get_local $res))) + ) +) diff --git a/wasm/mem.wast b/wasm/mem.wast new file mode 100644 index 0000000000..43464cd0d8 --- /dev/null +++ b/wasm/mem.wast @@ -0,0 +1,461 @@ +(module $mem + (global $MEM_SIZE i32 (i32.const 1048576)) + (global $STRING_MEM_SIZE i32 (i32.const 1048576)) + + (global $heap_start (mut i32) (i32.const 0)) + (global $heap_end (mut i32) (i32.const 0)) + + (global $mem (mut i32) (i32.const 0)) + (global $mem_unused_start (mut i32) (i32.const 0)) + (global $mem_free_list (mut i32) (i32.const 0)) + (global $mem_user_start (mut i32) (i32.const 0)) + +;; (global $string_mem (mut i32) (i32.const 0)) +;; (global $string_mem_next (mut i32) (i32.const 0)) +;; (global $string_mem_user_start (mut i32) (i32.const 0)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General type storage/pointer functions + + (func $VAL0_ptr (param $mv i32) (result i32) + (i32.add (get_local $mv) (i32.const 4))) + (func $VAL1_ptr (param $mv i32) (result i32) + (i32.add (get_local $mv) (i32.const 8))) + + (func $VAL0 (param $mv i32) (result i32) + (i32.load (i32.add (get_local $mv) (i32.const 4)))) + (func $VAL1 (param $mv i32) (result i32) + (i32.load (i32.add (get_local $mv) (i32.const 8)))) + + + (func $MEM_VAL0_ptr (param $mv i32) (result i32) + (i32.add (get_global $mem) + (i32.mul_u (i32.load (i32.add (get_local $mv) (i32.const 4))) + (i32.const 8)))) + (func $MEM_VAL1_ptr (param $mv i32) (result i32) + (i32.add (get_global $mem) + (i32.mul_u (i32.load (i32.add (get_local $mv) (i32.const 8))) + (i32.const 8)))) + (func $MEM_VAL2_ptr (param $mv i32) (result i32) + (i32.add (get_global $mem) + (i32.mul_u (i32.load (i32.add (get_local $mv) (i32.const 12))) + (i32.const 8)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Returns the address of 'mem[mv_idx]' + (func $MalVal_ptr (param $mv_idx i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + ;;; mem[mv_idx].refcnt_type + (i32.add (get_global $mem) + (i32.mul_u (get_local $mv_idx) (i32.const 8)))) + + ;; Returns the memory index mem of mv + ;; Will usually be used with a load or store by the caller + (func $MalVal_index (param $mv i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + (i32.div_u (i32.sub_u (get_local $mv) (get_global $mem)) + (i32.const 8))) + + ;; Returns the address of 'mem[mv_idx].refcnt_type' + (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) + (i32.load (call $MalVal_ptr (get_local $mv_idx)))) + + (func $TYPE (param $mv i32) (result i32) + ;;; type = mv->refcnt_type & 31 + (i32.and (i32.load (get_local $mv)) + (i32.const 0x1f))) ;; 0x1f == 31 + + (func $REFS (param $mv i32) (result i32) + ;;; type = mv->refcnt_type & 31 + (i32.shr_u (i32.load (get_local $mv)) + (i32.const 5))) ;; / 32 + + ;; Returns the address of 'mem[mv_idx].val[val]' + ;; Will usually be used with a load or store by the caller + (func $MalVal_val_ptr (param $mv_idx i32) (param $val i32) (result i32) + (i32.add (i32.add (call $MalVal_ptr (get_local $mv_idx)) + (i32.const 4)) + (i32.mul_u (get_local $val) + (i32.const 4)))) + + ;; Returns the value of 'mem[mv_idx].val[val]' + (func $MalVal_val (param $mv_idx i32) (param $val i32) (result i32) + (i32.load (call $MalVal_val_ptr (get_local $mv_idx) (get_local $val)))) + + (func $MalType_size (param $type i32) (result i32) + ;;; if (type <= 5 || type == 9 || type == 12) + (if i32 (i32.or (i32.le_u (get_local $type) (i32.const 5)) + (i32.or (i32.eq (get_local $type) (i32.const 9)) + (i32.eq (get_local $type) (i32.const 12)))) + (then (i32.const 2)) + (else + ;;; else if (type == 8 || type == 10 || type == 11) + (if i32 (i32.or (i32.eq (get_local $type) (i32.const 8)) + (i32.or (i32.eq (get_local $type) (i32.const 10)) + (i32.eq (get_local $type) (i32.const 11)))) + (then (i32.const 4)) + (else (i32.const 3)))))) + + (func $MalVal_size (param $mv i32) (result i32) + (local $type i32) + (set_local $type (call $TYPE (get_local $mv))) + ;; if (type == FREE_T) + (if i32 (i32.eq (get_local $type) (get_global $FREE_T)) + (then + ;;; return (mv->refcnt_type & 0xffe0)>>5 + (i32.shr_u + (i32.and + (i32.load (get_local $mv)) + (i32.const 0xffe0)) + (i32.const 5))) ;;; / 32 + (else + ;;; return MalType_size(type) + (call $MalType_size (get_local $type))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; init_memory + + (func $init_memory + (local $heap_size i32) + +;; (call $print (STRING ">>> init_memory\n")) + + (call $init_sprintf_mem) + + ;; 100 character error_str static buffer + (set_global $error_str (STRING " ")) + ;; 256 character token static buffer + (set_global $token (STRING " ")) + + (set_local $heap_size (i32.add (get_global $MEM_SIZE) + (get_global $STRING_MEM_SIZE))) + (set_global $heap_start (i32.add (get_global $memoryBase) + (get_global $S_STRING_END))) + (set_global $heap_end (i32.add (get_global $heap_start) + (get_local $heap_size))) + + (set_global $mem (get_global $heap_start)) + (set_global $mem_unused_start (i32.const 0)) + (set_global $mem_free_list (i32.const 0)) + +;; (set_global $string_mem (i32.add (get_global $heap_start) +;; (get_global $MEM_SIZE))) +;; (set_global $string_mem_next (get_global $string_mem)) + + ;; Empty values + (set_global $NIL + (call $ALLOC_SCALAR (get_global $NIL_T) (i32.const 0))) + (set_global $FALSE + (call $ALLOC_SCALAR (get_global $BOOLEAN_T) (i32.const 0))) + (set_global $TRUE + (call $ALLOC_SCALAR (get_global $BOOLEAN_T) (i32.const 1))) + (set_global $EMPTY_LIST + (call $ALLOC (get_global $LIST_T) + (get_global $NIL) (get_global $NIL) (get_global $NIL))) + (set_global $EMPTY_VECTOR + (call $ALLOC (get_global $VECTOR_T) + (get_global $NIL) (get_global $NIL) (get_global $NIL))) + (set_global $EMPTY_HASHMAP + (call $ALLOC (get_global $HASHMAP_T) + (get_global $NIL) (get_global $NIL) (get_global $NIL))) + +;; (call $print (STRING "<<< init_memory\n")) + + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; memory management + + (func $ALLOC_INTERNAL (param $type i32) (param $val1 i32) + (param $val2 i32) (param $val3 i32) (result i32) + (local $prev i32) + (local $res i32) + (local $size i32) + (set_local $prev (get_global $mem_free_list)) + (set_local $res (get_global $mem_free_list)) + (set_local $size (call $MalType_size (get_local $type))) + + (block $loop_done + (loop $loop + ;; res == mem_unused_start + (if (i32.eq (get_local $res) (get_global $mem_unused_start)) + (then + ;; ALLOC_UNUSED + ;;; if (res + size > MEM_SIZE) + (if (i32.gt_u (i32.add (get_local $res) (get_local $size)) + (get_global $MEM_SIZE)) + (then + ;; Out of memory, exit + (call $print (STRING "Out of mal memory!\n")) + (call $exit (i32.const 1)))) + ;;; if (mem_unused_start += size) + (set_global $mem_unused_start + (i32.add (get_global $mem_unused_start) + (get_local $size))) + ;;; if (prev == res) + (if (i32.eq (get_local $prev) (get_local $res)) + (then + (set_global $mem_free_list (get_global $mem_unused_start))) + (else + ;;; mem[prev].val[0] = mem_unused_start + (i32.store + (call $MalVal_val_ptr (get_local $prev) (i32.const 0)) + (get_global $mem_unused_start)))) + (br $loop_done))) + ;; if (MalVal_size(mem+res) == size) + (if (i32.eq (call $MalVal_size (call $MalVal_ptr (get_local $res))) + (get_local $size)) + (then + ;; ALLOC_MIDDLE + ;;; if (res == mem_free_list) + (if (i32.eq (get_local $res) (get_global $mem_free_list)) + ;; set free pointer (mem_free_list) to next free + ;;; mem_free_list = mem[res].val[0]; + (set_global $mem_free_list + (call $MalVal_val (get_local $res) (i32.const 0)))) + ;; if (res != mem_free_list) + (if (i32.ne (get_local $res) (get_global $mem_free_list)) + ;; set previous free to next free + ;;; mem[prev].val[0] = mem[res].val[0] + (i32.store (call $MalVal_val_ptr (get_local $prev) (i32.const 0)) + (call $MalVal_val (get_local $res) (i32.const 0)))) + (br $loop_done))) + ;;; prev = res + (set_local $prev (get_local $res)) + ;;; res = mem[res].val[0] + (set_local $res (call $MalVal_val (get_local $res) (i32.const 0))) + (br $loop) + ) + ) + ;; ALLOC_DONE + ;;; mem[res].refcnt_type = type + 32 + (i32.store (call $MalVal_ptr (get_local $res)) + (i32.add (get_local $type) (i32.const 32))) + ;; set val to default val1 + ;;; mem[res].val[0] = val1 + (i32.store (call $MalVal_val_ptr (get_local $res) (i32.const 0)) + (get_local $val1)) + ;;; if (type > 5 && type != 9) + (if (i32.and (i32.gt_u (get_local $type) (i32.const 5)) + (i32.ne (get_local $type) (i32.const 9))) + (then + ;; inc refcnt of referenced value + ;;; mem[val1].refcnt_type += 32 + (i32.store (call $MalVal_ptr (get_local $val1)) + (i32.add (call $MalVal_refcnt_type (get_local $val1)) + (i32.const 32))))) + ;;; if (size > 2) + (if (i32.gt_u (get_local $size) (i32.const 2)) + (then + ;; inc refcnt of referenced value + ;;; mem[val2].refcnt_type += 32 + (i32.store (call $MalVal_ptr (get_local $val2)) + (i32.add (call $MalVal_refcnt_type (get_local $val2)) + (i32.const 32))) + ;;; mem[res].val[1] = val2 + (i32.store (call $MalVal_val_ptr (get_local $res) (i32.const 1)) + (get_local $val2)))) + ;;; if (size > 3) + (if (i32.gt_u (get_local $size) (i32.const 3)) + (then + ;; inc refcnt of referenced value + ;;; mem[val3].refcnt_type += 32 + (i32.store (call $MalVal_ptr (get_local $val3)) + (i32.add (call $MalVal_refcnt_type (get_local $val3)) + (i32.const 32))) + ;;; mem[res].val[2] = val3 + (i32.store (call $MalVal_val_ptr (get_local $res) (i32.const 2)) + (get_local $val3)))) + + ;;; return mem + res + (call $MalVal_ptr (get_local $res)) + ) + + (func $ALLOC_SCALAR (param $type i32) (param $val1 i32) + (result i32) + (call $ALLOC_INTERNAL + (get_local $type) + (get_local $val1) + (i32.const 0) + (i32.const 0)) + ) + + (func $ALLOC (param $type i32) (param $val1 i32) + (param $val2 i32) (param $val3 i32) (result i32) + (call $ALLOC_INTERNAL + (get_local $type) + (call $MalVal_index (get_local $val1)) + (call $MalVal_index (get_local $val2)) + (call $MalVal_index (get_local $val3))) + ) + + (func $RELEASE (param $mv i32) + (local $idx i32) + (local $type i32) + (local $size i32) + + ;; Ignore NULLs + ;;; if (mv == NULL) { return; } + (if (i32.eqz (get_local $mv)) (return)) + ;;; idx = mv - mem + (set_local $idx (call $MalVal_index (get_local $mv))) + ;;; type = mv->refcnt_type & 31 + (set_local $type (i32.and (i32.load (get_local $mv)) + (i32.const 0x1f))) ;; 0x1f == 31 + ;;; size = MalType_size(type) + (set_local $size (call $MalType_size (get_local $type))) + + ;; DEBUG + ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) +;; (call $print (STRING ">>> RELEASE idx: ")) +;; (call $printhex (get_local $idx)) +;; (call $print (STRING ", type: ")) +;; (call $printnum (get_local $type) (i32.const 10)) +;; (call $print (STRING ", size: ")) +;; (call $printnum (get_local $size) (i32.const 10)) +;; (call $print (STRING "\n")) + + (if (i32.eq (i32.const 0) (get_local $mv)) + (then + (call $print (STRING "RELEASE of NULL!\n")) + (call $exit (i32.const 1)))) + + (if (i32.eq (get_global $FREE_T) (get_local $type)) + (then + (call $printf_2 (STRING "RELEASE of already free mv: 0x%x, idx: 0x%x\n") + (get_local $mv) (get_local $idx)) + (call $exit (i32.const 1)))) + (if (i32.lt_u (call $MalVal_refcnt_type (get_local $idx)) + (i32.const 15)) + (then + (call $printf_2 (STRING "RELEASE of unowned mv: 0x%x, idx: 0x%x\n") + (get_local $mv) (get_local $idx)) + (call $exit (i32.const 1)))) + + ;; decrease reference count by one + (i32.store (call $MalVal_ptr (get_local $idx)) + (i32.sub_u (call $MalVal_refcnt_type (get_local $idx)) + (i32.const 32))) + + ;; nil, false, true, empty sequences + (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) + (then + (if (i32.lt_u (call $MalVal_refcnt_type (get_local $idx)) + (i32.const 32)) + (then + (call $printf_2 (STRING "RELEASE of unowned mv: 0x%x, idx: 0x%x\n") + (get_local $mv) (get_local $idx)) + (call $exit (i32.const 1)))) + (return))) + + ;; our reference count is not 0, so don't release + (if (i32.ge_u (call $MalVal_refcnt_type (get_local $idx)) + (i32.const 32)) + (return)) + + (block $done + (block (block (block (block (block (block + (br_table 0 0 0 0 1 1 2 2 3 5 5 5 5 4 5 5 5 (get_local $type))) + ;; nil, boolean, integer, float + (br $done)) + ;; string, kw, symbol + ;; release string, then FREE reference + (call $RELEASE_STRING (get_local $mv)) + (br $done)) + ;; list, vector + (if (i32.ne (call $MalVal_val (get_local $idx) (i32.const 0)) + (i32.const 0)) + (then + ;; release next element and value + (call $RELEASE (call $MEM_VAL0_ptr (get_local $mv))) + (call $RELEASE (call $MEM_VAL1_ptr (get_local $mv))))) + (br $done)) + ;; hashmap + (if (i32.ne (call $MalVal_val (get_local $idx) (i32.const 0)) + (i32.const 0)) + (then + ;; release next element, value, and key + (call $RELEASE (call $MEM_VAL0_ptr (get_local $mv))) + (call $RELEASE (call $MEM_VAL2_ptr (get_local $mv))) + (call $RELEASE (call $MEM_VAL1_ptr (get_local $mv))))) + (br $done)) + ;; env + ;; if outer is set then release outer + (if (i32.ne (call $MalVal_val (get_local $idx) (i32.const 1)) + (i32.const 0)) + (call $RELEASE (call $MEM_VAL1_ptr (get_local $mv)))) + ;; release the hashmap data + (call $RELEASE (call $MEM_VAL0_ptr (get_local $mv))) + (br $done)) + ;; default/unknown + ) + + ;; FREE, free the current element + + ;; set type(FREE/15) and size + ;;; mv->refcnt_type = size*32 + FREE_T + (i32.store (get_local $mv) + (i32.add (i32.mul_u (get_local $size) + (i32.const 32)) + (get_global $FREE_T))) + (i32.store (call $MalVal_val_ptr (get_local $idx) (i32.const 0)) + (get_global $mem_free_list)) + (set_global $mem_free_list (get_local $idx)) + (if (i32.ge_u (get_local $size) (i32.const 3)) + (i32.store (call $MalVal_val_ptr (get_local $idx) (i32.const 1)) + (i32.const 0))) + (if (i32.eq (get_local $size) (i32.const 4)) + (i32.store (call $MalVal_val_ptr (get_local $idx) (i32.const 2)) + (i32.const 0))) + ) + + ;; Allocate a string as follows: + ;; refcnt (i32 set to 1), string data, NULL byte + (func $STRING_DUPE (param $str i32) (result i32) + (local $len i32) + (local $cur i32) + (local $new i32) + (local $idx i32) + + ;; Calculate length of string needed + (set_local $len (call $STRING_LEN (get_local $str))) + + ;; leading i32 refcnt + trailing NULL + (set_local $new (call $malloc (i32.add (i32.const 5) (get_local $len)))) + + ;; DEBUG +;; (call $debug (STRING "STRING_DUPE - malloc returned: ") (get_local $new)) + + ;; set initial refcnt to 1 + (i32.store (get_local $new) (i32.const 1)) + ;; skip refcnt + (set_local $cur (i32.add (get_local $new) (i32.const 4))) + ;; Set NULL terminator + (i32.store8_u (i32.add (get_local $cur) (get_local $len)) (i32.const 0)) + + ;; Copy the characters + (call $MEM_COPY (get_local $cur) (get_local $str) (get_local $len)) + (get_local $new) + ) + + ;; Duplicate regular character array string into a Mal string and + ;; return the MalVal pointer + (func $STRING (param $type i32) (param $str i32) (result i32) + (call $ALLOC_SCALAR + (get_local $type) + (call $STRING_DUPE (get_local $str))) + ) + + (func $RELEASE_STRING (param $mv i32) + (local $str i32) + (set_local $str (call $MalVal_val + (call $MalVal_index (get_local $mv)) + (i32.const 0))) + + ;; DEBUG +;; (call $debug (STRING "RELEASE_STRING - calling free on: ") (get_local $str)) + + (call $free (get_local $str)) + ) +) diff --git a/wasm/printer.wast b/wasm/printer.wast new file mode 100644 index 0000000000..7f88ded823 --- /dev/null +++ b/wasm/printer.wast @@ -0,0 +1,148 @@ +(module $printer + + (func $pr_str_val (param $res i32) (param $mv i32) (result i32) + (local $type i32) + (local $val0 i32) + (local $sval i32) + (set_local $type (call $TYPE (get_local $mv))) + (set_local $val0 (call $MalVal_val (call $MalVal_index (get_local $mv)) + (i32.const 0))) + + ;;; switch(type) + (block $done + (block $default + (block (block (block (block (block (block (block (block + (block (block (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (get_local $type))) + ;; 0: nil + (call $MEM_COPY (get_local $res) (STRING "nil") (i32.const 4)) + (set_local $res (i32.add (i32.const 3) (get_local $res))) + (br $done)) + ;; 1: boolean + (if (i32.eq (get_local $val0) (i32.const 0)) + (then + ;; false + (call $MEM_COPY (get_local $res) (STRING "false") (i32.const 5)) + (set_local $res (i32.add (i32.const 5) (get_local $res)))) + (else + ;; true + (call $MEM_COPY (get_local $res) (STRING "true") (i32.const 4)) + (set_local $res (i32.add (i32.const 4) (get_local $res))))) + (br $done)) + ;; 2: integer + (set_local $res (call $sprintf_1 (get_local $res) (STRING "%d") + (get_local $val0))) + (br $done)) + ;; 3: float/ERROR + (set_local $res (call $sprintf_1 (get_local $res) (STRING "%d") + (STRING " *** GOT FLOAT *** "))) + (br $done)) + ;; 4: string/kw + (set_local $sval (call $to_String (get_local $mv))) + (if (i32.eq (i32.load8_u (get_local $sval)) (CHAR "\x7f")) + (then + (set_local $res (call $sprintf_1 (get_local $res) (STRING ":%s") + (i32.add (get_local $sval) (i32.const 1))))) + (else + (set_local $res (call $sprintf_1 (get_local $res) (STRING "\"%s\"") + (call $to_String (get_local $mv)))))) + (br $done)) + ;; 5: symbol + (set_local $res (call $sprintf_1 (get_local $res) (STRING "%s") + (call $to_String (get_local $mv)))) + (br $done)) + ;; 6: list, fallthrouogh + ) + ;; 7: vector, fallthrough + ) + ;; 8: hashmap + (set_local + $res (call $sprintf_1 (get_local $res) (STRING "%c") + (if i32 (i32.eq (get_local $type) (get_global $LIST_T)) + (CHAR "(") + (else (if i32 (i32.eq (get_local $type) (get_global $VECTOR_T)) + (CHAR "[") + (else (CHAR "{"))))))) + ;; PR_SEQ_LOOP + ;;; while (VAL0(mv) != 0) + (block $done_seq + (loop $seq_loop + (if (i32.eq (call $VAL0 (get_local $mv)) (i32.const 0)) + (br $done_seq)) + ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) + (set_local $res (call $pr_str_val (get_local $res) + (call $MEM_VAL1_ptr (get_local $mv)))) + + ;; if this is a hash-map, print the next element + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (then + ;;; res += snprintf(res, 2, " ") + (set_local $res (call $sprintf_1 (get_local $res) (STRING " ") + (i32.const 0))) + (set_local $res (call $pr_str_val (get_local $res) + (call $MEM_VAL2_ptr (get_local $mv)))))) + ;;; mv = MEM_VAL0(mv) + (set_local $mv (call $MEM_VAL0_ptr (get_local $mv))) + ;;; if (VAL0(mv) != 0) + (if (i32.ne (call $VAL0 (get_local $mv)) (i32.const 0)) + ;;; res += snprintf(res, 2, " ") + (set_local $res (call $sprintf_1 (get_local $res) (STRING " ") + (i32.const 0)))) + ;;(call $print (STRING "here4\n")) + (br $seq_loop) + ) + ) + + (set_local + $res (call $sprintf_1 (get_local $res) (STRING "%c") + (if i32 (i32.eq (get_local $type) (get_global $LIST_T)) + (CHAR ")") + (else (if i32 (i32.eq (get_local $type) (get_global $VECTOR_T)) + (CHAR "]") + (else (CHAR "}"))))))) + (br $done)) + ;; 9: function + (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 10)) + (set_local $res (i32.add (i32.const 9) (get_local $res))) + (br $done)) + ;; 10: mal function + (call $MEM_COPY (get_local $res) (STRING "(fn* ...)") (i32.const 10)) + (set_local $res (i32.add (i32.const 9) (get_local $res))) + (br $done)) + ;; 11: macro fn + (call $print (STRING "macro fn")) + (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 13)) + (set_local $res (i32.add (i32.const 12) (get_local $res))) + (br $done)) + ;; 12: atom + (call $MEM_COPY (get_local $res) (STRING "(atom ...)") (i32.const 11)) + (set_local $res (i32.add (i32.const 10) (get_local $res))) + (br $done)) + ;; 13: environment + (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 11)) + (set_local $res (i32.add (i32.const 10) (get_local $res))) + (br $done)) + ;; 14: metadata + (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 12)) + (set_local $res (i32.add (i32.const 11) (get_local $res))) + (br $done)) + ;; 15: FREE + (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 12)) + (set_local $res (i32.add (i32.const 11) (get_local $res))) + (br $done)) + ;; 16: default + (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 11)) + (set_local $res (i32.add (i32.const 10) (get_local $res))) + ) + + (get_local $res) + ) + + (func $pr_str (param $mv i32) (result i32) + (drop (call $pr_str_val (get_global $sprintf_buf) (get_local $mv))) + (call $STRING (get_global $STRING_T) (get_global $sprintf_buf)) + ) + + (export "pr_str" (func $pr_str)) + +) diff --git a/wasm/reader.wast b/wasm/reader.wast new file mode 100644 index 0000000000..3b16df3acb --- /dev/null +++ b/wasm/reader.wast @@ -0,0 +1,321 @@ +(module $reader + + ;; TODO: global warning + (global $token (mut i32) (i32.const 0)) + (global $read_index (mut i32) (i32.const 0)) + + (func $skip_spaces (param $str i32) (result i32) + (local $found i32) + (local $c i32) + (set_local $found (i32.const 0)) + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + (block $done + (loop $loop + ;;; while (c == ' ' || c == ',' || c == '\n') + (if (i32.and (i32.and + (i32.ne (get_local $c) (CHAR " ")) + (i32.ne (get_local $c) (CHAR ","))) + (i32.ne (get_local $c) (CHAR "\n"))) + (br $done)) + (set_local $found (i32.const 1)) + ;;; c=str[++(*index)] + (set_global $read_index (i32.add (get_global $read_index) + (i32.const 1))) + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + (br $loop) + ) + ) +;; (call $debug (STRING ">>> skip_spaces:") (get_local $found)) + (get_local $found) + ) + + (func $skip_to_eol (param $str i32) (result i32) + (local $found i32) + (local $c i32) + (set_local $found (i32.const 0)) + (set_local $c (i32.load8_c (i32.add (get_local $str) + (get_global $read_index)))) + (if (i32.eq (get_local $c) (CHAR ";")) + (then + (set_local $found (i32.const 1)) + (block $done + (loop $loop + ;;; c=str[++(*index)] + (set_global $read_index (i32.add (get_global $read_index) + (i32.const 1))) + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + ;;; while (c != '\0' && c != '\n') + (if (i32.and (i32.ne (get_local $c) (CHAR "\x00")) + (i32.ne (get_local $c) (CHAR "\n"))) + (br $loop)) + ) + ))) +;; (call $debug (STRING ">>> skip_to_eol:") (get_local $found)) + (get_local $found) + ) + + (func $skip_spaces_comments (param $str i32) + (loop $loop + ;; skip spaces + (if (call $skip_spaces (get_local $str)) (br $loop)) + ;; skip comments + (if (call $skip_to_eol (get_local $str)) (br $loop)) + ) + ) + + (func $read_token (param $str i32) (result i32) + (local $token_index i32) + (local $instring i32) + (local $escaped i32) + (local $c i32) + (set_local $token_index (i32.const 0)) + (set_local $instring (i32.const 0)) + (set_local $escaped (i32.const 0)) + + (call $skip_spaces_comments (get_local $str)) + + ;; read first character + ;;; c=str[++(*index)] + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + (set_global $read_index (i32.add (get_global $read_index) + (i32.const 1))) + ;; read first character + ;;; token[token_index++] = c + (i32.store8_u (i32.add (get_global $token) (get_local $token_index)) + (get_local $c)) + (set_local $token_index (i32.add (get_local $token_index) + (i32.const 1))) + ;; single/double character token + (if (i32.or (i32.eq (get_local $c) (CHAR "(")) + (i32.or (i32.eq (get_local $c) (CHAR ")")) + (i32.or (i32.eq (get_local $c) (CHAR "[")) + (i32.or (i32.eq (get_local $c) (CHAR "]")) + (i32.or (i32.eq (get_local $c) (CHAR "{")) + (i32.or (i32.eq (get_local $c) (CHAR "}")) + (i32.or (i32.eq (get_local $c) (CHAR "'")) + (i32.or (i32.eq (get_local $c) (CHAR "`")) + (i32.or (i32.eq (get_local $c) (CHAR "@")) + (i32.and (i32.eq (get_local $c) (CHAR "~")) + (i32.eq (i32.load8_u (i32.add (get_local $str) + (get_global $read_index))) + (CHAR "@")))))))))))) + + (then + ;; continue + (nop)) + (else + ;;; if (c == '"') instring = true + (set_local $instring (i32.eq (get_local $c) (CHAR "\""))) + (block $done + (loop $loop + ;; peek at next character + ;;; c = str[*index] + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + ;;; if (c == '\0') break + (if (i32.eq (get_local $c) (i32.const 0)) (br $done)) + ;;; if (!instring) + (if (i32.eqz (get_local $instring)) + (then + ;; next character is token delimiter + (if (i32.or (i32.eq (get_local $c) (CHAR "(")) + (i32.or (i32.eq (get_local $c) (CHAR ")")) + (i32.or (i32.eq (get_local $c) (CHAR "[")) + (i32.or (i32.eq (get_local $c) (CHAR "]")) + (i32.or (i32.eq (get_local $c) (CHAR "{")) + (i32.or (i32.eq (get_local $c) (CHAR "}")) + (i32.or (i32.eq (get_local $c) (CHAR " ")) + (i32.or (i32.eq (get_local $c) (CHAR ",")) + (i32.eq (get_local $c) (CHAR "\n")))))))))) + (br $done)))) + ;; read next character + ;;; token[token_index++] = str[(*index)++] + (i32.store8_u (i32.add (get_global $token) + (get_local $token_index)) + (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + (set_local $token_index (i32.add (get_local $token_index) + (i32.const 1))) + (set_global $read_index (i32.add (get_global $read_index) + (i32.const 1))) + ;;; if (token[0] == '~' && token[1] == '@') break + (if (i32.and (i32.eq (i32.load8_u (i32.add (get_global $token) + (i32.const 0))) + (CHAR "~")) + (i32.eq (i32.load8_u (i32.add (get_global $token) + (i32.const 1))) + (i32.const 0x40))) + (br $done)) + + ;;; if ((!instring) || escaped) + (if (i32.or (i32.eqz (get_local $instring)) + (get_local $escaped)) + (then + (set_local $escaped (i32.const 0)) + (br $loop))) + (if (i32.eq (get_local $c) (CHAR "\\")) + (set_local $escaped (i32.const 1))) + (if (i32.eq (get_local $c) (CHAR "\"")) + (br $done)) + (br $loop) + ) + ))) + + ;;; token[token_index] = '\0' + (i32.store8_u (i32.add (get_global $token) (get_local $token_index)) + (i32.const 0)) + (get_global $token) + ) + + (func $read_seq (param $str i32) (param $type i32) (param $end i32) + (result i32) + (local $res i32) + (local $val2 i32) + (local $val3 i32) + (local $c i32) + + ;; MAP_LOOP stack + (local $ret i32) + (local $empty i32) + (local $current i32) + + ;; MAP_LOOP_START + (set_local $res (call $MAP_LOOP_START (get_local $type))) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret (get_local $res)) + (set_local $current (get_local $res)) + (set_local $empty (get_local $res)) + + ;; READ_SEQ_LOOP + (block $done + (loop $loop + (call $skip_spaces_comments (get_local $str)) + + ;; peek at next character + ;;; c = str[*index] + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + (if (i32.eq (get_local $c) (CHAR "\x00")) + (then + (call $THROW_STR_0 (STRING "unexpected EOF")) + (br $done))) + (if (i32.eq (get_local $c) (get_local $end)) + (then + ;; read next character + ;;; c = str[(*index)++] + (set_local $c (i32.load8_u (i32.add (get_local $str) + (get_global $read_index)))) + (set_global $read_index (i32.add (get_global $read_index) + (i32.const 1))) + (br $done))) + + ;; value (or key for hash-maps) + (set_local $val2 (call $read_form (get_local $str))) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + (call $RELEASE (get_local $val2)) + (br $done))) + + ;; if this is a hash-map, READ_FORM again + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (set_local $val3 (call $read_form (get_local $str)))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (set_local $res (call $MAP_LOOP_UPDATE (get_local $type) + (get_local $empty) (get_local $current) + (get_local $val2) (get_local $val3))) + (if (i32.le_u (get_local $current) (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret (get_local $res))) + ;; update current to point to new element + (set_local $current (get_local $res)) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + (get_local $ret) + ) + + (func $read_form (param $str i32) (result i32) + ;;(call $STRING (get_global $STRING_T) (get_local $str)) + (local $tok i32) + (local $c0 i32) + (local $c1 i32) + (local $res i32) + + (if (get_global $error_type) (return (i32.const 0))) + + (set_local $tok (call $read_token (get_local $str))) +;; (call $debug (STRING ">>> read_form 1:") (get_local $tok)) + ;;; c0 = token[0] + (set_local $c0 (i32.load8_u (get_local $tok))) + (set_local $c1 (i32.load8_u (i32.add (get_local $tok) (i32.const 1)))) + + (if (i32.eq (get_local $c0) (i32.const 0)) + (then + (return (call $INC_REF (get_global $NIL)))) + (else (if (i32.or + (i32.and + (i32.ge_u (get_local $c0) (CHAR "0")) + (i32.le_u (get_local $c0) (CHAR "9"))) + (i32.and + (i32.eq (get_local $c0) (CHAR "-")) + (i32.and (i32.ge_u (get_local $c1) (CHAR "0")) + (i32.le_u (get_local $c1) (CHAR "9"))))) + (then + (return (call $INTEGER (call $ATOI (get_local $tok))))) + (else (if (i32.eq (get_local $c0) (CHAR ":")) + (then + (i32.store8_u (get_local $tok) (CHAR "\x7f")) + (return (call $STRING (get_global $STRING_T) (get_local $tok)))) + (else (if (i32.eq (get_local $c0) (CHAR "\"")) + (then + ;; TODO: unescape + (i32.store8_u (i32.sub_u + (i32.add (get_local $tok) + (call $STRING_LEN (get_local $tok))) + (i32.const 1)) + (CHAR "\x00")) + (return (call $STRING (get_global $STRING_T) (i32.add (get_local $tok) + (i32.const 1))))) + (else (if (i32.eq (get_local $c0) (CHAR "(")) + (then + (return (call $read_seq (get_local $str) + (get_global $LIST_T) (CHAR ")")))) + (else (if (i32.eq (get_local $c0) (CHAR "[")) + (then + (return (call $read_seq (get_local $str) + (get_global $VECTOR_T) (CHAR "]")))) + (else (if (i32.eq (get_local $c0) (CHAR "{")) + (then + (return (call $read_seq (get_local $str) + (get_global $HASHMAP_T) (CHAR "}")))) + (else (if (i32.or (i32.eq (get_local $c0) (CHAR ")")) + (i32.or (i32.eq (get_local $c0) (CHAR "]")) + (i32.eq (get_local $c0) (CHAR "}")))) + (then + (call $THROW_STR_1 (STRING "unexpected '%c'") (get_local $c0)) + (return (i32.const 0))) + (else + (return (call $STRING (get_global $SYMBOL_T) + (get_local $tok))))))))))))))))))) + ) + + (func $read_str (param $str i32) (result i32) + (set_global $read_index (i32.const 0)) + (call $read_form (get_local $str)) + ) + + (export "read_str" (func $read_str)) + +) diff --git a/wasm/run b/wasm/run new file mode 100755 index 0000000000..f91d7b1593 --- /dev/null +++ b/wasm/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec wace $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" diff --git a/wasm/step0_repl.wast b/wasm/step0_repl.wast new file mode 100644 index 0000000000..652bb560cd --- /dev/null +++ b/wasm/step0_repl.wast @@ -0,0 +1,41 @@ +(module $step0_repl + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + (func $READ (param $str i32) (result i32) + (get_local $str)) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + (get_local $ast)) + + (func $PRINT (param $ast i32) (result i32) + (get_local $ast)) + + (func $rep (param $str i32) (result i32) + (call $PRINT + (call $EVAL + (call $READ (get_local $str)) + (i32.const 0)))) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line (call $readline (STRING "user> "))) + (if (i32.eqz (get_local $line)) (br $repl_done)) + (call $printf_1 (STRING "%s\n") (call $rep (get_local $line))) + (call $free (get_local $line)) + (br $repl_loop))) + + (call $print (STRING "\n")) + (i32.const 0) + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_sprintf_mem)) +) + diff --git a/wasm/step1_read_print.wast b/wasm/step1_read_print.wast new file mode 100644 index 0000000000..51fcb41ac4 --- /dev/null +++ b/wasm/step1_read_print.wast @@ -0,0 +1,81 @@ +(module $step1_read_print + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + (func $READ (param $str i32) (result i32) + (call $read_str (get_local $str))) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + (get_local $ast)) + + (func $PRINT (param $ast i32) (result i32) + (call $pr_str (get_local $ast))) + + (func $rep (param $line i32) (param $env i32) (result i32) + (local $mv1 i32) + (local $mv2 i32) + (local $ms i32) + (block $rep_done + (set_local $mv1 (call $READ (get_local $line))) + (if (get_global $error_type) (br $rep_done)) + + (set_local $mv2 (call $EVAL (get_local $mv1) (get_local $env))) + (if (get_global $error_type) (br $rep_done)) + +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (set_local $ms (call $PRINT (get_local $mv2))) + ) + +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (call $RELEASE (get_local $mv1)) + (get_local $ms) + ) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + (local $res i32) + + ;; DEBUG + (call $printf_1 (STRING "memoryBase: %d\n") (get_global $memoryBase)) + (call $printf_1 (STRING "heap_start: %d\n") (get_global $heap_start)) + (call $printf_1 (STRING "heap_end: %d\n") (get_global $heap_end)) + (call $printf_1 (STRING "mem: %d\n") (get_global $mem)) +;; (call $printf_1 (STRING "string_mem: %d\n") (get_global $string_mem)) + (call $PR_MEMORY (i32.const -1) (i32.const -1)) +;; (call $PR_MEMORY_RAW (get_global $mem) +;; (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) +;; (i32.const 8)))) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line (call $readline (STRING "user> "))) + (if (i32.eqz (get_local $line)) (br $repl_done)) + (if (i32.eq (i32.load8_u (get_local $line)) (i32.const 0)) + (then + (call $free (get_local $line)) + (br $repl_loop))) + (set_local $res (call $rep (get_local $line) (i32.const 0))) + (if (get_global $error_type) + (then + (call $printf_1 (STRING "Error: %s\n") (get_global $error_str)) + (set_global $error_type (i32.const 0))) + (else + (call $printf_1 (STRING "%s\n") (call $to_String (get_local $res))))) + (call $RELEASE (get_local $res)) +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (call $free (get_local $line)) + (br $repl_loop))) + + (call $print (STRING "\n")) + (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (i32.const 0) + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step2_eval.wast b/wasm/step2_eval.wast new file mode 100644 index 0000000000..ac30da431c --- /dev/null +++ b/wasm/step2_eval.wast @@ -0,0 +1,269 @@ +(module $step1_read_print + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + ;; READ + (func $READ (param $str i32) (result i32) + (call $read_str (get_local $str)) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $val2 i32) + (local $val3 i32) + (local $ret i32) + (local $empty i32) + (local $current i32) + (local $type i32) + (local $res2 i64) + (local $found i32) + + (if (get_global $error_type) (return (i32.const 0))) + (set_local $type (call $TYPE (get_local $ast))) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 (get_local $type))) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res2 (call $HASHMAP_GET (get_local $env) (get_local $ast))) + (set_local $res (i32.wrap/i64 (get_local $res2))) + (set_local $found (i32.wrap/i64 (i64.shr_u (get_local $res2) + (i64.const 32)))) + (if (i32.eqz (get_local $found)) + (call $THROW_STR_1 (STRING "'%s' not found") + (call $to_String (get_local $ast)))) + (set_local $res (call $INC_REF (get_local $res))) + + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res (call $MAP_LOOP_START (get_local $type))) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret (get_local $res)) + (set_local $current (get_local $res)) + (set_local $empty (get_local $res)) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq (call $VAL0 (get_local $ast)) (i32.const 0)) + (br $done)) + + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (then + (set_local $res (call $EVAL (call $MEM_VAL2_ptr (get_local $ast)) + (get_local $env)))) + (else + (set_local $res (call $EVAL (call $MEM_VAL1_ptr (get_local $ast)) + (get_local $env))))) + (set_local $val2 (get_local $res)) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + (call $RELEASE (get_local $res)) + (set_local $res (i32.const 0)) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (then + (set_local $val3 (get_local $val2)) + (set_local $val2 (call $MEM_VAL1_ptr (get_local $ast))) + (drop (call $INC_REF (get_local $ast))))) + + ;; MAP_LOOP_UPDATE + (set_local $res (call $MAP_LOOP_UPDATE (get_local $type) + (get_local $empty) (get_local $current) + (get_local $val2) (get_local $val3))) + (if (i32.le_u (get_local $current) (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret (get_local $res))) + ;; update current to point to new element + (set_local $current (get_local $res)) + + (set_local $ast (call $MEM_VAL0_ptr (get_local $ast))) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res (get_local $ret)) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res (call $INC_REF (get_local $ast))) + ) + + (get_local $res) + ) + + (type $fnT (func (param i32) (result i32))) + + (table anyfunc + (elem + $add $subtract $multiply $divide)) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $f_args i32) + (local $f i32) + (local $args i32) + (local $type i32) + (local $ftype i32) + + (set_local $res (i32.const 0)) + (set_local $f_args (i32.const 0)) + (set_local $f (i32.const 0)) + (set_local $args (i32.const 0)) + (set_local $type (call $TYPE (get_local $ast))) + + (if (get_global $error_type) (return (i32.const 0))) + + (if (i32.ne (get_local $type) (get_global $LIST_T)) + (return (call $EVAL_AST (get_local $ast) (get_local $env)))) + + ;; APPLY_LIST + (if (call $EMPTY_Q (get_local $ast)) + (return (call $INC_REF (get_local $ast)))) + + ;; EVAL_INVOKE + (set_local $res (call $EVAL_AST (get_local $ast) (get_local $env))) + (set_local $f_args (get_local $res)) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) (return (get_local $f_args))) + + ;; rest + (set_local $args (call $MEM_VAL0_ptr (get_local $f_args))) + ;; value + (set_local $f (call $MEM_VAL1_ptr (get_local $f_args))) + + (set_local $ftype (call $TYPE (get_local $f))) + (if (i32.eq (get_local $ftype) (get_global $FUNCTION_T)) + (then + (set_local $res (call_indirect (type $fnT) (get_local $args) + (call $VAL0 (get_local $f))))) + (else + (call $THROW_STR_1 (STRING "apply of non-function type: %d\n") + (get_local $type)) + (set_local $res (i32.const 0)))) + + (call $RELEASE (get_local $f_args)) + + (get_local $res) + ) + + (func $PRINT (param $ast i32) (result i32) + (call $pr_str (get_local $ast)) + ) + + ;; REPL + (func $rep (param $line i32) (param $env i32) (result i32) + (local $mv1 i32) + (local $mv2 i32) + (local $ms i32) + (block $rep_done + (set_local $mv1 (call $READ (get_local $line))) + (if (get_global $error_type) (br $rep_done)) + + (set_local $mv2 (call $EVAL (get_local $mv1) (get_local $env))) + (if (get_global $error_type) (br $rep_done)) + +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (set_local $ms (call $PRINT (get_local $mv2))) + ) + + ;; release memory from MAL_READ and EVAL + (call $RELEASE (get_local $mv2)) + (call $RELEASE (get_local $mv1)) + (get_local $ms) + ) + + (func $add (param $args i32) (result i32) + (call $INTEGER + (i32.add (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $subtract (param $args i32) (result i32) + (call $INTEGER + (i32.sub_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $multiply (param $args i32) (result i32) + (call $INTEGER + (i32.mul_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $divide (param $args i32) (result i32) + (call $INTEGER + (i32.div_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + (local $res i32) + (local $repl_env i32) + + ;; DEBUG + (call $printf_1 (STRING "memoryBase: %d\n") (get_global $memoryBase)) + (call $printf_1 (STRING "heap_start: %d\n") (get_global $heap_start)) + (call $printf_1 (STRING "heap_end: %d\n") (get_global $heap_end)) + (call $printf_1 (STRING "mem: %d\n") (get_global $mem)) +;; (call $printf_1 (STRING "string_mem: %d\n") (get_global $string_mem)) + + (set_local $repl_env (call $HASHMAP)) + + (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) + (STRING "+") (call $FUNCTION (i32.const 0)))) + (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) + (STRING "-") (call $FUNCTION (i32.const 1)))) + (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) + (STRING "*") (call $FUNCTION (i32.const 2)))) + (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) + (STRING "/") (call $FUNCTION (i32.const 3)))) + + (call $PR_MEMORY (i32.const -1) (i32.const -1)) +;; (call $PR_MEMORY_RAW (get_global $mem) +;; (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) +;; (i32.const 8)))) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line (call $readline (STRING "user> "))) + (if (i32.eqz (get_local $line)) (br $repl_done)) + (if (i32.eq (i32.load8_u (get_local $line)) (i32.const 0)) + (then + (call $free (get_local $line)) + (br $repl_loop))) + (set_local $res (call $rep (get_local $line) (get_local $repl_env))) + (if (get_global $error_type) + (then + (call $printf_1 (STRING "Error: %s\n") (get_global $error_str)) + (set_global $error_type (i32.const 0))) + (else + (call $printf_1 (STRING "%s\n") (call $to_String (get_local $res))))) + (call $RELEASE (get_local $res)) +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (call $free (get_local $line)) + (br $repl_loop))) + + (call $print (STRING "\n")) + (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (i32.const 0) + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step3_env.wast b/wasm/step3_env.wast new file mode 100644 index 0000000000..21afa31cdf --- /dev/null +++ b/wasm/step3_env.wast @@ -0,0 +1,329 @@ +(module $step1_read_print + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + ;; READ + (func $READ (param $str i32) (result i32) + (call $read_str (get_local $str)) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $val2 i32) + (local $val3 i32) + (local $ret i32) + (local $empty i32) + (local $current i32) + (local $type i32) + (local $found i32) + + (if (get_global $error_type) (return (i32.const 0))) + (set_local $type (call $TYPE (get_local $ast))) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 (get_local $type))) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res (call $ENV_GET (get_local $env) (get_local $ast))) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res (call $MAP_LOOP_START (get_local $type))) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret (get_local $res)) + (set_local $current (get_local $res)) + (set_local $empty (get_local $res)) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq (call $VAL0 (get_local $ast)) (i32.const 0)) + (br $done)) + + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (then + (set_local $res (call $EVAL (call $MEM_VAL2_ptr (get_local $ast)) + (get_local $env)))) + (else + (set_local $res (call $EVAL (call $MEM_VAL1_ptr (get_local $ast)) + (get_local $env))))) + (set_local $val2 (get_local $res)) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + (call $RELEASE (get_local $res)) + (set_local $res (i32.const 0)) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (then + (set_local $val3 (get_local $val2)) + (set_local $val2 (call $MEM_VAL1_ptr (get_local $ast))) + (drop (call $INC_REF (get_local $ast))))) + + ;; MAP_LOOP_UPDATE + (set_local $res (call $MAP_LOOP_UPDATE (get_local $type) + (get_local $empty) (get_local $current) + (get_local $val2) (get_local $val3))) + (if (i32.le_u (get_local $current) (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret (get_local $res))) + ;; update current to point to new element + (set_local $current (get_local $res)) + + (set_local $ast (call $MEM_VAL0_ptr (get_local $ast))) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res (get_local $ret)) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res (call $INC_REF (get_local $ast))) + ) + + (get_local $res) + ) + + (type $fnT (func (param i32) (result i32))) + + (table anyfunc + (elem + $add $subtract $multiply $divide)) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + (call $MEM_VAL1_ptr (call $MEM_VAL0_ptr (get_local $ast)))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + (call $MEM_VAL1_ptr (call $MEM_VAL0_ptr (call $MEM_VAL0_ptr (get_local $ast))))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + (call $MEM_VAL1_ptr (call $MEM_VAL0_ptr (call $MEM_VAL0_ptr (call $MEM_VAL0_ptr (get_local $ast)))))) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $f_args i32) + (local $f i32) + (local $args i32) + (local $type i32) + (local $ftype i32) + (local $a0 i32) + (local $a0sym i32) + (local $a1 i32) + (local $a2 i32) + (local $let_env i32) + + (set_local $res (i32.const 0)) + (set_local $f_args (i32.const 0)) + (set_local $f (i32.const 0)) + (set_local $args (i32.const 0)) + (set_local $type (call $TYPE (get_local $ast))) + + ;;(call $PR_VALUE (STRING ">>> EVAL ast: '%s'\n") (get_local $ast)) + + (if (get_global $error_type) (return (i32.const 0))) + + (if (i32.ne (get_local $type) (get_global $LIST_T)) + (return (call $EVAL_AST (get_local $ast) (get_local $env)))) + + ;; APPLY_LIST + (if (call $EMPTY_Q (get_local $ast)) + (return (call $INC_REF (get_local $ast)))) + + (set_local $a0 (call $MEM_VAL1_ptr (get_local $ast))) + (set_local $a0sym (STRING "")) + (if (i32.eq (call $TYPE (get_local $a0)) (get_global $SYMBOL_T)) + (set_local $a0sym (call $to_String (get_local $a0)))) + + (if (i32.eqz (call $strcmp (STRING "def!") (get_local $a0sym))) + (then + (set_local $a1 (call $MAL_GET_A1 (get_local $ast))) + (set_local $a2 (call $MAL_GET_A2 (get_local $ast))) + (set_local $res (call $EVAL (get_local $a2) (get_local $env))) + (if (get_global $error_type) (return (get_local $res))) + + ;; set a1 in env to a2 + (set_local $res (call $ENV_SET (get_local $env) + (get_local $a1) (get_local $res)))) + (else (if (i32.eqz (call $strcmp (STRING "let*") (get_local $a0sym))) + (then + (set_local $a1 (call $MAL_GET_A1 (get_local $ast))) + (set_local $a2 (call $MAL_GET_A2 (get_local $ast))) + + ;; create new environment with outer as current environment + (set_local $let_env (call $ENV_NEW (get_local $env))) + + (block $done + (loop $loop + (if (i32.eqz (call $VAL0 (get_local $a1))) + (br $done)) + ;; eval current A1 odd element + (set_local $res (call $EVAL (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr + (get_local $a1))) + (get_local $let_env))) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res (call $ENV_SET (get_local $let_env) + (call $MEM_VAL1_ptr (get_local $a1)) + (get_local $res))) + ;; release our use, ENV_SET took ownership + (call $RELEASE (get_local $res)) + + ;; skip to the next pair of a1 elements + (set_local $a1 (call $MEM_VAL0_ptr + (call $MEM_VAL0_ptr (get_local $a1)))) + (br $loop) + ) + ) + (set_local $res (call $EVAL (get_local $a2) (get_local $let_env))) + ;; EVAL_RETURN + (call $RELEASE (get_local $let_env))) + (else + ;; EVAL_INVOKE + (set_local $res (call $EVAL_AST (get_local $ast) (get_local $env))) + (set_local $f_args (get_local $res)) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) (return (get_local $f_args))) + + ;; rest + (set_local $args (call $MEM_VAL0_ptr (get_local $f_args))) + ;; value + (set_local $f (call $MEM_VAL1_ptr (get_local $f_args))) + + (set_local $ftype (call $TYPE (get_local $f))) + (if (i32.eq (get_local $ftype) (get_global $FUNCTION_T)) + (then + (set_local $res (call_indirect (type $fnT) (get_local $args) + (call $VAL0 (get_local $f))))) + (else + (call $THROW_STR_1 (STRING "apply of non-function type: %d\n") + (get_local $type)) + (set_local $res (i32.const 0)))) + + (call $RELEASE (get_local $f_args)))))) + + (get_local $res) + ) + + (func $PRINT (param $ast i32) (result i32) + (call $pr_str (get_local $ast)) + ) + + ;; REPL + (func $rep (param $line i32) (param $env i32) (result i32) + (local $mv1 i32) + (local $mv2 i32) + (local $ms i32) + (block $rep_done + (set_local $mv1 (call $READ (get_local $line))) + (if (get_global $error_type) (br $rep_done)) + + (set_local $mv2 (call $EVAL (get_local $mv1) (get_local $env))) + (if (get_global $error_type) (br $rep_done)) + +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (set_local $ms (call $PRINT (get_local $mv2))) + ) + + ;; release memory from MAL_READ and EVAL + (call $RELEASE (get_local $mv2)) + (call $RELEASE (get_local $mv1)) + (get_local $ms) + ) + + (func $add (param $args i32) (result i32) + (call $INTEGER + (i32.add (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $subtract (param $args i32) (result i32) + (call $INTEGER + (i32.sub_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $multiply (param $args i32) (result i32) + (call $INTEGER + (i32.mul_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $divide (param $args i32) (result i32) + (call $INTEGER + (i32.div_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) + (call $VAL0 (call $MEM_VAL1_ptr + (call $MEM_VAL0_ptr (get_local $args))))))) + (func $pr_memory (param $args i32) (result i32) + (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (call $INC_REF (get_global $NIL))) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + (local $res i32) + (local $repl_env i32) + + ;; DEBUG + (call $printf_1 (STRING "memoryBase: 0x%x\n") (get_global $memoryBase)) + (call $printf_1 (STRING "heap_start: 0x%x\n") (get_global $heap_start)) + (call $printf_1 (STRING "heap_end: 0x%x\n") (get_global $heap_end)) + (call $printf_1 (STRING "mem: 0x%x\n") (get_global $mem)) +;; (call $printf_1 (STRING "string_mem: %d\n") (get_global $string_mem)) + + (set_local $repl_env (call $ENV_NEW (get_global $NIL))) + + (drop (call $ENV_SET_S (get_local $repl_env) + (STRING "+") (call $FUNCTION (i32.const 0)))) + (drop (call $ENV_SET_S (get_local $repl_env) + (STRING "-") (call $FUNCTION (i32.const 1)))) + (drop (call $ENV_SET_S (get_local $repl_env) + (STRING "*") (call $FUNCTION (i32.const 2)))) + (drop (call $ENV_SET_S (get_local $repl_env) + (STRING "/") (call $FUNCTION (i32.const 3)))) + + (call $PR_MEMORY (i32.const -1) (i32.const -1)) +;; (call $PR_MEMORY_RAW (get_global $mem) +;; (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) +;; (i32.const 8)))) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line (call $readline (STRING "user> "))) + (if (i32.eqz (get_local $line)) (br $repl_done)) + (if (i32.eq (i32.load8_u (get_local $line)) (i32.const 0)) + (then + (call $free (get_local $line)) + (br $repl_loop))) + (set_local $res (call $rep (get_local $line) (get_local $repl_env))) + (if (get_global $error_type) + (then + (call $printf_1 (STRING "Error: %s\n") (get_global $error_str)) + (set_global $error_type (i32.const 0))) + (else + (call $printf_1 (STRING "%s\n") (call $to_String (get_local $res))))) + (call $RELEASE (get_local $res)) +;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (call $free (get_local $line)) + (br $repl_loop))) + + (call $print (STRING "\n")) + (call $PR_MEMORY (i32.const -1) (i32.const -1)) + (i32.const 0) + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/types.wast b/wasm/types.wast new file mode 100644 index 0000000000..cd1212c167 --- /dev/null +++ b/wasm/types.wast @@ -0,0 +1,202 @@ +;; Mal value memory layout +;; type words +;; ---------- ---------- +;; nil ref/ 0 | 0 | | +;; false ref/ 1 | 0 | | +;; true ref/ 1 | 1 | | +;; integer ref/ 2 | int | | +;; float ref/ 3 | ??? | | +;; string/kw ref/ 4 | string ptr | | +;; symbol ref/ 5 | string ptr | | +;; list ref/ 6 | next mem idx | val mem idx | +;; vector ref/ 7 | next mem idx | val mem idx | +;; hashmap ref/ 8 | next mem idx | key mem idx | val mem idx +;; function ref/ 9 | fn idx | | +;; mal function ref/10 | body mem idx | param mem idx | env mem idx +;; macro fn ref/11 | body mem idx | param mem idx | env mem idx +;; atom ref/12 | val mem idx | | +;; environment ref/13 | hmap mem idx | outer mem idx | +;; metadata ref/14 | obj mem idx | meta mem idx | +;; FREE sz/15 | next mem idx | | + +(module $types + + (global $NIL_T i32 (i32.const 0)) + (global $BOOLEAN_T i32 (i32.const 1)) + (global $INTEGER_T i32 (i32.const 2)) + (global $FLOAT_T i32 (i32.const 3)) + (global $STRING_T i32 (i32.const 4)) + (global $SYMBOL_T i32 (i32.const 5)) + (global $LIST_T i32 (i32.const 6)) + (global $VECTOR_T i32 (i32.const 7)) + (global $HASHMAP_T i32 (i32.const 8)) + (global $FUNCTION_T i32 (i32.const 9)) + (global $MALFUNC_T i32 (i32.const 10)) + (global $MACRO_T i32 (i32.const 11)) + (global $ATOM_T i32 (i32.const 12)) + (global $ENVIRONMENT_T i32 (i32.const 13)) + (global $METADATA_T i32 (i32.const 14)) + (global $FREE_T i32 (i32.const 15)) + + (global $error_type (mut i32) (i32.const 0)) + (global $error_val (mut i32) (i32.const 0)) + ;; Index into static string memory (static.wast) + (global $error_str (mut i32) (i32.const 0)) + + (global $NIL (mut i32) (i32.const 0)) + (global $FALSE (mut i32) (i32.const 0)) + (global $TRUE (mut i32) (i32.const 0)) + (global $EMPTY_LIST (mut i32) (i32.const 0)) + (global $EMPTY_VECTOR (mut i32) (i32.const 0)) + (global $EMPTY_HASHMAP (mut i32) (i32.const 0)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General functions + + (func $INC_REF (param $mv i32) (result i32) + (i32.store (get_local $mv) + (i32.add (i32.load (get_local $mv)) + (i32.const 32))) + (get_local $mv)) + + (func $THROW_STR_0 (param $fmt i32) + (drop (call $sprintf_1 (get_global $error_str) (get_local $fmt) (STRING ""))) + (set_global $error_type (i32.const 1))) + + (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) + (drop (call $sprintf_1 (get_global $error_str) (get_local $fmt) (get_local $v0))) + (set_global $error_type (i32.const 1))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; numeric functions + + (func $INTEGER (param $val i32) (result i32) + (call $ALLOC_SCALAR (get_global $INTEGER_T) (get_local $val))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; sequence functions + + (func $MAP_LOOP_START (param $type i32) (result i32) + (local $res i32) + (set_local $res (if i32 (i32.eq (get_local $type) + (get_global $LIST_T)) + (get_global $EMPTY_LIST) + (else (if i32 (i32.eq (get_local $type) + (get_global $VECTOR_T)) + (get_global $EMPTY_VECTOR) + (else (if i32 (i32.eq (get_local $type) + (get_global $HASHMAP_T)) + (get_global $EMPTY_HASHMAP) + (else + (call $THROW_STR_1 (STRING "read_seq invalid type %d") + (get_local $type)) + (i32.const 0)))))))) + + (call $INC_REF (get_local $res)) + ) + + (func $MAP_LOOP_UPDATE (param $type i32) (param $empty i32) + (param $current i32) (param $val2 i32) (param $val3 i32) + (result i32) + (local $res i32) + + (set_local $res (call $ALLOC (get_local $type) (get_local $empty) + (get_local $val2) (get_local $val3))) + ;; sequence took ownership + (call $RELEASE (get_local $empty)) + (call $RELEASE (get_local $val2)) + (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) + (call $RELEASE (get_local $val3))) + (if (i32.gt_u (get_local $current) (get_global $EMPTY_HASHMAP)) + ;; if not first element, set current next to point to new element + (i32.store (call $VAL0_ptr (get_local $current)) + (call $MalVal_index (get_local $res)))) + + (get_local $res) + ) + + (func $EMPTY_Q (param $mv i32) (result i32) + (i32.eq (call $VAL0 (get_local $mv)) (i32.const 0)) + ) + + (func $HASHMAP (result i32) + ;; just point to static empty hash-map + (call $INC_REF (get_global $EMPTY_HASHMAP)) + ) + + (func $ASSOC1 (param $hm i32) (param $k i32) (param $v i32) (result i32) + (local $res i32) + (set_local $res (call $ALLOC (get_global $HASHMAP_T) (get_local $hm) + (get_local $k) (get_local $v))) + ;; we took ownership of previous release + (call $RELEASE (get_local $hm)) + (get_local $res) + ) + + (func $ASSOC1_S (param $hm i32) (param $k i32) (param $v i32) (result i32) + (local $kmv i32) + (local $res i32) + (set_local $kmv (call $STRING (get_global $STRING_T) (get_local $k))) + (set_local $res (call $ASSOC1 (get_local $hm) + (get_local $kmv) (get_local $v))) + ;; map took ownership of key + (call $RELEASE (get_local $kmv)) + (get_local $res) + ) + + (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) + (local $res i32) + (local $found i32) + (local $key i32) + (local $test_key_mv i32) + + (set_local $key (call $to_String (get_local $key_mv))) + (set_local $found (i32.const 0)) + + + (block $done + (loop $loop + ;;; if (VAL0(hm) == 0) + (if (i32.eq (call $VAL0 (get_local $hm)) (i32.const 0)) + (then + (set_local $res (get_global $NIL)) + (br $done))) + ;;; test_key_mv = MEM_VAL1(hm) + (set_local $test_key_mv (call $MEM_VAL1_ptr (get_local $hm))) + ;;; if (strcmp(key, to_String(test_key_mv)) == 0) + (if (i32.eq (call $strcmp (get_local $key) + (call $to_String (get_local $test_key_mv))) + (i32.const 0)) + (then + (set_local $found (i32.const 1)) + (set_local $res (call $MEM_VAL2_ptr (get_local $hm))) + (br $done))) + (set_local $hm (call $MEM_VAL0_ptr (get_local $hm))) + + (br $loop) + ) + ) + + ;; combine found/res as hi 32/low 32 of i64 + (i64.or + (i64.shl_u (i64.extend_u/i32 (get_local $found)) + (i64.const 32)) + (i64.extend_u/i32 (get_local $res))) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; function functions + + (func $FUNCTION (param $index i32) (result i32) + (call $ALLOC_SCALAR (get_global $FUNCTION_T) (get_local $index)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; string functions + + (func $to_String (param $mv i32) (result i32) + (i32.add (i32.const 4) ;; skip string refcnt + (call $MalVal_val + (call $MalVal_index (get_local $mv)) + (i32.const 0)))) +) diff --git a/wasm/util.wast b/wasm/util.wast new file mode 100644 index 0000000000..acbe12285a --- /dev/null +++ b/wasm/util.wast @@ -0,0 +1,275 @@ +(module $util + (import "env" "malloc" (func $malloc (param i32) (result i32))) + (import "env" "free" (func $free (param i32))) + (import "env" "exit" (func $exit (param i32))) + + (import "env" "stdout" (global $stdout i32)) + (import "env" "putchar" (func $putchar (param i32) (result i32))) + (import "env" "fputs" (func $fputs (param i32 i32) (result i32))) + ;;(import "env" "readline" (func $readline (param i32) (result i32))) + (import "libedit.so" "readline" (func $readline (param i32) (result i32))) + ;;(import "libreadline.so" "readline" (func $readline (param i32) (result i32))) + + (global $sprintf_buf (mut i32) (i32.const 0)) + + (func $init_sprintf_mem + ;; 256 character sprintf static buffer + (set_global $sprintf_buf (STRING " ")) + ) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Copy len chatacters from src to dst + ;; Returns len + (func $MEM_COPY (param $dst i32) (param $src i32) (param $len i32) + (local $idx i32) + (set_local $idx (i32.const 0)) + (loop $copy + (i32.store8_u (i32.add (get_local $idx) (get_local $dst)) + (i32.load8_u (i32.add (get_local $idx) + (get_local $src)))) + (set_local $idx (i32.add (i32.const 1) (get_local $idx))) + (br_if $copy (i32.lt_u (get_local $idx) (get_local $len))) + ) + ) + + (func $STRING_LEN (param $str i32) (result i32) + (local $cur i32) + (set_local $cur (get_local $str)) + (loop $count + (if (i32.ne (i32.const 0) (i32.load8_u (get_local $cur))) + (then + (set_local $cur (i32.add (get_local $cur) (i32.const 1))) + (br $count))) + ) + (i32.sub_u (get_local $cur) (get_local $str)) + ) + + (func $ATOI (param $str i32) (result i32) + (local $acc i32) + (local $i i32) + (local $neg i32) + (local $ch i32) + (set_local $acc (i32.const 0)) + (set_local $i (i32.const 0)) + (set_local $neg (i32.const 0)) + (block $done + (loop $loop + (set_local $ch (i32.load8_u (i32.add (get_local $str) + (get_local $i)))) + (if (i32.and (i32.ne (get_local $ch) (CHAR '-')) + (i32.or (i32.lt_u (get_local $ch) (CHAR '0')) + (i32.gt_u (get_local $ch) (CHAR '9')))) + (br $done)) + (set_local $i (i32.add (get_local $i) (i32.const 1))) + (if (i32.eq (get_local $ch) (CHAR '-')) + (then + (set_local $neg (i32.const 1))) + (else + (set_local $acc (i32.add (i32.mul_u (get_local $acc) (i32.const 10)) + (i32.sub_u (get_local $ch) (CHAR '0')))))) + (br $loop) + ) + ) + (if i32 (get_local $neg) + (then (i32.sub_s (i32.const 0) (get_local $acc))) + (else (get_local $acc))) + ) + + (func $strcmp (param $s1 i32) (param $s2 i32) (result i32) + (block $done + (loop $loop + (if (i32.or (i32.eqz (i32.load8_u (get_local $s1))) + (i32.eqz (i32.load8_u (get_local $s2)))) + (br $done)) + (if (i32.ne (i32.load8_u (get_local $s1)) + (i32.load8_u (get_local $s2))) + (br $done)) + (set_local $s1 (i32.add (get_local $s1) (i32.const 1))) + (set_local $s2 (i32.add (get_local $s2) (i32.const 1))) + (br $loop) + ) + ) + (if i32 (i32.eq (i32.load8_u (get_local $s1)) + (i32.load8_u (get_local $s2))) + (then (i32.const 0)) + (else + (if i32 (i32.lt_u (i32.load8_u (get_local $s1)) + (i32.load8_u (get_local $s2))) + (then (i32.const -1)) + (else (i32.const 1))))) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $print (param $addr i32) + (drop (call $fputs (get_local $addr) (get_global $stdout)))) + + (func $printf_1 (param $fmt i32) + (param $v0 i32) + (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) + (get_local $v0) (i32.const 0) (i32.const 0) + (i32.const 0) (i32.const 0) (i32.const 0))) + (call $print (get_global $sprintf_buf)) + ) + + (func $printf_2 (param $fmt i32) + (param $v0 i32) (param $v1 i32) + (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) + (get_local $v0) (get_local $v1) (i32.const 0) + (i32.const 0) (i32.const 0) (i32.const 0))) + (call $print (get_global $sprintf_buf)) + ) + + (func $printf_3 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) + (get_local $v0) (get_local $v1) (get_local $v2) + (i32.const 0) (i32.const 0) (i32.const 0))) + (call $print (get_global $sprintf_buf)) + ) + + (func $printf_4 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) + (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) + (get_local $v0) (get_local $v1) (get_local $v2) + (get_local $v3) (i32.const 0) (i32.const 0))) + (call $print (get_global $sprintf_buf)) + ) + + (func $printf_5 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) + (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) + (get_local $v0) (get_local $v1) (get_local $v2) + (get_local $v3) (get_local $v4) (i32.const 0))) + (call $print (get_global $sprintf_buf)) + ) + + (func $printf_6 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) (param $v5 i32) + (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) + (get_local $v0) (get_local $v1) (get_local $v2) + (get_local $v3) (get_local $v4) (get_local $v5))) + (call $print (get_global $sprintf_buf)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) + (local $n i32) + (local $ch i32) + (set_local $n (i32.rem_u (get_local $num) (get_local $base))) + (set_local $ch (if (result i32) (i32.lt_u (get_local $n) (i32.const 10)) + (i32.const 48) + (i32.const 55))) + (i32.store8_u (get_local $str) (i32.add (get_local $n) (get_local $ch))) + ) + + ;; TODO: switch to snprint* (add buffer len) + (func $_sprintnum (param $str i32) (param $num i32) (param $base i32) + (result i32) + (if (i32.and (i32.eq (get_local $base) (i32.const 10)) + (i32.lt_s (get_local $num) (i32.const 0))) + (then + ;; Print '-' if negative + (i32.store8_u (get_local $str) (CHAR '-')) + (set_local $str (i32.add (get_local $str) (i32.const 1))) + ;; Reverse the sign + (set_local $num (i32.sub_s (i32.const 0) (get_local $num))))) + (if (i32.gt_u (i32.div_u (get_local $num) (get_local $base)) + (i32.const 0)) + (set_local + $str + (call $_sprintnum (get_local $str) + (i32.div_u (get_local $num) (get_local $base)) + (get_local $base)))) + (call $_sprintdigit (get_local $str) (get_local $num) (get_local $base)) + (i32.add (i32.const 1) (get_local $str)) + ) + + ;; TODO: switch to snprint* (add buffer len) + (func $sprintf_1 (param $str i32) (param $fmt i32) + (param $v0 i32) (result i32) + (call $sprintf_6 (get_local $str) (get_local $fmt) + (get_local $v0) (i32.const 0) (i32.const 0) + (i32.const 0) (i32.const 0) (i32.const 0)) + ) + + (func $sprintf_6 (param $str i32) (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) (param $v5 i32) + (result i32) + (local $ch i32) + (local $pstr i32) + (local $v i32) + (local $vidx i32) + (local $len i32) + (set_local $pstr (get_local $str)) + (set_local $vidx (i32.const 0)) + + (block $done + (loop $loop + (block $after_v + (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 0 (get_local $vidx))) + (; 0 ;) (set_local $v (get_local $v0)) (br $after_v)) + (; 1 ;) (set_local $v (get_local $v1)) (br $after_v)) + (; 2 ;) (set_local $v (get_local $v2)) (br $after_v)) + (; 3 ;) (set_local $v (get_local $v3)) (br $after_v)) + (; 4 ;) (set_local $v (get_local $v4)) (br $after_v)) + (; 5 ;) (set_local $v (get_local $v5)) (br $after_v) + ) + + ;;; while ((ch=*(fmt++))) + (set_local $ch (i32.load8_u (get_local $fmt))) + (set_local $fmt (i32.add (i32.const 1) (get_local $fmt))) + (if (i32.eqz (get_local $ch)) (br $done)) + ;; TODO: check buffer length + + (if (i32.ne (get_local $ch) (CHAR '%')) + (then + ;; TODO: check buffer length + (i32.store8_u (get_local $pstr) (get_local $ch)) + (set_local $pstr (i32.add (i32.const 1) (get_local $pstr))) + (br $loop))) + + ;;; ch=*(fmt++) + (set_local $ch (i32.load8_u (get_local $fmt))) + (set_local $fmt (i32.add (i32.const 1) (get_local $fmt))) + + (if (i32.eq (CHAR 'd') (get_local $ch)) + (then + (set_local $pstr (call $_sprintnum (get_local $pstr) + (get_local $v) (i32.const 10)))) + (else (if (i32.eq (CHAR 'x') (get_local $ch)) + (then + (set_local $pstr (call $_sprintnum (get_local $pstr) + (get_local $v) (i32.const 16)))) + (else (if (i32.eq (CHAR 's') (get_local $ch)) + (then + (set_local $len (call $STRING_LEN (get_local $v))) + (call $MEM_COPY (get_local $pstr) (get_local $v) (get_local $len)) + (set_local $pstr (i32.add (get_local $pstr) (get_local $len)))) + (else (if (i32.eq (CHAR 'c') (get_local $ch)) + (then + (i32.store8_u (get_local $pstr) (get_local $v)) + (set_local $pstr (i32.add (get_local $pstr) (i32.const 1)))) + (else + (call $print (STRING "Illegal format character: ")) + (drop (call $putchar (get_local $ch))) + (drop (call $putchar (CHAR '\n'))) + (call $exit (i32.const 3)))))))))) + + (set_local $vidx (i32.add (i32.const 1) (get_local $vidx))) + (br $loop) + ) + ) + + (i32.store8_u (get_local $pstr) (CHAR '\x00')) + (get_local $pstr) + ) + +) + diff --git a/wasm/wastpp.py b/wasm/wastpp.py new file mode 100755 index 0000000000..22266dfcf9 --- /dev/null +++ b/wasm/wastpp.py @@ -0,0 +1,123 @@ +#!/usr/bin/env python3 + +from itertools import tee +from ast import literal_eval +import os +import pprint +import re +import sys + +def pairwise(iterable): + "s -> (s0,s1), (s1,s2), (s2, s3), ..." + a, b = tee(iterable) + next(b, None) + return zip(a, b) + +def _escape(s): + return s.replace('\\', '\\\\').replace('"', '\\"').replace('\n', '\\n') + + +tokre = re.compile(r"""([\s][\s]*|[(];|;[)]|[\[\]{}()`~^@]|'(?:[\\].|[^\\'])*'?|"(?:[\\].|[^\\"])*"?|;;.*|[^\s\[\]{}()'"`@,;]+)""") + +file_tokens = [] +strings = [] +string_map = {} + +depth = 0 +module = None +type = None + +for f in sys.argv[1:]: + content = open(f).read() + tokens = [t for t in re.findall(tokre, content)] + #print(tokens[0:100], file=sys.stderr) + pairs = ["".join(p) for p in pairwise(tokens)] + pairs.append("") + + index = 0 + while index < len(tokens): + token = tokens[index] + pair = pairs[index] + if pair in ["(STRING", "(CHAR"]: + arg = tokens[index+3] + #print("arg: %s" % arg, file=sys.stderr) + if tokens[index+4] != ')': + raise Exception("Invalid %s) macro, too many/few args" % pair) + if arg.startswith('"') and arg.endswith('"'): + pass + elif arg.startswith("'") and arg.endswith("'"): + pass + else: + raise Exception ("Invalid %s) macro, invalid string arg" % pair) + if pair == "(STRING": + str = literal_eval(arg) + if str in string_map: + # Duplicate string, re-use address + file_tokens.append("(i32.add (get_global $memoryBase) (get_global %s))" % string_map[str]) + else: + str_name = "$S_STRING_%d" % len(strings) + file_tokens.append("(i32.add (get_global $memoryBase) (get_global %s))" % str_name) + strings.append(str) + string_map[str] = str_name + if pair == "(CHAR": + c = literal_eval(arg) + if len(c) != 1: + raise Exception ("Invalid (CHAR) macro, must be 1 character") + file_tokens.append("(i32.const 0x%x (; %s ;))" % (ord(c), arg)) + # Skip the rest of the macro + index += 5 + continue + index += 1 + if token == '(': + depth += 1 + if token == ')': + depth -= 1 + if depth == 0: + module = None + if token == ')': continue + if depth == 1: + type = None + if pair == '(module': + index += 1 + continue + if token.startswith('$'): + module = token[1:] + #print("module:", module, file=sys.stderr) + file_tokens.append('\n ;;\n ;; module "%s"\n ;;\n' % module) + continue + if depth == 2: + if token == '(': + type = tokens[index] + if type == 'data': + raise Exception("User data section not supported") + #print(" type:", type, file=sys.stderr) + file_tokens.append(token) + +# TODO: remove duplicates +# Create data section with static strings +string_tokens = [] +if strings: + string_tokens.append(" (data\n (get_global $memoryBase)\n") + string_offset = 0 + for string in strings: + string_tokens.append(' %-30s ;; %d\n' % ( + '"'+_escape(string)+'\\00"', string_offset)) + string_offset += len(string)+1 + string_tokens.append(" )\n\n") + + # Create string names/pointers + string_offset = 0 + for index, string in enumerate(strings): + string_tokens.append(' (global $S_STRING_%d i32 (i32.const %d))\n' % ( + index, string_offset)) + string_offset += len(string)+1 + # Terminator so we know how much memory we took + string_tokens.append(' (global $S_STRING_END i32 (i32.const %d))\n' % ( + string_offset)) + +all_tokens = ["(module\n"] +all_tokens.extend(string_tokens) +all_tokens.extend(file_tokens) +all_tokens.append("\n)") + +print("".join(all_tokens)) From 33309c6a6246ea0d5699b4eb0d90a2fd0c67ec8a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 13 Oct 2018 23:10:28 -0500 Subject: [PATCH 0403/1998] wasm: Convert to wam syntax using wamp. - Convert sources to much more concise wam syntax supported by wamp. - Rename sources from *.wast to *.wam and generate *.wast files by translating via wamp. --- .gitignore | 2 +- wasm/Makefile | 20 +- wasm/debug.wam | 186 +++++++++ wasm/debug.wast | 194 ---------- wasm/env.wam | 79 ++++ wasm/env.wast | 90 ----- wasm/mem.wam | 401 ++++++++++++++++++++ wasm/mem.wast | 461 ----------------------- wasm/printer.wam | 139 +++++++ wasm/printer.wast | 148 -------- wasm/reader.wam | 287 ++++++++++++++ wasm/reader.wast | 321 ---------------- wasm/{step0_repl.wast => step0_repl.wam} | 32 +- wasm/step1_read_print.wam | 88 +++++ wasm/step1_read_print.wast | 81 ---- wasm/step2_eval.wam | 255 +++++++++++++ wasm/step2_eval.wast | 269 ------------- wasm/step3_env.wam | 308 +++++++++++++++ wasm/step3_env.wast | 329 ---------------- wasm/types.wam | 186 +++++++++ wasm/types.wast | 202 ---------- wasm/util.wam | 254 +++++++++++++ wasm/util.wast | 275 -------------- wasm/wastpp.py | 123 ------ 24 files changed, 2212 insertions(+), 2518 deletions(-) create mode 100644 wasm/debug.wam delete mode 100644 wasm/debug.wast create mode 100644 wasm/env.wam delete mode 100644 wasm/env.wast create mode 100644 wasm/mem.wam delete mode 100644 wasm/mem.wast create mode 100644 wasm/printer.wam delete mode 100644 wasm/printer.wast create mode 100644 wasm/reader.wam delete mode 100644 wasm/reader.wast rename wasm/{step0_repl.wast => step0_repl.wam} (52%) create mode 100644 wasm/step1_read_print.wam delete mode 100644 wasm/step1_read_print.wast create mode 100644 wasm/step2_eval.wam delete mode 100644 wasm/step2_eval.wast create mode 100644 wasm/step3_env.wam delete mode 100644 wasm/step3_env.wast create mode 100644 wasm/types.wam delete mode 100644 wasm/types.wast create mode 100644 wasm/util.wam delete mode 100644 wasm/util.wast delete mode 100755 wasm/wastpp.py diff --git a/.gitignore b/.gitignore index d5c41ff45f..aa4aa493c8 100644 --- a/.gitignore +++ b/.gitignore @@ -144,5 +144,5 @@ elm/elm-stuff elm/*.js !elm/node_readline.js !elm/bootstrap.js -wasm/*.wat +wasm/*.wast wasm/*.wasm diff --git a/wasm/Makefile b/wasm/Makefile index 46650e42fb..aeac222726 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,7 +1,7 @@ -STEP0_DEPS = util.wast -STEP1_DEPS = $(STEP0_DEPS) types.wast mem.wast debug.wast reader.wast printer.wast +STEP0_DEPS = util.wam +STEP1_DEPS = $(STEP0_DEPS) types.wam mem.wam debug.wam reader.wam printer.wam STEP2_DEPS = $(STEP1_DEPS) -STEP3_DEPS = $(STEP2_DEPS) env.wast +STEP3_DEPS = $(STEP2_DEPS) env.wam STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ @@ -10,15 +10,15 @@ STEPS = step0_repl step1_read_print step2_eval step3_env \ all: $(foreach s,$(STEPS),$(s).wasm) %.wasm: - ./wastpp.py $^ > $*.wat - wasm-as $*.wat -o $@ + wamp $^ > $*.wast + wasm-as $*.wast -o $@ -step0_repl.wasm: $(STEP0_DEPS) step0_repl.wast -step1_read_print.wasm: $(STEP1_DEPS) step1_read_print.wast -step2_eval.wasm: $(STEP2_DEPS) step2_eval.wast -step3_env.wasm: $(STEP3_DEPS) step3_env.wast +step0_repl.wasm: $(STEP0_DEPS) step0_repl.wam +step1_read_print.wasm: $(STEP1_DEPS) step1_read_print.wam +step2_eval.wasm: $(STEP2_DEPS) step2_eval.wam +step3_env.wasm: $(STEP3_DEPS) step3_env.wam .PHONY: clean clean: - rm -f *.wat *.wasm + rm -f *.wast *.wasm diff --git a/wasm/debug.wam b/wasm/debug.wam new file mode 100644 index 0000000000..7eb0795461 --- /dev/null +++ b/wasm/debug.wam @@ -0,0 +1,186 @@ +(module $debug + + (func $PR_VALUE (param $fmt i32) (param $mv i32) + (local $temp i32) + (set_local $temp ($pr_str $mv)) + ($printf_1 $fmt ($to_String $temp)) + ($RELEASE $temp) + ) + + (func $PR_MEMORY_VALUE (param $idx i32) (result i32) + (local $mv i32) + (local $type i32) + (local $size i32) + (local $val0 i32) + ;;; mv = mem + idx + (set_local $mv ($MalVal_ptr $idx)) + (set_local $type ($TYPE $mv)) + (set_local $size ($MalVal_size $mv)) + (set_local $val0 ($MalVal_val $idx 0)) + + ;;; printf(" %3d: type: %2d", idx, type) + ($printf_2 " 0x%x: type: %d" $idx $type) + + (if (i32.eq $type 15) + (then + ;;; printf(", size: %2d", size) + ($printf_1 ", size: %d" $size)) + (else + ;;; printf(", refs: %2d", (mv->refcnt_type - type)>>5) + ($printf_1 ", refs: %d" ($REFS $mv)))) + + ;;; printf(", [ %3d | %3d", mv->refcnt_type, val0) + ($printf_2 ", [ 0x%x | 0x%x" ($MalVal_refcnt_type $idx) $val0) + + (if (i32.eq $size 2) + (then + ($print " | --- | --- ]")) + (else + ;;; printf(" | %3d", mv->val[1]) + ($printf_1 " | 0x%x" ($MalVal_val $idx 1)) + (if (i32.eq $size 3) + (then + ($print " | --- ]")) + (else + ;;; printf(" | %3d ]", mv->val[2]) + ($printf_1 " | 0x%x ]" ($MalVal_val $idx 2)))))) + + ;;; printf(" >> ") + ($print " >> ") + + (block $done (block $unknown + (block (block (block (block (block (block (block (block + (block (block (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + $unknown $type)) + ;; 0: nil + ($print "nil") + (br $done)) + ;; 1: boolean + (if (i32.eq $val0 0) + ;; true + ($print "false") + ;; false + ($print "true")) + (br $done)) + ;; 2: integer + ($printf_1 "%d" $val0) + (br $done)) + ;; 3: float/ERROR + ($print " *** GOT FLOAT *** ") + (br $done)) + ;; 4: string/kw + ($printf_1 "'%s'" ($to_String $mv)) + (br $done)) + ;; 5: symbol + ($print ($to_String $mv)) + (br $done)) + ;; 6: list + (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (then + ($print "()")) + (else + ;;; printf("(... %d ...), next: %d\n", mv->val[1], mv->val[0]) + ($printf_2 "(... 0x%x ...), next: 0x%x" + ($MalVal_val $idx 1) + ($MalVal_val $idx 0)))) + (br $done)) + ;; 7: vector + (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (then + ($print "[]")) + (else + ;;; printf("[... %d ...], next: %d\n", mv->val[1], mv->val[0])val + ($printf_2 "[... %d ...], next: %d" + ($MalVal_val $idx 1) + ($MalVal_val $idx 0)))) + (br $done)) + ;; 8: hashmap + (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (then + ($print "{}")) + (else + ;;; printf("{... '%s'(%d) : %d ...}\n", + ;; to_String(mem + mv->val[1]), mv->val[1], mv->val[2]) + ($printf_3 "{... '%s'(%d) : %d ...}" + ($to_String ($MalVal_ptr ($MalVal_val $idx 1))) + ($MalVal_val $idx 1) + ($MalVal_val $idx 2)))) + (br $done)) + ;; 9: function + ($print "function") + (br $done)) + ;; 10: mal function + ($print "mal function") + (br $done)) + ;; 11: macro fn + ($print "macro fn") + (br $done)) + ;; 12: atom + ($print "atom") + (br $done)) + ;; 13: environment + ($print "environment") + (br $done)) + ;; 14: metadata + ($print "metadata") + (br $done)) + ;; 15: FREE + ($printf_1 "FREE next: 0x%x" $val0) + (if (i32.eq $idx (get_global $mem_free_list)) + ($print " (free start)")) + (if (i32.eq $val0 (get_global $mem_unused_start)) + ($print " (free end)")) + (br $done)) + ;; 16: unknown + ($print "unknown") + ) + + (drop ($putchar 0xA)) + + (i32.add $size $idx) + ) + + (func $PR_MEMORY (param $start i32) (param $end i32) + (local $idx i32) + (if (i32.lt_s $start 0) + (set_local $start (get_global $mem_user_start))) + (if (i32.lt_s $end 0) + (set_local $end (get_global $mem_unused_start))) + ;;; printf("Values - (mem) showing %d -> %d", start, end) + ;;; printf(" (unused start: %d, free list: %d):\n", + ;;; mem_unused_start, mem_free_list) + ($printf_4 "Values - (mem) showing 0x%x -> 0x%x (unused start: 0x%x, free list: 0x%x):\n" + $start + $end + (get_global $mem_unused_start) + (get_global $mem_free_list)) + + (if (i32.le_s $end $start) + (then + ($print " ---\n") + (set_local $end (get_global $mem_unused_start))) + (else + (set_local $idx $start) + ;;; while (idx < end) + (block $loopvals_exit + (loop $loopvals + (if (i32.ge_s $idx $end) + (br $loopvals_exit)) + (set_local $idx ($PR_MEMORY_VALUE $idx)) + (br $loopvals) + ) + ))) + ) + + (func $PR_MEMORY_RAW (param $start i32) (param $end i32) + (block $loop_exit + (loop $loop + (if (i32.ge_u $start $end) (br $loop_exit)) + ($printf_2 "0x%x 0x%x\n" $start (i32.load $start)) + (set_local $start (i32.add 4 $start)) + (br $loop) + ) + ) + ) +) diff --git a/wasm/debug.wast b/wasm/debug.wast deleted file mode 100644 index 18e5fa1c35..0000000000 --- a/wasm/debug.wast +++ /dev/null @@ -1,194 +0,0 @@ -(module $debug - - (func $PR_VALUE (param $fmt i32) (param $mv i32) - (local $temp i32) - (set_local $temp (call $pr_str (get_local $mv))) - (call $printf_1 (get_local $fmt) (call $to_String (get_local $temp))) - (call $RELEASE (get_local $temp)) - ) - - (func $PR_MEMORY_VALUE (param $idx i32) (result i32) - (local $mv i32) - (local $type i32) - (local $size i32) - (local $val0 i32) - ;;; mv = mem + idx - (set_local $mv (call $MalVal_ptr (get_local $idx))) - (set_local $type (call $TYPE (get_local $mv))) - (set_local $size (call $MalVal_size (get_local $mv))) - (set_local $val0 (call $MalVal_val (get_local $idx) (i32.const 0))) - - ;;; printf(" %3d: type: %2d", idx, type) - (call $printf_2 (STRING " 0x%x: type: %d") - (get_local $idx) (get_local $type)) - - (if (i32.eq (get_local $type) (i32.const 15)) - (then - ;;; printf(", size: %2d", size) - (call $printf_1 (STRING ", size: %d") (get_local $size))) - (else - ;;; printf(", refs: %2d", (mv->refcnt_type - type)>>5) - (call $printf_1 (STRING ", refs: %d") (call $REFS (get_local $mv))))) - - ;;; printf(", [ %3d | %3d", mv->refcnt_type, val0) - (call $printf_2 (STRING ", [ 0x%x | 0x%x") - (call $MalVal_refcnt_type (get_local $idx)) - (get_local $val0)) - - (if (i32.eq (get_local $size) (i32.const 2)) - (then - (call $print (STRING " | --- | --- ]"))) - (else - ;;; printf(" | %3d", mv->val[1]) - (call $printf_1 (STRING " | 0x%x") - (call $MalVal_val (get_local $idx) (i32.const 1))) - (if (i32.eq (get_local $size) (i32.const 3)) - (then - (call $print (STRING " | --- ]"))) - (else - ;;; printf(" | %3d ]", mv->val[2]) - (call $printf_1 (STRING " | 0x%x ]") - (call $MalVal_val (get_local $idx) (i32.const 2))))))) - - ;;; printf(" >> ") - (call $print (STRING " >> ")) - - (block $done (block $unknown - (block (block (block (block (block (block (block (block - (block (block (block (block (block (block (block (block - (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 $unknown (get_local $type))) - ;; 0: nil - (call $print (STRING "nil")) - (br $done)) - ;; 1: boolean - (if (i32.eq (get_local $val0) (i32.const 0)) - ;; true - (call $print (STRING "false")) - ;; false - (call $print (STRING "true"))) - (br $done)) - ;; 2: integer - (call $printf_1 (STRING "%d") (get_local $val0)) - (br $done)) - ;; 3: float/ERROR - (call $print (STRING " *** GOT FLOAT *** ")) - (br $done)) - ;; 4: string/kw - (call $printf_1 (STRING "'%s'") (call $to_String (get_local $mv))) - (br $done)) - ;; 5: symbol - (call $print (call $to_String (get_local $mv))) - (br $done)) - ;; 6: list - (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) - (then - (call $print (STRING "()"))) - (else - ;;; printf("(... %d ...), next: %d\n", mv->val[1], mv->val[0]) - (call $printf_2 (STRING "(... 0x%x ...), next: 0x%x") - (call $MalVal_val (get_local $idx) (i32.const 1)) - (call $MalVal_val (get_local $idx) (i32.const 0))))) - (br $done)) - ;; 7: vector - (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) - (then - (call $print (STRING "[]"))) - (else - ;;; printf("[... %d ...], next: %d\n", mv->val[1], mv->val[0])val - (call $printf_2 (STRING "[... %d ...], next: %d") - (call $MalVal_val (get_local $idx) (i32.const 1)) - (call $MalVal_val (get_local $idx) (i32.const 0))))) - (br $done)) - ;; 8: hashmap - (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) - (then - (call $print (STRING "{}"))) - (else - ;;; printf("{... '%s'(%d) : %d ...}\n", - ;; to_String(mem + mv->val[1]), mv->val[1], mv->val[2]) - (call $printf_3 (STRING "{... '%s'(%d) : %d ...}") - (call $to_String - (call $MalVal_ptr - (call $MalVal_val (get_local $idx) (i32.const 1)))) - (call $MalVal_val (get_local $idx) (i32.const 1)) - (call $MalVal_val (get_local $idx) (i32.const 2))))) - (br $done)) - ;; 9: function - (call $print (STRING "function")) - (br $done)) - ;; 10: mal function - (call $print (STRING "mal function")) - (br $done)) - ;; 11: macro fn - (call $print (STRING "macro fn")) - (br $done)) - ;; 12: atom - (call $print (STRING "atom")) - (br $done)) - ;; 13: environment - (call $print (STRING "environment")) - (br $done)) - ;; 14: metadata - (call $print (STRING "metadata")) - (br $done)) - ;; 15: FREE - (call $printf_1 (STRING "FREE next: 0x%x") (get_local $val0)) - (if (i32.eq (get_local $idx) (get_global $mem_free_list)) - (call $print (STRING " (free start)"))) - (if (i32.eq (get_local $val0) (get_global $mem_unused_start)) - (call $print (STRING " (free end)"))) - (br $done)) - ;; 16: unknown - (call $print (STRING "unknown")) - ) - - (drop (call $putchar (i32.const 0xA))) - - (i32.add (get_local $size) (get_local $idx)) - ) - - (func $PR_MEMORY (param $start i32) (param $end i32) - (local $idx i32) - (if (i32.lt_s (get_local $start) (i32.const 0)) - (set_local $start (get_global $mem_user_start))) - (if (i32.lt_s (get_local $end) (i32.const 0)) - (set_local $end (get_global $mem_unused_start))) - ;;; printf("Values - (mem) showing %d -> %d", start, end) - ;;; printf(" (unused start: %d, free list: %d):\n", - ;;; mem_unused_start, mem_free_list) - (call $printf_4 (STRING "Values - (mem) showing 0x%x -> 0x%x (unused start: 0x%x, free list: 0x%x):\n") - (get_local $start) - (get_local $end) - (get_global $mem_unused_start) - (get_global $mem_free_list)) - - (if (i32.le_s (get_local $end) (get_local $start)) - (then - (call $print (STRING " ---\n")) - (set_local $end (get_global $mem_unused_start))) - (else - (set_local $idx (get_local $start)) - ;;; while (idx < end) - (block $loopvals_exit - (loop $loopvals - (if (i32.ge_s (get_local $idx) (get_local $end)) - (br $loopvals_exit)) - (set_local $idx (call $PR_MEMORY_VALUE (get_local $idx))) - (br $loopvals) - ) - ))) - ) - - (func $PR_MEMORY_RAW (param $start i32) (param $end i32) - (block $loop_exit - (loop $loop - (if (i32.ge_u (get_local $start) (get_local $end)) - (br $loop_exit)) - (call $printf_2 (STRING "0x%x 0x%x\n") - (get_local $start) (i32.load (get_local $start))) - (set_local $start (i32.add (i32.const 4) (get_local $start))) - (br $loop) - ) - ) - ) -) diff --git a/wasm/env.wam b/wasm/env.wam new file mode 100644 index 0000000000..88945ff34a --- /dev/null +++ b/wasm/env.wam @@ -0,0 +1,79 @@ +(module $env + + (func $ENV_NEW (param $outer i32) (result i32) + (local $data i32) + (local $env i32) + + ;; allocate the data hashmap + (set_local $data ($HASHMAP)) + + (set_local $env ($ALLOC (get_global $ENVIRONMENT_T) $data $outer 0)) + ;; environment takes ownership + ($RELEASE $data) + $env + ) + + (func $ENV_SET (param $env i32) (param $key i32) (param $value i32) + (result i32) + (local $data i32) + (set_local $data ($MEM_VAL0_ptr $env)) + (i32.store ($VAL0_ptr $env) ($MalVal_index ($ASSOC1 $data $key $value))) + $value + ) + + (func $ENV_SET_S (param $env i32) (param $key i32) (param $value i32) + (result i32) + (local $data i32) + (set_local $data ($MEM_VAL0_ptr $env)) + (i32.store ($VAL0_ptr $env) ($MalVal_index ($ASSOC1_S $data $key $value))) + $value + ) + + (func $ENV_FIND (param $env i32) (param $key i32) (result i64) + (local $res i32) + (local $data i32) + (local $found_res i64) + + (set_local $res 0) + + (block $done + (loop $loop + (set_local $data ($MEM_VAL0_ptr $env)) + (set_local $found_res ($HASHMAP_GET $data + $key)) + ;;; if (found) + (if (i32.wrap/i64 (i64.shr_u $found_res (i64.const 32))) + (then + (set_local $res (i32.wrap/i64 $found_res)) + (br $done))) + (set_local $env ($MEM_VAL1_ptr $env)) + (if (i32.eq $env (get_global $NIL)) + (then + (set_local $env 0) + (br $done))) + (br $loop) + ) + ) + + ;; combine res/env as hi 32/low 32 of i64 + (i64.or + (i64.shl_u (i64.extend_u/i32 $res) (i64.const 32)) + (i64.extend_u/i32 $env)) + ) + + (func $ENV_GET (param $env i32) (param $key i32) (result i32) + (local $res i32) + (local $res_env i64) + (set_local $res 0) + + (set_local $res_env ($ENV_FIND $env $key)) + (set_local $env (i32.wrap/i64 $res_env)) + (set_local $res (i32.wrap/i64 (i64.shr_u $res_env (i64.const 32)))) + + (if (i32.eqz $env) + (then + ($THROW_STR_1 "'%s' not found" ($to_String $key)) + (return $res))) + (return ($INC_REF $res)) + ) +) diff --git a/wasm/env.wast b/wasm/env.wast deleted file mode 100644 index 9e36586062..0000000000 --- a/wasm/env.wast +++ /dev/null @@ -1,90 +0,0 @@ -(module $env - - (func $ENV_NEW (param $outer i32) (result i32) - (local $data i32) - (local $env i32) - - ;; allocate the data hashmap - (set_local $data (call $HASHMAP)) - - (set_local $env (call $ALLOC (get_global $ENVIRONMENT_T) - (get_local $data) (get_local $outer) (i32.const 0))) - ;; environment takes ownership - (call $RELEASE (get_local $data)) - (get_local $env) - ) - - (func $ENV_SET (param $env i32) (param $key i32) (param $value i32) - (result i32) - (local $data i32) - (set_local $data (call $MEM_VAL0_ptr (get_local $env))) - (i32.store (call $VAL0_ptr (get_local $env)) - (call $MalVal_index - (call $ASSOC1 (get_local $data) - (get_local $key) (get_local $value)))) - (get_local $value) - ) - - (func $ENV_SET_S (param $env i32) (param $key i32) (param $value i32) - (result i32) - (local $data i32) - (set_local $data (call $MEM_VAL0_ptr (get_local $env))) - (i32.store (call $VAL0_ptr (get_local $env)) - (call $MalVal_index - (call $ASSOC1_S (get_local $data) - (get_local $key) (get_local $value)))) - (get_local $value) - ) - - (func $ENV_FIND (param $env i32) (param $key i32) (result i64) - (local $res i32) - (local $data i32) - (local $found_res i64) - - (set_local $res (i32.const 0)) - - (block $done - (loop $loop - (set_local $data (call $MEM_VAL0_ptr (get_local $env))) - (set_local $found_res (call $HASHMAP_GET (get_local $data) - (get_local $key))) - ;;; if (found) - (if (i32.wrap/i64 (i64.shr_u (get_local $found_res) - (i64.const 32))) - (then - (set_local $res (i32.wrap/i64 (get_local $found_res))) - (br $done))) - (set_local $env (call $MEM_VAL1_ptr (get_local $env))) - (if (i32.eq (get_local $env) (get_global $NIL)) - (then - (set_local $env (i32.const 0)) - (br $done))) - (br $loop) - ) - ) - - ;; combine res/env as hi 32/low 32 of i64 - (i64.or - (i64.shl_u (i64.extend_u/i32 (get_local $res)) - (i64.const 32)) - (i64.extend_u/i32 (get_local $env))) - ) - - (func $ENV_GET (param $env i32) (param $key i32) (result i32) - (local $res i32) - (local $res_env i64) - (set_local $res (i32.const 0)) - - (set_local $res_env (call $ENV_FIND (get_local $env) (get_local $key))) - (set_local $env (i32.wrap/i64 (get_local $res_env))) - (set_local $res (i32.wrap/i64 (i64.shr_u (get_local $res_env) - (i64.const 32)))) - - (if (i32.eqz (get_local $env)) - (then - (call $THROW_STR_1 (STRING "'%s' not found") - (call $to_String (get_local $key))) - (return (get_local $res)))) - (return (call $INC_REF (get_local $res))) - ) -) diff --git a/wasm/mem.wam b/wasm/mem.wam new file mode 100644 index 0000000000..1134ae1ccc --- /dev/null +++ b/wasm/mem.wam @@ -0,0 +1,401 @@ +(module $mem + (global $MEM_SIZE i32 1048576) + (global $STRING_MEM_SIZE i32 1048576) + + (global $heap_start (mut i32) 0) + (global $heap_end (mut i32) 0) + + (global $mem (mut i32) 0) + (global $mem_unused_start (mut i32) 0) + (global $mem_free_list (mut i32) 0) + (global $mem_user_start (mut i32) 0) + +;; (global $string_mem (mut i32) 0) +;; (global $string_mem_next (mut i32) 0) +;; (global $string_mem_user_start (mut i32) 0) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General type storage/pointer functions + + (func $VAL0_ptr (param $mv i32) (result i32) + (i32.add $mv 4)) + (func $VAL1_ptr (param $mv i32) (result i32) + (i32.add $mv 8)) + + (func $VAL0 (param $mv i32) (result i32) + (i32.load (i32.add $mv 4))) + (func $VAL1 (param $mv i32) (result i32) + (i32.load (i32.add $mv 8))) + + + (func $MEM_VAL0_ptr (param $mv i32) (result i32) + (i32.add (get_global $mem) + (i32.mul_u (i32.load (i32.add $mv 4)) 8))) + (func $MEM_VAL1_ptr (param $mv i32) (result i32) + (i32.add (get_global $mem) + (i32.mul_u (i32.load (i32.add $mv 8)) 8))) + (func $MEM_VAL2_ptr (param $mv i32) (result i32) + (i32.add (get_global $mem) + (i32.mul_u (i32.load (i32.add $mv 12)) 8))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Returns the address of 'mem[mv_idx]' + (func $MalVal_ptr (param $mv_idx i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + ;;; mem[mv_idx].refcnt_type + (i32.add (get_global $mem) (i32.mul_u $mv_idx 8))) + + ;; Returns the memory index mem of mv + ;; Will usually be used with a load or store by the caller + (func $MalVal_index (param $mv i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + (i32.div_u (i32.sub_u $mv (get_global $mem)) 8)) + + ;; Returns the address of 'mem[mv_idx].refcnt_type' + (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) + (i32.load ($MalVal_ptr $mv_idx))) + + (func $TYPE (param $mv i32) (result i32) + ;;; type = mv->refcnt_type & 31 + (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 + + (func $REFS (param $mv i32) (result i32) + ;;; type = mv->refcnt_type & 31 + (i32.shr_u (i32.load $mv) 5)) ;; / 32 + + ;; Returns the address of 'mem[mv_idx].val[val]' + ;; Will usually be used with a load or store by the caller + (func $MalVal_val_ptr (param $mv_idx i32) (param $val i32) (result i32) + (i32.add (i32.add ($MalVal_ptr $mv_idx) 4) + (i32.mul_u $val 4))) + + ;; Returns the value of 'mem[mv_idx].val[val]' + (func $MalVal_val (param $mv_idx i32) (param $val i32) (result i32) + (i32.load ($MalVal_val_ptr $mv_idx $val))) + + (func $MalType_size (param $type i32) (result i32) + ;;; if (type <= 5 || type == 9 || type == 12) + (if i32 (i32.or (i32.le_u $type 5) + (i32.or (i32.eq $type 9) + (i32.eq $type 12))) + (then 2) + (else + ;;; else if (type == 8 || type == 10 || type == 11) + (if i32 (i32.or (i32.eq $type 8) + (i32.or (i32.eq $type 10) + (i32.eq $type 11))) + (then 4) + (else 3))))) + + (func $MalVal_size (param $mv i32) (result i32) + (local $type i32) + (set_local $type ($TYPE $mv)) + ;; if (type == FREE_T) + (if i32 (i32.eq $type (get_global $FREE_T)) + (then + ;;; return (mv->refcnt_type & 0xffe0)>>5 + (i32.shr_u (i32.and (i32.load $mv) 0xffe0) 5)) ;;; / 32 + (else + ;;; return MalType_size(type) + ($MalType_size $type)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; init_memory + + (func $init_memory + (local $heap_size i32) + +;; ($print ">>> init_memory\n") + + ($init_sprintf_mem) + + ;; 100 character error_str static buffer + (set_global $error_str " ") + ;; 256 character token static buffer + (set_global $token " ") + + (set_local $heap_size (i32.add (get_global $MEM_SIZE) + (get_global $STRING_MEM_SIZE))) + (set_global $heap_start (i32.add (get_global $memoryBase) + (get_global $S_STRING_END))) + (set_global $heap_end (i32.add (get_global $heap_start) + $heap_size)) + + (set_global $mem (get_global $heap_start)) + (set_global $mem_unused_start 0) + (set_global $mem_free_list 0) + +;; (set_global $string_mem (i32.add (get_global $heap_start) +;; (get_global $MEM_SIZE))) +;; (set_global $string_mem_next (get_global $string_mem)) + + ;; Empty values + (set_global $NIL + ($ALLOC_SCALAR (get_global $NIL_T) 0)) + (set_global $FALSE + ($ALLOC_SCALAR (get_global $BOOLEAN_T) 0)) + (set_global $TRUE + ($ALLOC_SCALAR (get_global $BOOLEAN_T) 1)) + (set_global $EMPTY_LIST + ($ALLOC (get_global $LIST_T) + (get_global $NIL) (get_global $NIL) (get_global $NIL))) + (set_global $EMPTY_VECTOR + ($ALLOC (get_global $VECTOR_T) + (get_global $NIL) (get_global $NIL) (get_global $NIL))) + (set_global $EMPTY_HASHMAP + ($ALLOC (get_global $HASHMAP_T) + (get_global $NIL) (get_global $NIL) (get_global $NIL))) + +;; ($print "<<< init_memory\n") + + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; memory management + + (func $ALLOC_INTERNAL (param $type i32) (param $val1 i32) + (param $val2 i32) (param $val3 i32) (result i32) + (local $prev i32) + (local $res i32) + (local $size i32) + (set_local $prev (get_global $mem_free_list)) + (set_local $res (get_global $mem_free_list)) + (set_local $size ($MalType_size $type)) + + (block $loop_done + (loop $loop + ;; res == mem_unused_start + (if (i32.eq $res (get_global $mem_unused_start)) + (then + ;; ALLOC_UNUSED + ;;; if (res + size > MEM_SIZE) + (if (i32.gt_u (i32.add $res $size) (get_global $MEM_SIZE)) + (then + ;; Out of memory, exit + ($print "Out of mal memory!\n") + ($exit 1))) + ;;; if (mem_unused_start += size) + (set_global $mem_unused_start + (i32.add (get_global $mem_unused_start) $size)) + ;;; if (prev == res) + (if (i32.eq $prev $res) + (then + (set_global $mem_free_list (get_global $mem_unused_start))) + (else + ;;; mem[prev].val[0] = mem_unused_start + (i32.store + ($MalVal_val_ptr $prev 0) + (get_global $mem_unused_start)))) + (br $loop_done))) + ;; if (MalVal_size(mem+res) == size) + (if (i32.eq ($MalVal_size ($MalVal_ptr $res)) + $size) + (then + ;; ALLOC_MIDDLE + ;;; if (res == mem_free_list) + (if (i32.eq $res (get_global $mem_free_list)) + ;; set free pointer (mem_free_list) to next free + ;;; mem_free_list = mem[res].val[0]; + (set_global $mem_free_list ($MalVal_val $res 0))) + ;; if (res != mem_free_list) + (if (i32.ne $res (get_global $mem_free_list)) + ;; set previous free to next free + ;;; mem[prev].val[0] = mem[res].val[0] + (i32.store ($MalVal_val_ptr $prev 0) ($MalVal_val $res 0))) + (br $loop_done))) + ;;; prev = res + (set_local $prev $res) + ;;; res = mem[res].val[0] + (set_local $res ($MalVal_val $res 0)) + (br $loop) + ) + ) + ;; ALLOC_DONE + ;;; mem[res].refcnt_type = type + 32 + (i32.store ($MalVal_ptr $res) (i32.add $type 32)) + ;; set val to default val1 + ;;; mem[res].val[0] = val1 + (i32.store ($MalVal_val_ptr $res 0) $val1) + ;;; if (type > 5 && type != 9) + (if (i32.and (i32.gt_u $type 5) (i32.ne $type 9)) + (then + ;; inc refcnt of referenced value + ;;; mem[val1].refcnt_type += 32 + (i32.store ($MalVal_ptr $val1) + (i32.add ($MalVal_refcnt_type $val1) 32)))) + ;;; if (size > 2) + (if (i32.gt_u $size 2) + (then + ;; inc refcnt of referenced value + ;;; mem[val2].refcnt_type += 32 + (i32.store ($MalVal_ptr $val2) + (i32.add ($MalVal_refcnt_type $val2) 32)) + ;;; mem[res].val[1] = val2 + (i32.store ($MalVal_val_ptr $res 1) $val2))) + ;;; if (size > 3) + (if (i32.gt_u $size 3) + (then + ;; inc refcnt of referenced value + ;;; mem[val3].refcnt_type += 32 + (i32.store ($MalVal_ptr $val3) + (i32.add ($MalVal_refcnt_type $val3) 32)) + ;;; mem[res].val[2] = val3 + (i32.store ($MalVal_val_ptr $res 2) $val3))) + + ;;; return mem + res + ($MalVal_ptr $res) + ) + + (func $ALLOC_SCALAR (param $type i32) (param $val1 i32) (result i32) + ($ALLOC_INTERNAL $type $val1 0 0) + ) + + (func $ALLOC (param $type i32) (param $val1 i32) + (param $val2 i32) (param $val3 i32) (result i32) + ($ALLOC_INTERNAL $type + ($MalVal_index $val1) + ($MalVal_index $val2) + ($MalVal_index $val3)) + ) + + (func $RELEASE (param $mv i32) + (local $idx i32) + (local $type i32) + (local $size i32) + + ;; Ignore NULLs + ;;; if (mv == NULL) { return; } + (if (i32.eqz $mv) (return)) + ;;; idx = mv - mem + (set_local $idx ($MalVal_index $mv)) + ;;; type = mv->refcnt_type & 31 + (set_local $type (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 + ;;; size = MalType_size(type) + (set_local $size ($MalType_size $type)) + + ;; DEBUG + ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) + + (if (i32.eq 0 $mv) + (then + ($print "RELEASE of NULL!\n") + ($exit 1))) + + (if (i32.eq (get_global $FREE_T) $type) + (then + ($printf_2 "RELEASE of already free mv: 0x%x, idx: 0x%x\n" $mv $idx) + ($exit 1))) + (if (i32.lt_u ($MalVal_refcnt_type $idx) 15) + (then + ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) + ($exit 1))) + + ;; decrease reference count by one + (i32.store ($MalVal_ptr $idx) + (i32.sub_u ($MalVal_refcnt_type $idx) 32)) + + ;; nil, false, true, empty sequences + (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (then + (if (i32.lt_u ($MalVal_refcnt_type $idx) 32) + (then + ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) + ($exit 1))) + (return))) + + ;; our reference count is not 0, so don't release + (if (i32.ge_u ($MalVal_refcnt_type $idx) 32) + (return)) + + (block $done + (block (block (block (block (block (block + (br_table 0 0 0 0 1 1 2 2 3 5 5 5 5 4 5 5 5 $type)) + ;; nil, boolean, integer, float + (br $done)) + ;; string, kw, symbol + ;; release string, then FREE reference + ($RELEASE_STRING $mv) + (br $done)) + ;; list, vector + (if (i32.ne ($MalVal_val $idx 0) 0) + (then + ;; release next element and value + ($RELEASE ($MEM_VAL0_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)))) + (br $done)) + ;; hashmap + (if (i32.ne ($MalVal_val $idx 0) 0) + (then + ;; release next element, value, and key + ($RELEASE ($MEM_VAL0_ptr $mv)) + ($RELEASE ($MEM_VAL2_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)))) + (br $done)) + ;; env + ;; if outer is set then release outer + (if (i32.ne ($MalVal_val $idx 1) 0) + ($RELEASE ($MEM_VAL1_ptr $mv))) + ;; release the hashmap data + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) + ;; default/unknown + ) + + ;; FREE, free the current element + + ;; set type(FREE/15) and size + ;;; mv->refcnt_type = size*32 + FREE_T + (i32.store $mv (i32.add (i32.mul_u $size 32) (get_global $FREE_T))) + (i32.store ($MalVal_val_ptr $idx 0) (get_global $mem_free_list)) + (set_global $mem_free_list $idx) + (if (i32.ge_u $size 3) (i32.store ($MalVal_val_ptr $idx 1) 0)) + (if (i32.eq $size 4) (i32.store ($MalVal_val_ptr $idx 2) 0)) + ) + + ;; Allocate a string as follows: + ;; refcnt (i32 set to 1), string data, NULL byte + (func $STRING_DUPE (param $str i32) (result i32) + (local $len i32) + (local $cur i32) + (local $new i32) + (local $idx i32) + + ;; Calculate length of string needed + (set_local $len ($STRING_LEN $str)) + + ;; leading i32 refcnt + trailing NULL + (set_local $new ($malloc (i32.add 5 $len))) + + ;; set initial refcnt to 1 + (i32.store $new 1) + ;; skip refcnt + (set_local $cur (i32.add $new 4)) + ;; Set NULL terminator + (i32.store8_u (i32.add $cur $len) 0) + + ;; Copy the characters + ($MEM_COPY $cur $str $len) + $new + ) + + ;; Duplicate regular character array string into a Mal string and + ;; return the MalVal pointer + (func $STRING (param $type i32) (param $str i32) (result i32) + ($ALLOC_SCALAR + $type + ($STRING_DUPE $str)) + ) + + (func $RELEASE_STRING (param $mv i32) + (local $str i32) + (set_local $str ($MalVal_val + ($MalVal_index $mv) + 0)) + + ;; DEBUG +;; ($printf_1 "RELEASE_STRING - calling free on: %d" $str) + + ($free $str) + ) +) diff --git a/wasm/mem.wast b/wasm/mem.wast deleted file mode 100644 index 43464cd0d8..0000000000 --- a/wasm/mem.wast +++ /dev/null @@ -1,461 +0,0 @@ -(module $mem - (global $MEM_SIZE i32 (i32.const 1048576)) - (global $STRING_MEM_SIZE i32 (i32.const 1048576)) - - (global $heap_start (mut i32) (i32.const 0)) - (global $heap_end (mut i32) (i32.const 0)) - - (global $mem (mut i32) (i32.const 0)) - (global $mem_unused_start (mut i32) (i32.const 0)) - (global $mem_free_list (mut i32) (i32.const 0)) - (global $mem_user_start (mut i32) (i32.const 0)) - -;; (global $string_mem (mut i32) (i32.const 0)) -;; (global $string_mem_next (mut i32) (i32.const 0)) -;; (global $string_mem_user_start (mut i32) (i32.const 0)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; General type storage/pointer functions - - (func $VAL0_ptr (param $mv i32) (result i32) - (i32.add (get_local $mv) (i32.const 4))) - (func $VAL1_ptr (param $mv i32) (result i32) - (i32.add (get_local $mv) (i32.const 8))) - - (func $VAL0 (param $mv i32) (result i32) - (i32.load (i32.add (get_local $mv) (i32.const 4)))) - (func $VAL1 (param $mv i32) (result i32) - (i32.load (i32.add (get_local $mv) (i32.const 8)))) - - - (func $MEM_VAL0_ptr (param $mv i32) (result i32) - (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add (get_local $mv) (i32.const 4))) - (i32.const 8)))) - (func $MEM_VAL1_ptr (param $mv i32) (result i32) - (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add (get_local $mv) (i32.const 8))) - (i32.const 8)))) - (func $MEM_VAL2_ptr (param $mv i32) (result i32) - (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add (get_local $mv) (i32.const 12))) - (i32.const 8)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Returns the address of 'mem[mv_idx]' - (func $MalVal_ptr (param $mv_idx i32) (result i32) - ;; MalVal memory 64 bit (2 * i32) aligned - ;;; mem[mv_idx].refcnt_type - (i32.add (get_global $mem) - (i32.mul_u (get_local $mv_idx) (i32.const 8)))) - - ;; Returns the memory index mem of mv - ;; Will usually be used with a load or store by the caller - (func $MalVal_index (param $mv i32) (result i32) - ;; MalVal memory 64 bit (2 * i32) aligned - (i32.div_u (i32.sub_u (get_local $mv) (get_global $mem)) - (i32.const 8))) - - ;; Returns the address of 'mem[mv_idx].refcnt_type' - (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) - (i32.load (call $MalVal_ptr (get_local $mv_idx)))) - - (func $TYPE (param $mv i32) (result i32) - ;;; type = mv->refcnt_type & 31 - (i32.and (i32.load (get_local $mv)) - (i32.const 0x1f))) ;; 0x1f == 31 - - (func $REFS (param $mv i32) (result i32) - ;;; type = mv->refcnt_type & 31 - (i32.shr_u (i32.load (get_local $mv)) - (i32.const 5))) ;; / 32 - - ;; Returns the address of 'mem[mv_idx].val[val]' - ;; Will usually be used with a load or store by the caller - (func $MalVal_val_ptr (param $mv_idx i32) (param $val i32) (result i32) - (i32.add (i32.add (call $MalVal_ptr (get_local $mv_idx)) - (i32.const 4)) - (i32.mul_u (get_local $val) - (i32.const 4)))) - - ;; Returns the value of 'mem[mv_idx].val[val]' - (func $MalVal_val (param $mv_idx i32) (param $val i32) (result i32) - (i32.load (call $MalVal_val_ptr (get_local $mv_idx) (get_local $val)))) - - (func $MalType_size (param $type i32) (result i32) - ;;; if (type <= 5 || type == 9 || type == 12) - (if i32 (i32.or (i32.le_u (get_local $type) (i32.const 5)) - (i32.or (i32.eq (get_local $type) (i32.const 9)) - (i32.eq (get_local $type) (i32.const 12)))) - (then (i32.const 2)) - (else - ;;; else if (type == 8 || type == 10 || type == 11) - (if i32 (i32.or (i32.eq (get_local $type) (i32.const 8)) - (i32.or (i32.eq (get_local $type) (i32.const 10)) - (i32.eq (get_local $type) (i32.const 11)))) - (then (i32.const 4)) - (else (i32.const 3)))))) - - (func $MalVal_size (param $mv i32) (result i32) - (local $type i32) - (set_local $type (call $TYPE (get_local $mv))) - ;; if (type == FREE_T) - (if i32 (i32.eq (get_local $type) (get_global $FREE_T)) - (then - ;;; return (mv->refcnt_type & 0xffe0)>>5 - (i32.shr_u - (i32.and - (i32.load (get_local $mv)) - (i32.const 0xffe0)) - (i32.const 5))) ;;; / 32 - (else - ;;; return MalType_size(type) - (call $MalType_size (get_local $type))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; init_memory - - (func $init_memory - (local $heap_size i32) - -;; (call $print (STRING ">>> init_memory\n")) - - (call $init_sprintf_mem) - - ;; 100 character error_str static buffer - (set_global $error_str (STRING " ")) - ;; 256 character token static buffer - (set_global $token (STRING " ")) - - (set_local $heap_size (i32.add (get_global $MEM_SIZE) - (get_global $STRING_MEM_SIZE))) - (set_global $heap_start (i32.add (get_global $memoryBase) - (get_global $S_STRING_END))) - (set_global $heap_end (i32.add (get_global $heap_start) - (get_local $heap_size))) - - (set_global $mem (get_global $heap_start)) - (set_global $mem_unused_start (i32.const 0)) - (set_global $mem_free_list (i32.const 0)) - -;; (set_global $string_mem (i32.add (get_global $heap_start) -;; (get_global $MEM_SIZE))) -;; (set_global $string_mem_next (get_global $string_mem)) - - ;; Empty values - (set_global $NIL - (call $ALLOC_SCALAR (get_global $NIL_T) (i32.const 0))) - (set_global $FALSE - (call $ALLOC_SCALAR (get_global $BOOLEAN_T) (i32.const 0))) - (set_global $TRUE - (call $ALLOC_SCALAR (get_global $BOOLEAN_T) (i32.const 1))) - (set_global $EMPTY_LIST - (call $ALLOC (get_global $LIST_T) - (get_global $NIL) (get_global $NIL) (get_global $NIL))) - (set_global $EMPTY_VECTOR - (call $ALLOC (get_global $VECTOR_T) - (get_global $NIL) (get_global $NIL) (get_global $NIL))) - (set_global $EMPTY_HASHMAP - (call $ALLOC (get_global $HASHMAP_T) - (get_global $NIL) (get_global $NIL) (get_global $NIL))) - -;; (call $print (STRING "<<< init_memory\n")) - - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; memory management - - (func $ALLOC_INTERNAL (param $type i32) (param $val1 i32) - (param $val2 i32) (param $val3 i32) (result i32) - (local $prev i32) - (local $res i32) - (local $size i32) - (set_local $prev (get_global $mem_free_list)) - (set_local $res (get_global $mem_free_list)) - (set_local $size (call $MalType_size (get_local $type))) - - (block $loop_done - (loop $loop - ;; res == mem_unused_start - (if (i32.eq (get_local $res) (get_global $mem_unused_start)) - (then - ;; ALLOC_UNUSED - ;;; if (res + size > MEM_SIZE) - (if (i32.gt_u (i32.add (get_local $res) (get_local $size)) - (get_global $MEM_SIZE)) - (then - ;; Out of memory, exit - (call $print (STRING "Out of mal memory!\n")) - (call $exit (i32.const 1)))) - ;;; if (mem_unused_start += size) - (set_global $mem_unused_start - (i32.add (get_global $mem_unused_start) - (get_local $size))) - ;;; if (prev == res) - (if (i32.eq (get_local $prev) (get_local $res)) - (then - (set_global $mem_free_list (get_global $mem_unused_start))) - (else - ;;; mem[prev].val[0] = mem_unused_start - (i32.store - (call $MalVal_val_ptr (get_local $prev) (i32.const 0)) - (get_global $mem_unused_start)))) - (br $loop_done))) - ;; if (MalVal_size(mem+res) == size) - (if (i32.eq (call $MalVal_size (call $MalVal_ptr (get_local $res))) - (get_local $size)) - (then - ;; ALLOC_MIDDLE - ;;; if (res == mem_free_list) - (if (i32.eq (get_local $res) (get_global $mem_free_list)) - ;; set free pointer (mem_free_list) to next free - ;;; mem_free_list = mem[res].val[0]; - (set_global $mem_free_list - (call $MalVal_val (get_local $res) (i32.const 0)))) - ;; if (res != mem_free_list) - (if (i32.ne (get_local $res) (get_global $mem_free_list)) - ;; set previous free to next free - ;;; mem[prev].val[0] = mem[res].val[0] - (i32.store (call $MalVal_val_ptr (get_local $prev) (i32.const 0)) - (call $MalVal_val (get_local $res) (i32.const 0)))) - (br $loop_done))) - ;;; prev = res - (set_local $prev (get_local $res)) - ;;; res = mem[res].val[0] - (set_local $res (call $MalVal_val (get_local $res) (i32.const 0))) - (br $loop) - ) - ) - ;; ALLOC_DONE - ;;; mem[res].refcnt_type = type + 32 - (i32.store (call $MalVal_ptr (get_local $res)) - (i32.add (get_local $type) (i32.const 32))) - ;; set val to default val1 - ;;; mem[res].val[0] = val1 - (i32.store (call $MalVal_val_ptr (get_local $res) (i32.const 0)) - (get_local $val1)) - ;;; if (type > 5 && type != 9) - (if (i32.and (i32.gt_u (get_local $type) (i32.const 5)) - (i32.ne (get_local $type) (i32.const 9))) - (then - ;; inc refcnt of referenced value - ;;; mem[val1].refcnt_type += 32 - (i32.store (call $MalVal_ptr (get_local $val1)) - (i32.add (call $MalVal_refcnt_type (get_local $val1)) - (i32.const 32))))) - ;;; if (size > 2) - (if (i32.gt_u (get_local $size) (i32.const 2)) - (then - ;; inc refcnt of referenced value - ;;; mem[val2].refcnt_type += 32 - (i32.store (call $MalVal_ptr (get_local $val2)) - (i32.add (call $MalVal_refcnt_type (get_local $val2)) - (i32.const 32))) - ;;; mem[res].val[1] = val2 - (i32.store (call $MalVal_val_ptr (get_local $res) (i32.const 1)) - (get_local $val2)))) - ;;; if (size > 3) - (if (i32.gt_u (get_local $size) (i32.const 3)) - (then - ;; inc refcnt of referenced value - ;;; mem[val3].refcnt_type += 32 - (i32.store (call $MalVal_ptr (get_local $val3)) - (i32.add (call $MalVal_refcnt_type (get_local $val3)) - (i32.const 32))) - ;;; mem[res].val[2] = val3 - (i32.store (call $MalVal_val_ptr (get_local $res) (i32.const 2)) - (get_local $val3)))) - - ;;; return mem + res - (call $MalVal_ptr (get_local $res)) - ) - - (func $ALLOC_SCALAR (param $type i32) (param $val1 i32) - (result i32) - (call $ALLOC_INTERNAL - (get_local $type) - (get_local $val1) - (i32.const 0) - (i32.const 0)) - ) - - (func $ALLOC (param $type i32) (param $val1 i32) - (param $val2 i32) (param $val3 i32) (result i32) - (call $ALLOC_INTERNAL - (get_local $type) - (call $MalVal_index (get_local $val1)) - (call $MalVal_index (get_local $val2)) - (call $MalVal_index (get_local $val3))) - ) - - (func $RELEASE (param $mv i32) - (local $idx i32) - (local $type i32) - (local $size i32) - - ;; Ignore NULLs - ;;; if (mv == NULL) { return; } - (if (i32.eqz (get_local $mv)) (return)) - ;;; idx = mv - mem - (set_local $idx (call $MalVal_index (get_local $mv))) - ;;; type = mv->refcnt_type & 31 - (set_local $type (i32.and (i32.load (get_local $mv)) - (i32.const 0x1f))) ;; 0x1f == 31 - ;;; size = MalType_size(type) - (set_local $size (call $MalType_size (get_local $type))) - - ;; DEBUG - ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) -;; (call $print (STRING ">>> RELEASE idx: ")) -;; (call $printhex (get_local $idx)) -;; (call $print (STRING ", type: ")) -;; (call $printnum (get_local $type) (i32.const 10)) -;; (call $print (STRING ", size: ")) -;; (call $printnum (get_local $size) (i32.const 10)) -;; (call $print (STRING "\n")) - - (if (i32.eq (i32.const 0) (get_local $mv)) - (then - (call $print (STRING "RELEASE of NULL!\n")) - (call $exit (i32.const 1)))) - - (if (i32.eq (get_global $FREE_T) (get_local $type)) - (then - (call $printf_2 (STRING "RELEASE of already free mv: 0x%x, idx: 0x%x\n") - (get_local $mv) (get_local $idx)) - (call $exit (i32.const 1)))) - (if (i32.lt_u (call $MalVal_refcnt_type (get_local $idx)) - (i32.const 15)) - (then - (call $printf_2 (STRING "RELEASE of unowned mv: 0x%x, idx: 0x%x\n") - (get_local $mv) (get_local $idx)) - (call $exit (i32.const 1)))) - - ;; decrease reference count by one - (i32.store (call $MalVal_ptr (get_local $idx)) - (i32.sub_u (call $MalVal_refcnt_type (get_local $idx)) - (i32.const 32))) - - ;; nil, false, true, empty sequences - (if (i32.le_u (get_local $mv) (get_global $EMPTY_HASHMAP)) - (then - (if (i32.lt_u (call $MalVal_refcnt_type (get_local $idx)) - (i32.const 32)) - (then - (call $printf_2 (STRING "RELEASE of unowned mv: 0x%x, idx: 0x%x\n") - (get_local $mv) (get_local $idx)) - (call $exit (i32.const 1)))) - (return))) - - ;; our reference count is not 0, so don't release - (if (i32.ge_u (call $MalVal_refcnt_type (get_local $idx)) - (i32.const 32)) - (return)) - - (block $done - (block (block (block (block (block (block - (br_table 0 0 0 0 1 1 2 2 3 5 5 5 5 4 5 5 5 (get_local $type))) - ;; nil, boolean, integer, float - (br $done)) - ;; string, kw, symbol - ;; release string, then FREE reference - (call $RELEASE_STRING (get_local $mv)) - (br $done)) - ;; list, vector - (if (i32.ne (call $MalVal_val (get_local $idx) (i32.const 0)) - (i32.const 0)) - (then - ;; release next element and value - (call $RELEASE (call $MEM_VAL0_ptr (get_local $mv))) - (call $RELEASE (call $MEM_VAL1_ptr (get_local $mv))))) - (br $done)) - ;; hashmap - (if (i32.ne (call $MalVal_val (get_local $idx) (i32.const 0)) - (i32.const 0)) - (then - ;; release next element, value, and key - (call $RELEASE (call $MEM_VAL0_ptr (get_local $mv))) - (call $RELEASE (call $MEM_VAL2_ptr (get_local $mv))) - (call $RELEASE (call $MEM_VAL1_ptr (get_local $mv))))) - (br $done)) - ;; env - ;; if outer is set then release outer - (if (i32.ne (call $MalVal_val (get_local $idx) (i32.const 1)) - (i32.const 0)) - (call $RELEASE (call $MEM_VAL1_ptr (get_local $mv)))) - ;; release the hashmap data - (call $RELEASE (call $MEM_VAL0_ptr (get_local $mv))) - (br $done)) - ;; default/unknown - ) - - ;; FREE, free the current element - - ;; set type(FREE/15) and size - ;;; mv->refcnt_type = size*32 + FREE_T - (i32.store (get_local $mv) - (i32.add (i32.mul_u (get_local $size) - (i32.const 32)) - (get_global $FREE_T))) - (i32.store (call $MalVal_val_ptr (get_local $idx) (i32.const 0)) - (get_global $mem_free_list)) - (set_global $mem_free_list (get_local $idx)) - (if (i32.ge_u (get_local $size) (i32.const 3)) - (i32.store (call $MalVal_val_ptr (get_local $idx) (i32.const 1)) - (i32.const 0))) - (if (i32.eq (get_local $size) (i32.const 4)) - (i32.store (call $MalVal_val_ptr (get_local $idx) (i32.const 2)) - (i32.const 0))) - ) - - ;; Allocate a string as follows: - ;; refcnt (i32 set to 1), string data, NULL byte - (func $STRING_DUPE (param $str i32) (result i32) - (local $len i32) - (local $cur i32) - (local $new i32) - (local $idx i32) - - ;; Calculate length of string needed - (set_local $len (call $STRING_LEN (get_local $str))) - - ;; leading i32 refcnt + trailing NULL - (set_local $new (call $malloc (i32.add (i32.const 5) (get_local $len)))) - - ;; DEBUG -;; (call $debug (STRING "STRING_DUPE - malloc returned: ") (get_local $new)) - - ;; set initial refcnt to 1 - (i32.store (get_local $new) (i32.const 1)) - ;; skip refcnt - (set_local $cur (i32.add (get_local $new) (i32.const 4))) - ;; Set NULL terminator - (i32.store8_u (i32.add (get_local $cur) (get_local $len)) (i32.const 0)) - - ;; Copy the characters - (call $MEM_COPY (get_local $cur) (get_local $str) (get_local $len)) - (get_local $new) - ) - - ;; Duplicate regular character array string into a Mal string and - ;; return the MalVal pointer - (func $STRING (param $type i32) (param $str i32) (result i32) - (call $ALLOC_SCALAR - (get_local $type) - (call $STRING_DUPE (get_local $str))) - ) - - (func $RELEASE_STRING (param $mv i32) - (local $str i32) - (set_local $str (call $MalVal_val - (call $MalVal_index (get_local $mv)) - (i32.const 0))) - - ;; DEBUG -;; (call $debug (STRING "RELEASE_STRING - calling free on: ") (get_local $str)) - - (call $free (get_local $str)) - ) -) diff --git a/wasm/printer.wam b/wasm/printer.wam new file mode 100644 index 0000000000..28e9e1a87e --- /dev/null +++ b/wasm/printer.wam @@ -0,0 +1,139 @@ +(module $printer + + (func $pr_str_val (param $res i32) (param $mv i32) (result i32) + (local $type i32) + (local $val0 i32) + (local $sval i32) + (set_local $type ($TYPE $mv)) + (set_local $val0 ($MalVal_val ($MalVal_index $mv) + 0)) + + ;;; switch(type) + (block $done + (block $default + (block (block (block (block (block (block (block (block + (block (block (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 $type)) + ;; 0: nil + ($MEM_COPY $res "nil" 4) + (set_local $res (i32.add 3 $res)) + (br $done)) + ;; 1: boolean + (if (i32.eq $val0 0) + (then + ;; false + ($MEM_COPY $res "false" 5) + (set_local $res (i32.add 5 $res))) + (else + ;; true + ($MEM_COPY $res "true" 4) + (set_local $res (i32.add 4 $res)))) + (br $done)) + ;; 2: integer + (set_local $res ($sprintf_1 $res "%d" $val0)) + (br $done)) + ;; 3: float/ERROR + (set_local $res ($sprintf_1 $res "%d" " *** GOT FLOAT *** ")) + (br $done)) + ;; 4: string/kw + (set_local $sval ($to_String $mv)) + (if (i32.eq (i32.load8_u $sval) (CHR "\x7f")) + (then + (set_local $res ($sprintf_1 $res ":%s" (i32.add $sval 1)))) + (else + (set_local $res ($sprintf_1 $res "\"%s\"" ($to_String $mv))))) + (br $done)) + ;; 5: symbol + (set_local $res ($sprintf_1 $res "%s" ($to_String $mv))) + (br $done)) + ;; 6: list, fallthrouogh + ) + ;; 7: vector, fallthrough + ) + ;; 8: hashmap + (set_local + $res ($sprintf_1 $res "%c" + (if i32 (i32.eq $type (get_global $LIST_T)) + (CHR "(") + (else (if i32 (i32.eq $type (get_global $VECTOR_T)) + (CHR "[") + (else (CHR "{"))))))) + ;; PR_SEQ_LOOP + ;;; while (VAL0(mv) != 0) + (block $done_seq + (loop $seq_loop + (if (i32.eq ($VAL0 $mv) 0) + (br $done_seq)) + ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) + (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv))) + + ;; if this is a hash-map, print the next element + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + ;;; res += snprintf(res, 2, " ") + (set_local $res ($sprintf_1 $res " " 0)) + (set_local $res ($pr_str_val $res ($MEM_VAL2_ptr $mv))))) + ;;; mv = MEM_VAL0(mv) + (set_local $mv ($MEM_VAL0_ptr $mv)) + ;;; if (VAL0(mv) != 0) + (if (i32.ne ($VAL0 $mv) 0) + ;;; res += snprintf(res, 2, " ") + (set_local $res ($sprintf_1 $res " " 0))) + ;;($print "here4\n") + (br $seq_loop) + ) + ) + + (set_local + $res ($sprintf_1 $res "%c" + (if i32 (i32.eq $type (get_global $LIST_T)) + (CHR ")") + (else (if i32 (i32.eq $type (get_global $VECTOR_T)) + (CHR "]") + (else (CHR "}"))))))) + (br $done)) + ;; 9: function + ($MEM_COPY $res "#" 10) + (set_local $res (i32.add 9 $res)) + (br $done)) + ;; 10: mal function + ($MEM_COPY $res "(fn* ...)" 10) + (set_local $res (i32.add 9 $res)) + (br $done)) + ;; 11: macro fn + ($print "macro fn") + ($MEM_COPY $res "#" 13) + (set_local $res (i32.add 12 $res)) + (br $done)) + ;; 12: atom + ($MEM_COPY $res "(atom ...)" 11) + (set_local $res (i32.add 10 $res)) + (br $done)) + ;; 13: environment + ($MEM_COPY $res "#" 11) + (set_local $res (i32.add 10 $res)) + (br $done)) + ;; 14: metadata + ($MEM_COPY $res "#" 12) + (set_local $res (i32.add 11 $res)) + (br $done)) + ;; 15: FREE + ($MEM_COPY $res "#" 12) + (set_local $res (i32.add 11 $res)) + (br $done)) + ;; 16: default + ($MEM_COPY $res "#" 11) + (set_local $res (i32.add 10 $res)) + ) + + $res + ) + + (func $pr_str (param $mv i32) (result i32) + (drop ($pr_str_val (get_global $sprintf_buf) $mv)) + ($STRING (get_global $STRING_T) (get_global $sprintf_buf)) + ) + + (export "pr_str" (func $pr_str)) + +) diff --git a/wasm/printer.wast b/wasm/printer.wast deleted file mode 100644 index 7f88ded823..0000000000 --- a/wasm/printer.wast +++ /dev/null @@ -1,148 +0,0 @@ -(module $printer - - (func $pr_str_val (param $res i32) (param $mv i32) (result i32) - (local $type i32) - (local $val0 i32) - (local $sval i32) - (set_local $type (call $TYPE (get_local $mv))) - (set_local $val0 (call $MalVal_val (call $MalVal_index (get_local $mv)) - (i32.const 0))) - - ;;; switch(type) - (block $done - (block $default - (block (block (block (block (block (block (block (block - (block (block (block (block (block (block (block (block - (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (get_local $type))) - ;; 0: nil - (call $MEM_COPY (get_local $res) (STRING "nil") (i32.const 4)) - (set_local $res (i32.add (i32.const 3) (get_local $res))) - (br $done)) - ;; 1: boolean - (if (i32.eq (get_local $val0) (i32.const 0)) - (then - ;; false - (call $MEM_COPY (get_local $res) (STRING "false") (i32.const 5)) - (set_local $res (i32.add (i32.const 5) (get_local $res)))) - (else - ;; true - (call $MEM_COPY (get_local $res) (STRING "true") (i32.const 4)) - (set_local $res (i32.add (i32.const 4) (get_local $res))))) - (br $done)) - ;; 2: integer - (set_local $res (call $sprintf_1 (get_local $res) (STRING "%d") - (get_local $val0))) - (br $done)) - ;; 3: float/ERROR - (set_local $res (call $sprintf_1 (get_local $res) (STRING "%d") - (STRING " *** GOT FLOAT *** "))) - (br $done)) - ;; 4: string/kw - (set_local $sval (call $to_String (get_local $mv))) - (if (i32.eq (i32.load8_u (get_local $sval)) (CHAR "\x7f")) - (then - (set_local $res (call $sprintf_1 (get_local $res) (STRING ":%s") - (i32.add (get_local $sval) (i32.const 1))))) - (else - (set_local $res (call $sprintf_1 (get_local $res) (STRING "\"%s\"") - (call $to_String (get_local $mv)))))) - (br $done)) - ;; 5: symbol - (set_local $res (call $sprintf_1 (get_local $res) (STRING "%s") - (call $to_String (get_local $mv)))) - (br $done)) - ;; 6: list, fallthrouogh - ) - ;; 7: vector, fallthrough - ) - ;; 8: hashmap - (set_local - $res (call $sprintf_1 (get_local $res) (STRING "%c") - (if i32 (i32.eq (get_local $type) (get_global $LIST_T)) - (CHAR "(") - (else (if i32 (i32.eq (get_local $type) (get_global $VECTOR_T)) - (CHAR "[") - (else (CHAR "{"))))))) - ;; PR_SEQ_LOOP - ;;; while (VAL0(mv) != 0) - (block $done_seq - (loop $seq_loop - (if (i32.eq (call $VAL0 (get_local $mv)) (i32.const 0)) - (br $done_seq)) - ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) - (set_local $res (call $pr_str_val (get_local $res) - (call $MEM_VAL1_ptr (get_local $mv)))) - - ;; if this is a hash-map, print the next element - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (then - ;;; res += snprintf(res, 2, " ") - (set_local $res (call $sprintf_1 (get_local $res) (STRING " ") - (i32.const 0))) - (set_local $res (call $pr_str_val (get_local $res) - (call $MEM_VAL2_ptr (get_local $mv)))))) - ;;; mv = MEM_VAL0(mv) - (set_local $mv (call $MEM_VAL0_ptr (get_local $mv))) - ;;; if (VAL0(mv) != 0) - (if (i32.ne (call $VAL0 (get_local $mv)) (i32.const 0)) - ;;; res += snprintf(res, 2, " ") - (set_local $res (call $sprintf_1 (get_local $res) (STRING " ") - (i32.const 0)))) - ;;(call $print (STRING "here4\n")) - (br $seq_loop) - ) - ) - - (set_local - $res (call $sprintf_1 (get_local $res) (STRING "%c") - (if i32 (i32.eq (get_local $type) (get_global $LIST_T)) - (CHAR ")") - (else (if i32 (i32.eq (get_local $type) (get_global $VECTOR_T)) - (CHAR "]") - (else (CHAR "}"))))))) - (br $done)) - ;; 9: function - (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 10)) - (set_local $res (i32.add (i32.const 9) (get_local $res))) - (br $done)) - ;; 10: mal function - (call $MEM_COPY (get_local $res) (STRING "(fn* ...)") (i32.const 10)) - (set_local $res (i32.add (i32.const 9) (get_local $res))) - (br $done)) - ;; 11: macro fn - (call $print (STRING "macro fn")) - (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 13)) - (set_local $res (i32.add (i32.const 12) (get_local $res))) - (br $done)) - ;; 12: atom - (call $MEM_COPY (get_local $res) (STRING "(atom ...)") (i32.const 11)) - (set_local $res (i32.add (i32.const 10) (get_local $res))) - (br $done)) - ;; 13: environment - (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 11)) - (set_local $res (i32.add (i32.const 10) (get_local $res))) - (br $done)) - ;; 14: metadata - (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 12)) - (set_local $res (i32.add (i32.const 11) (get_local $res))) - (br $done)) - ;; 15: FREE - (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 12)) - (set_local $res (i32.add (i32.const 11) (get_local $res))) - (br $done)) - ;; 16: default - (call $MEM_COPY (get_local $res) (STRING "#") (i32.const 11)) - (set_local $res (i32.add (i32.const 10) (get_local $res))) - ) - - (get_local $res) - ) - - (func $pr_str (param $mv i32) (result i32) - (drop (call $pr_str_val (get_global $sprintf_buf) (get_local $mv))) - (call $STRING (get_global $STRING_T) (get_global $sprintf_buf)) - ) - - (export "pr_str" (func $pr_str)) - -) diff --git a/wasm/reader.wam b/wasm/reader.wam new file mode 100644 index 0000000000..af13e90123 --- /dev/null +++ b/wasm/reader.wam @@ -0,0 +1,287 @@ +(module $reader + + ;; TODO: global warning + (global $token (mut i32) 0) + (global $read_index (mut i32) 0) + + (func $skip_spaces (param $str i32) (result i32) + (local $found i32) + (local $c i32) + (set_local $found 0) + (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (block $done + (loop $loop + ;;; while (c == ' ' || c == ',' || c == '\n') + (if (i32.and (i32.and + (i32.ne $c (CHR " ")) + (i32.ne $c (CHR ","))) + (i32.ne $c (CHR "\n"))) + (br $done)) + (set_local $found 1) + ;;; c=str[++(*index)] + (set_global $read_index (i32.add (get_global $read_index) 1)) + (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (br $loop) + ) + ) +;; ($debug ">>> skip_spaces:" $found) + $found + ) + + (func $skip_to_eol (param $str i32) (result i32) + (local $found i32) + (local $c i32) + (set_local $found 0) + (set_local $c (i32.load8_c (i32.add $str (get_global $read_index)))) + (if (i32.eq $c (CHR ";")) + (then + (set_local $found 1) + (block $done + (loop $loop + ;;; c=str[++(*index)] + (set_global $read_index (i32.add (get_global $read_index) 1)) + (set_local $c (i32.load8_u (i32.add $str + (get_global $read_index)))) + ;;; while (c != '\0' && c != '\n') + (if (i32.and (i32.ne $c (CHR "\x00")) (i32.ne $c (CHR "\n"))) + (br $loop)) + ) + ))) +;; ($debug ">>> skip_to_eol:" $found) + $found + ) + + (func $skip_spaces_comments (param $str i32) + (loop $loop + ;; skip spaces + (if ($skip_spaces $str) (br $loop)) + ;; skip comments + (if ($skip_to_eol $str) (br $loop)) + ) + ) + + (func $read_token (param $str i32) (result i32) + (local $token_index i32) + (local $instring i32) + (local $escaped i32) + (local $c i32) + (set_local $token_index 0) + (set_local $instring 0) + (set_local $escaped 0) + + ($skip_spaces_comments $str) + + ;; read first character + ;;; c=str[++(*index)] + (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (set_global $read_index (i32.add (get_global $read_index) 1)) + ;; read first character + ;;; token[token_index++] = c + (i32.store8_u (i32.add (get_global $token) $token_index) $c) + (set_local $token_index (i32.add $token_index 1)) + ;; single/double character token + (if (i32.or (i32.eq $c (CHR "(")) + (i32.or (i32.eq $c (CHR ")")) + (i32.or (i32.eq $c (CHR "[")) + (i32.or (i32.eq $c (CHR "]")) + (i32.or (i32.eq $c (CHR "{")) + (i32.or (i32.eq $c (CHR "}")) + (i32.or (i32.eq $c (CHR "'")) + (i32.or (i32.eq $c (CHR "`")) + (i32.or (i32.eq $c (CHR "@")) + (i32.and (i32.eq $c (CHR "~")) + (i32.eq (i32.load8_u (i32.add $str (get_global $read_index))) + (CHR "@")))))))))))) + + (then + ;; continue + (nop)) + (else + ;;; if (c == '"') instring = true + (set_local $instring (i32.eq $c (CHR "\""))) + (block $done + (loop $loop + ;; peek at next character + ;;; c = str[*index] + (set_local $c (i32.load8_u + (i32.add $str (get_global $read_index)))) + ;;; if (c == '\0') break + (if (i32.eq $c 0) (br $done)) + ;;; if (!instring) + (if (i32.eqz $instring) + (then + ;; next character is token delimiter + (if (i32.or (i32.eq $c (CHR "(")) + (i32.or (i32.eq $c (CHR ")")) + (i32.or (i32.eq $c (CHR "[")) + (i32.or (i32.eq $c (CHR "]")) + (i32.or (i32.eq $c (CHR "{")) + (i32.or (i32.eq $c (CHR "}")) + (i32.or (i32.eq $c (CHR " ")) + (i32.or (i32.eq $c (CHR ",")) + (i32.eq $c (CHR "\n")))))))))) + (br $done)))) + ;; read next character + ;;; token[token_index++] = str[(*index)++] + (i32.store8_u (i32.add (get_global $token) $token_index) + (i32.load8_u + (i32.add $str (get_global $read_index)))) + (set_local $token_index (i32.add $token_index 1)) + (set_global $read_index (i32.add (get_global $read_index) 1)) + ;;; if (token[0] == '~' && token[1] == '@') break + (if (i32.and (i32.eq (i32.load8_u (i32.add (get_global $token) 0)) + (CHR "~")) + (i32.eq (i32.load8_u (i32.add (get_global $token) 1)) + 0x40)) + (br $done)) + + ;;; if ((!instring) || escaped) + (if (i32.or (i32.eqz $instring) $escaped) + (then + (set_local $escaped 0) + (br $loop))) + (if (i32.eq $c (CHR "\\")) + (set_local $escaped 1)) + (if (i32.eq $c (CHR "\"")) + (br $done)) + (br $loop) + ) + ))) + + ;;; token[token_index] = '\0' + (i32.store8_u (i32.add (get_global $token) $token_index) 0) + (get_global $token) + ) + + (func $read_seq (param $str i32) (param $type i32) (param $end i32) + (result i32) + (local $res i32) + (local $val2 i32) + (local $val3 i32) + (local $c i32) + + ;; MAP_LOOP stack + (local $ret i32) + (local $empty i32) + (local $current i32) + + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + ;; READ_SEQ_LOOP + (block $done + (loop $loop + ($skip_spaces_comments $str) + + ;; peek at next character + ;;; c = str[*index] + (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (if (i32.eq $c (CHR "\x00")) + (then + ($THROW_STR_0 "unexpected EOF") + (br $done))) + (if (i32.eq $c $end) + (then + ;; read next character + ;;; c = str[(*index)++] + (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (set_global $read_index (i32.add (get_global $read_index) 1)) + (br $done))) + + ;; value (or key for hash-maps) + (set_local $val2 ($read_form $str)) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $val2) + (br $done))) + + ;; if this is a hash-map, READ_FORM again + (if (i32.eq $type (get_global $HASHMAP_T)) + (set_local $val3 ($read_form $str))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + (func $read_form (param $str i32) (result i32) + ;;($STRING (get_global $STRING_T) $str) + (local $tok i32) + (local $c0 i32) + (local $c1 i32) + (local $res i32) + + (if (get_global $error_type) (return 0)) + + (set_local $tok ($read_token $str)) +;; ($debug ">>> read_form 1:" $tok) + ;;; c0 = token[0] + (set_local $c0 (i32.load8_u $tok)) + (set_local $c1 (i32.load8_u (i32.add $tok 1))) + + (if (i32.eq $c0 0) + (then + (return ($INC_REF (get_global $NIL)))) + (else (if (i32.or (i32.and (i32.ge_u $c0 (CHR "0")) + (i32.le_u $c0 (CHR "9"))) + (i32.and (i32.eq $c0 (CHR "-")) + (i32.and (i32.ge_u $c1 (CHR "0")) + (i32.le_u $c1 (CHR "9"))))) + (then + (return ($INTEGER ($ATOI $tok)))) + (else (if (i32.eq $c0 (CHR ":")) + (then + (i32.store8_u $tok (CHR "\x7f")) + (return ($STRING (get_global $STRING_T) $tok))) + (else (if (i32.eq $c0 (CHR "\"")) + (then + ;; TODO: unescape + (i32.store8_u (i32.sub_u (i32.add $tok ($STRING_LEN $tok)) 1) + (CHR "\x00")) + (return ($STRING (get_global $STRING_T) (i32.add $tok 1)))) + (else (if (i32.eq $c0 (CHR "(")) + (then + (return ($read_seq $str (get_global $LIST_T) (CHR ")")))) + (else (if (i32.eq $c0 (CHR "[")) + (then + (return ($read_seq $str (get_global $VECTOR_T) (CHR "]")))) + (else (if (i32.eq $c0 (CHR "{")) + (then + (return ($read_seq $str (get_global $HASHMAP_T) (CHR "}")))) + (else (if (i32.or (i32.eq $c0 (CHR ")")) + (i32.or (i32.eq $c0 (CHR "]")) + (i32.eq $c0 (CHR "}")))) + (then + ($THROW_STR_1 "unexpected '%c'" $c0) + (return 0)) + (else + (return ($STRING (get_global $SYMBOL_T) $tok)))))))))))))))))) + ) + + (func $read_str (param $str i32) (result i32) + (set_global $read_index 0) + ($read_form $str) + ) + + (export "read_str" (func $read_str)) + +) diff --git a/wasm/reader.wast b/wasm/reader.wast deleted file mode 100644 index 3b16df3acb..0000000000 --- a/wasm/reader.wast +++ /dev/null @@ -1,321 +0,0 @@ -(module $reader - - ;; TODO: global warning - (global $token (mut i32) (i32.const 0)) - (global $read_index (mut i32) (i32.const 0)) - - (func $skip_spaces (param $str i32) (result i32) - (local $found i32) - (local $c i32) - (set_local $found (i32.const 0)) - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - (block $done - (loop $loop - ;;; while (c == ' ' || c == ',' || c == '\n') - (if (i32.and (i32.and - (i32.ne (get_local $c) (CHAR " ")) - (i32.ne (get_local $c) (CHAR ","))) - (i32.ne (get_local $c) (CHAR "\n"))) - (br $done)) - (set_local $found (i32.const 1)) - ;;; c=str[++(*index)] - (set_global $read_index (i32.add (get_global $read_index) - (i32.const 1))) - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - (br $loop) - ) - ) -;; (call $debug (STRING ">>> skip_spaces:") (get_local $found)) - (get_local $found) - ) - - (func $skip_to_eol (param $str i32) (result i32) - (local $found i32) - (local $c i32) - (set_local $found (i32.const 0)) - (set_local $c (i32.load8_c (i32.add (get_local $str) - (get_global $read_index)))) - (if (i32.eq (get_local $c) (CHAR ";")) - (then - (set_local $found (i32.const 1)) - (block $done - (loop $loop - ;;; c=str[++(*index)] - (set_global $read_index (i32.add (get_global $read_index) - (i32.const 1))) - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - ;;; while (c != '\0' && c != '\n') - (if (i32.and (i32.ne (get_local $c) (CHAR "\x00")) - (i32.ne (get_local $c) (CHAR "\n"))) - (br $loop)) - ) - ))) -;; (call $debug (STRING ">>> skip_to_eol:") (get_local $found)) - (get_local $found) - ) - - (func $skip_spaces_comments (param $str i32) - (loop $loop - ;; skip spaces - (if (call $skip_spaces (get_local $str)) (br $loop)) - ;; skip comments - (if (call $skip_to_eol (get_local $str)) (br $loop)) - ) - ) - - (func $read_token (param $str i32) (result i32) - (local $token_index i32) - (local $instring i32) - (local $escaped i32) - (local $c i32) - (set_local $token_index (i32.const 0)) - (set_local $instring (i32.const 0)) - (set_local $escaped (i32.const 0)) - - (call $skip_spaces_comments (get_local $str)) - - ;; read first character - ;;; c=str[++(*index)] - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - (set_global $read_index (i32.add (get_global $read_index) - (i32.const 1))) - ;; read first character - ;;; token[token_index++] = c - (i32.store8_u (i32.add (get_global $token) (get_local $token_index)) - (get_local $c)) - (set_local $token_index (i32.add (get_local $token_index) - (i32.const 1))) - ;; single/double character token - (if (i32.or (i32.eq (get_local $c) (CHAR "(")) - (i32.or (i32.eq (get_local $c) (CHAR ")")) - (i32.or (i32.eq (get_local $c) (CHAR "[")) - (i32.or (i32.eq (get_local $c) (CHAR "]")) - (i32.or (i32.eq (get_local $c) (CHAR "{")) - (i32.or (i32.eq (get_local $c) (CHAR "}")) - (i32.or (i32.eq (get_local $c) (CHAR "'")) - (i32.or (i32.eq (get_local $c) (CHAR "`")) - (i32.or (i32.eq (get_local $c) (CHAR "@")) - (i32.and (i32.eq (get_local $c) (CHAR "~")) - (i32.eq (i32.load8_u (i32.add (get_local $str) - (get_global $read_index))) - (CHAR "@")))))))))))) - - (then - ;; continue - (nop)) - (else - ;;; if (c == '"') instring = true - (set_local $instring (i32.eq (get_local $c) (CHAR "\""))) - (block $done - (loop $loop - ;; peek at next character - ;;; c = str[*index] - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - ;;; if (c == '\0') break - (if (i32.eq (get_local $c) (i32.const 0)) (br $done)) - ;;; if (!instring) - (if (i32.eqz (get_local $instring)) - (then - ;; next character is token delimiter - (if (i32.or (i32.eq (get_local $c) (CHAR "(")) - (i32.or (i32.eq (get_local $c) (CHAR ")")) - (i32.or (i32.eq (get_local $c) (CHAR "[")) - (i32.or (i32.eq (get_local $c) (CHAR "]")) - (i32.or (i32.eq (get_local $c) (CHAR "{")) - (i32.or (i32.eq (get_local $c) (CHAR "}")) - (i32.or (i32.eq (get_local $c) (CHAR " ")) - (i32.or (i32.eq (get_local $c) (CHAR ",")) - (i32.eq (get_local $c) (CHAR "\n")))))))))) - (br $done)))) - ;; read next character - ;;; token[token_index++] = str[(*index)++] - (i32.store8_u (i32.add (get_global $token) - (get_local $token_index)) - (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - (set_local $token_index (i32.add (get_local $token_index) - (i32.const 1))) - (set_global $read_index (i32.add (get_global $read_index) - (i32.const 1))) - ;;; if (token[0] == '~' && token[1] == '@') break - (if (i32.and (i32.eq (i32.load8_u (i32.add (get_global $token) - (i32.const 0))) - (CHAR "~")) - (i32.eq (i32.load8_u (i32.add (get_global $token) - (i32.const 1))) - (i32.const 0x40))) - (br $done)) - - ;;; if ((!instring) || escaped) - (if (i32.or (i32.eqz (get_local $instring)) - (get_local $escaped)) - (then - (set_local $escaped (i32.const 0)) - (br $loop))) - (if (i32.eq (get_local $c) (CHAR "\\")) - (set_local $escaped (i32.const 1))) - (if (i32.eq (get_local $c) (CHAR "\"")) - (br $done)) - (br $loop) - ) - ))) - - ;;; token[token_index] = '\0' - (i32.store8_u (i32.add (get_global $token) (get_local $token_index)) - (i32.const 0)) - (get_global $token) - ) - - (func $read_seq (param $str i32) (param $type i32) (param $end i32) - (result i32) - (local $res i32) - (local $val2 i32) - (local $val3 i32) - (local $c i32) - - ;; MAP_LOOP stack - (local $ret i32) - (local $empty i32) - (local $current i32) - - ;; MAP_LOOP_START - (set_local $res (call $MAP_LOOP_START (get_local $type))) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret (get_local $res)) - (set_local $current (get_local $res)) - (set_local $empty (get_local $res)) - - ;; READ_SEQ_LOOP - (block $done - (loop $loop - (call $skip_spaces_comments (get_local $str)) - - ;; peek at next character - ;;; c = str[*index] - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - (if (i32.eq (get_local $c) (CHAR "\x00")) - (then - (call $THROW_STR_0 (STRING "unexpected EOF")) - (br $done))) - (if (i32.eq (get_local $c) (get_local $end)) - (then - ;; read next character - ;;; c = str[(*index)++] - (set_local $c (i32.load8_u (i32.add (get_local $str) - (get_global $read_index)))) - (set_global $read_index (i32.add (get_global $read_index) - (i32.const 1))) - (br $done))) - - ;; value (or key for hash-maps) - (set_local $val2 (call $read_form (get_local $str))) - - ;; if error, release the unattached element - (if (get_global $error_type) - (then - (call $RELEASE (get_local $val2)) - (br $done))) - - ;; if this is a hash-map, READ_FORM again - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (set_local $val3 (call $read_form (get_local $str)))) - - ;; update the return sequence structure - ;; MAP_LOOP_UPDATE - (set_local $res (call $MAP_LOOP_UPDATE (get_local $type) - (get_local $empty) (get_local $current) - (get_local $val2) (get_local $val3))) - (if (i32.le_u (get_local $current) (get_global $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (set_local $ret (get_local $res))) - ;; update current to point to new element - (set_local $current (get_local $res)) - - (br $loop) - ) - ) - - ;; MAP_LOOP_DONE - (get_local $ret) - ) - - (func $read_form (param $str i32) (result i32) - ;;(call $STRING (get_global $STRING_T) (get_local $str)) - (local $tok i32) - (local $c0 i32) - (local $c1 i32) - (local $res i32) - - (if (get_global $error_type) (return (i32.const 0))) - - (set_local $tok (call $read_token (get_local $str))) -;; (call $debug (STRING ">>> read_form 1:") (get_local $tok)) - ;;; c0 = token[0] - (set_local $c0 (i32.load8_u (get_local $tok))) - (set_local $c1 (i32.load8_u (i32.add (get_local $tok) (i32.const 1)))) - - (if (i32.eq (get_local $c0) (i32.const 0)) - (then - (return (call $INC_REF (get_global $NIL)))) - (else (if (i32.or - (i32.and - (i32.ge_u (get_local $c0) (CHAR "0")) - (i32.le_u (get_local $c0) (CHAR "9"))) - (i32.and - (i32.eq (get_local $c0) (CHAR "-")) - (i32.and (i32.ge_u (get_local $c1) (CHAR "0")) - (i32.le_u (get_local $c1) (CHAR "9"))))) - (then - (return (call $INTEGER (call $ATOI (get_local $tok))))) - (else (if (i32.eq (get_local $c0) (CHAR ":")) - (then - (i32.store8_u (get_local $tok) (CHAR "\x7f")) - (return (call $STRING (get_global $STRING_T) (get_local $tok)))) - (else (if (i32.eq (get_local $c0) (CHAR "\"")) - (then - ;; TODO: unescape - (i32.store8_u (i32.sub_u - (i32.add (get_local $tok) - (call $STRING_LEN (get_local $tok))) - (i32.const 1)) - (CHAR "\x00")) - (return (call $STRING (get_global $STRING_T) (i32.add (get_local $tok) - (i32.const 1))))) - (else (if (i32.eq (get_local $c0) (CHAR "(")) - (then - (return (call $read_seq (get_local $str) - (get_global $LIST_T) (CHAR ")")))) - (else (if (i32.eq (get_local $c0) (CHAR "[")) - (then - (return (call $read_seq (get_local $str) - (get_global $VECTOR_T) (CHAR "]")))) - (else (if (i32.eq (get_local $c0) (CHAR "{")) - (then - (return (call $read_seq (get_local $str) - (get_global $HASHMAP_T) (CHAR "}")))) - (else (if (i32.or (i32.eq (get_local $c0) (CHAR ")")) - (i32.or (i32.eq (get_local $c0) (CHAR "]")) - (i32.eq (get_local $c0) (CHAR "}")))) - (then - (call $THROW_STR_1 (STRING "unexpected '%c'") (get_local $c0)) - (return (i32.const 0))) - (else - (return (call $STRING (get_global $SYMBOL_T) - (get_local $tok))))))))))))))))))) - ) - - (func $read_str (param $str i32) (result i32) - (set_global $read_index (i32.const 0)) - (call $read_form (get_local $str)) - ) - - (export "read_str" (func $read_str)) - -) diff --git a/wasm/step0_repl.wast b/wasm/step0_repl.wam similarity index 52% rename from wasm/step0_repl.wast rename to wasm/step0_repl.wam index 652bb560cd..fd663b607c 100644 --- a/wasm/step0_repl.wast +++ b/wasm/step0_repl.wam @@ -2,20 +2,24 @@ (import "env" "memory" (memory $0 256)) (import "env" "memoryBase" (global $memoryBase i32)) + ;; READ (func $READ (param $str i32) (result i32) - (get_local $str)) + $str + ) (func $EVAL (param $ast i32) (param $env i32) (result i32) - (get_local $ast)) + $ast + ) + ;; PRINT (func $PRINT (param $ast i32) (result i32) - (get_local $ast)) + $ast + ) - (func $rep (param $str i32) (result i32) - (call $PRINT - (call $EVAL - (call $READ (get_local $str)) - (i32.const 0)))) + ;; REPL + (func $rep (param $line i32) (result i32) + ($PRINT ($EVAL ($READ $line) 0)) + ) (func $main (result i32) ;; Constant location/value definitions @@ -24,14 +28,14 @@ ;; Start (block $repl_done (loop $repl_loop - (set_local $line (call $readline (STRING "user> "))) - (if (i32.eqz (get_local $line)) (br $repl_done)) - (call $printf_1 (STRING "%s\n") (call $rep (get_local $line))) - (call $free (get_local $line)) + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + ($printf_1 "%s\n" ($rep $line)) + ($free $line) (br $repl_loop))) - (call $print (STRING "\n")) - (i32.const 0) + ($print "\n") + 0 ) diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam new file mode 100644 index 0000000000..2253021df1 --- /dev/null +++ b/wasm/step1_read_print.wam @@ -0,0 +1,88 @@ +(module $step1_read_print + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL (param $ast i32) (param $env i32) (result i32) + $ast + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast) + ) + + ;; REPL + (func $rep (param $line i32) (param $env i32) (result i32) + (local $mv1 i32) + (local $mv2 i32) + (local $ms i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $mv2 ($EVAL $mv1 $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + +;; ($PR_MEMORY -1 -1) + ($RELEASE $mv1) + $ms + ) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + (local $res i32) + + ;; DEBUG + ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) + ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) + ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + ($PR_MEMORY -1 -1) +;; ($PR_MEMORY_RAW (get_global $mem) +;; (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) +;; 8))) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($rep $line 0)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step1_read_print.wast b/wasm/step1_read_print.wast deleted file mode 100644 index 51fcb41ac4..0000000000 --- a/wasm/step1_read_print.wast +++ /dev/null @@ -1,81 +0,0 @@ -(module $step1_read_print - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) - - (func $READ (param $str i32) (result i32) - (call $read_str (get_local $str))) - - (func $EVAL (param $ast i32) (param $env i32) (result i32) - (get_local $ast)) - - (func $PRINT (param $ast i32) (result i32) - (call $pr_str (get_local $ast))) - - (func $rep (param $line i32) (param $env i32) (result i32) - (local $mv1 i32) - (local $mv2 i32) - (local $ms i32) - (block $rep_done - (set_local $mv1 (call $READ (get_local $line))) - (if (get_global $error_type) (br $rep_done)) - - (set_local $mv2 (call $EVAL (get_local $mv1) (get_local $env))) - (if (get_global $error_type) (br $rep_done)) - -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (set_local $ms (call $PRINT (get_local $mv2))) - ) - -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (call $RELEASE (get_local $mv1)) - (get_local $ms) - ) - - (func $main (result i32) - ;; Constant location/value definitions - (local $line i32) - (local $res i32) - - ;; DEBUG - (call $printf_1 (STRING "memoryBase: %d\n") (get_global $memoryBase)) - (call $printf_1 (STRING "heap_start: %d\n") (get_global $heap_start)) - (call $printf_1 (STRING "heap_end: %d\n") (get_global $heap_end)) - (call $printf_1 (STRING "mem: %d\n") (get_global $mem)) -;; (call $printf_1 (STRING "string_mem: %d\n") (get_global $string_mem)) - (call $PR_MEMORY (i32.const -1) (i32.const -1)) -;; (call $PR_MEMORY_RAW (get_global $mem) -;; (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) -;; (i32.const 8)))) - - ;; Start - (block $repl_done - (loop $repl_loop - (set_local $line (call $readline (STRING "user> "))) - (if (i32.eqz (get_local $line)) (br $repl_done)) - (if (i32.eq (i32.load8_u (get_local $line)) (i32.const 0)) - (then - (call $free (get_local $line)) - (br $repl_loop))) - (set_local $res (call $rep (get_local $line) (i32.const 0))) - (if (get_global $error_type) - (then - (call $printf_1 (STRING "Error: %s\n") (get_global $error_str)) - (set_global $error_type (i32.const 0))) - (else - (call $printf_1 (STRING "%s\n") (call $to_String (get_local $res))))) - (call $RELEASE (get_local $res)) -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (call $free (get_local $line)) - (br $repl_loop))) - - (call $print (STRING "\n")) - (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (i32.const 0) - ) - - - (export "_main" (func $main)) - (export "__post_instantiate" (func $init_memory)) -) - diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam new file mode 100644 index 0000000000..ca9a24a7ac --- /dev/null +++ b/wasm/step2_eval.wam @@ -0,0 +1,255 @@ +(module $step1_read_print + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $val2 i32) + (local $val3 i32) + (local $ret i32) + (local $empty i32) + (local $current i32) + (local $type i32) + (local $res2 i64) + (local $found i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res2 ($HASHMAP_GET $env $ast)) + (set_local $res (i32.wrap/i64 $res2)) + (set_local $found (i32.wrap/i64 (i64.shr_u $res2 + (i64.const 32)))) + (if (i32.eqz $found) + ($THROW_STR_1 "'%s' not found" + ($to_String $ast))) + (set_local $res ($INC_REF $res)) + + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) + (br $done)) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $ast)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (type $fnT (func (param i32) (result i32))) + + (table anyfunc + (elem + $add $subtract $multiply $divide)) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $f_args i32) + (local $f i32) + (local $args i32) + (local $type i32) + (local $ftype i32) + + (set_local $res 0) + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + (set_local $type ($TYPE $ast)) + + (if (get_global $error_type) (return 0)) + + (if (i32.ne $type (get_global $LIST_T)) + (return ($EVAL_AST $ast $env))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) + + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) (return $f_args)) + + ;; rest + (set_local $args ($MEM_VAL0_ptr $f_args)) + ;; value + (set_local $f ($MEM_VAL1_ptr $f_args)) + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $type) + (set_local $res 0))) + + ($RELEASE $f_args) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast) + ) + + ;; REPL + (func $rep (param $line i32) (param $env i32) (result i32) + (local $mv1 i32) + (local $mv2 i32) + (local $ms i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $mv2 ($EVAL $mv1 $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from MAL_READ and EVAL + ($RELEASE $mv2) + ($RELEASE $mv1) + $ms + ) + + (func $add (param $args i32) (result i32) + ($INTEGER + (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $subtract (param $args i32) (result i32) + ($INTEGER + (i32.sub_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $multiply (param $args i32) (result i32) + ($INTEGER + (i32.mul_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $divide (param $args i32) (result i32) + ($INTEGER + (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + (local $res i32) + (local $repl_env i32) + + ;; DEBUG + ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) + ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) + ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_local $repl_env ($HASHMAP)) + + (set_local $repl_env ($ASSOC1_S $repl_env "+" ($FUNCTION 0))) + (set_local $repl_env ($ASSOC1_S $repl_env "-" ($FUNCTION 1))) + (set_local $repl_env ($ASSOC1_S $repl_env "*" ($FUNCTION 2))) + (set_local $repl_env ($ASSOC1_S $repl_env "/" ($FUNCTION 3))) + + ($PR_MEMORY -1 -1) +;; ($PR_MEMORY_RAW (get_global $mem) +;; (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) +;; 8))) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($rep $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step2_eval.wast b/wasm/step2_eval.wast deleted file mode 100644 index ac30da431c..0000000000 --- a/wasm/step2_eval.wast +++ /dev/null @@ -1,269 +0,0 @@ -(module $step1_read_print - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) - - ;; READ - (func $READ (param $str i32) (result i32) - (call $read_str (get_local $str)) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) - (local $res i32) - (local $val2 i32) - (local $val3 i32) - (local $ret i32) - (local $empty i32) - (local $current i32) - (local $type i32) - (local $res2 i64) - (local $found i32) - - (if (get_global $error_type) (return (i32.const 0))) - (set_local $type (call $TYPE (get_local $ast))) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 (get_local $type))) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res2 (call $HASHMAP_GET (get_local $env) (get_local $ast))) - (set_local $res (i32.wrap/i64 (get_local $res2))) - (set_local $found (i32.wrap/i64 (i64.shr_u (get_local $res2) - (i64.const 32)))) - (if (i32.eqz (get_local $found)) - (call $THROW_STR_1 (STRING "'%s' not found") - (call $to_String (get_local $ast)))) - (set_local $res (call $INC_REF (get_local $res))) - - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (set_local $res (call $MAP_LOOP_START (get_local $type))) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret (get_local $res)) - (set_local $current (get_local $res)) - (set_local $empty (get_local $res)) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (if (i32.eq (call $VAL0 (get_local $ast)) (i32.const 0)) - (br $done)) - - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (then - (set_local $res (call $EVAL (call $MEM_VAL2_ptr (get_local $ast)) - (get_local $env)))) - (else - (set_local $res (call $EVAL (call $MEM_VAL1_ptr (get_local $ast)) - (get_local $env))))) - (set_local $val2 (get_local $res)) - - ;; if error, release the unattached element - (if (get_global $error_type) - (then - (call $RELEASE (get_local $res)) - (set_local $res (i32.const 0)) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (then - (set_local $val3 (get_local $val2)) - (set_local $val2 (call $MEM_VAL1_ptr (get_local $ast))) - (drop (call $INC_REF (get_local $ast))))) - - ;; MAP_LOOP_UPDATE - (set_local $res (call $MAP_LOOP_UPDATE (get_local $type) - (get_local $empty) (get_local $current) - (get_local $val2) (get_local $val3))) - (if (i32.le_u (get_local $current) (get_global $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (set_local $ret (get_local $res))) - ;; update current to point to new element - (set_local $current (get_local $res)) - - (set_local $ast (call $MEM_VAL0_ptr (get_local $ast))) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (set_local $res (get_local $ret)) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (set_local $res (call $INC_REF (get_local $ast))) - ) - - (get_local $res) - ) - - (type $fnT (func (param i32) (result i32))) - - (table anyfunc - (elem - $add $subtract $multiply $divide)) - - (func $EVAL (param $ast i32) (param $env i32) (result i32) - (local $res i32) - (local $f_args i32) - (local $f i32) - (local $args i32) - (local $type i32) - (local $ftype i32) - - (set_local $res (i32.const 0)) - (set_local $f_args (i32.const 0)) - (set_local $f (i32.const 0)) - (set_local $args (i32.const 0)) - (set_local $type (call $TYPE (get_local $ast))) - - (if (get_global $error_type) (return (i32.const 0))) - - (if (i32.ne (get_local $type) (get_global $LIST_T)) - (return (call $EVAL_AST (get_local $ast) (get_local $env)))) - - ;; APPLY_LIST - (if (call $EMPTY_Q (get_local $ast)) - (return (call $INC_REF (get_local $ast)))) - - ;; EVAL_INVOKE - (set_local $res (call $EVAL_AST (get_local $ast) (get_local $env))) - (set_local $f_args (get_local $res)) - - ;; if error, return f/args for release by caller - (if (get_global $error_type) (return (get_local $f_args))) - - ;; rest - (set_local $args (call $MEM_VAL0_ptr (get_local $f_args))) - ;; value - (set_local $f (call $MEM_VAL1_ptr (get_local $f_args))) - - (set_local $ftype (call $TYPE (get_local $f))) - (if (i32.eq (get_local $ftype) (get_global $FUNCTION_T)) - (then - (set_local $res (call_indirect (type $fnT) (get_local $args) - (call $VAL0 (get_local $f))))) - (else - (call $THROW_STR_1 (STRING "apply of non-function type: %d\n") - (get_local $type)) - (set_local $res (i32.const 0)))) - - (call $RELEASE (get_local $f_args)) - - (get_local $res) - ) - - (func $PRINT (param $ast i32) (result i32) - (call $pr_str (get_local $ast)) - ) - - ;; REPL - (func $rep (param $line i32) (param $env i32) (result i32) - (local $mv1 i32) - (local $mv2 i32) - (local $ms i32) - (block $rep_done - (set_local $mv1 (call $READ (get_local $line))) - (if (get_global $error_type) (br $rep_done)) - - (set_local $mv2 (call $EVAL (get_local $mv1) (get_local $env))) - (if (get_global $error_type) (br $rep_done)) - -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (set_local $ms (call $PRINT (get_local $mv2))) - ) - - ;; release memory from MAL_READ and EVAL - (call $RELEASE (get_local $mv2)) - (call $RELEASE (get_local $mv1)) - (get_local $ms) - ) - - (func $add (param $args i32) (result i32) - (call $INTEGER - (i32.add (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $subtract (param $args i32) (result i32) - (call $INTEGER - (i32.sub_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $multiply (param $args i32) (result i32) - (call $INTEGER - (i32.mul_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $divide (param $args i32) (result i32) - (call $INTEGER - (i32.div_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - - (func $main (result i32) - ;; Constant location/value definitions - (local $line i32) - (local $res i32) - (local $repl_env i32) - - ;; DEBUG - (call $printf_1 (STRING "memoryBase: %d\n") (get_global $memoryBase)) - (call $printf_1 (STRING "heap_start: %d\n") (get_global $heap_start)) - (call $printf_1 (STRING "heap_end: %d\n") (get_global $heap_end)) - (call $printf_1 (STRING "mem: %d\n") (get_global $mem)) -;; (call $printf_1 (STRING "string_mem: %d\n") (get_global $string_mem)) - - (set_local $repl_env (call $HASHMAP)) - - (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) - (STRING "+") (call $FUNCTION (i32.const 0)))) - (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) - (STRING "-") (call $FUNCTION (i32.const 1)))) - (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) - (STRING "*") (call $FUNCTION (i32.const 2)))) - (set_local $repl_env (call $ASSOC1_S (get_local $repl_env) - (STRING "/") (call $FUNCTION (i32.const 3)))) - - (call $PR_MEMORY (i32.const -1) (i32.const -1)) -;; (call $PR_MEMORY_RAW (get_global $mem) -;; (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) -;; (i32.const 8)))) - - ;; Start - (block $repl_done - (loop $repl_loop - (set_local $line (call $readline (STRING "user> "))) - (if (i32.eqz (get_local $line)) (br $repl_done)) - (if (i32.eq (i32.load8_u (get_local $line)) (i32.const 0)) - (then - (call $free (get_local $line)) - (br $repl_loop))) - (set_local $res (call $rep (get_local $line) (get_local $repl_env))) - (if (get_global $error_type) - (then - (call $printf_1 (STRING "Error: %s\n") (get_global $error_str)) - (set_global $error_type (i32.const 0))) - (else - (call $printf_1 (STRING "%s\n") (call $to_String (get_local $res))))) - (call $RELEASE (get_local $res)) -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (call $free (get_local $line)) - (br $repl_loop))) - - (call $print (STRING "\n")) - (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (i32.const 0) - ) - - - (export "_main" (func $main)) - (export "__post_instantiate" (func $init_memory)) -) - diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam new file mode 100644 index 0000000000..8044dff42e --- /dev/null +++ b/wasm/step3_env.wam @@ -0,0 +1,308 @@ +(module $step1_read_print + (import "env" "memory" (memory $0 256)) + (import "env" "memoryBase" (global $memoryBase i32)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $val2 i32) + (local $val3 i32) + (local $ret i32) + (local $empty i32) + (local $current i32) + (local $type i32) + (local $found i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) + (br $done)) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $ast)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (type $fnT (func (param i32) (result i32))) + + (table anyfunc + (elem + $add $subtract $multiply $divide)) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + (local $res i32) + (local $f_args i32) + (local $f i32) + (local $args i32) + (local $type i32) + (local $ftype i32) + (local $a0 i32) + (local $a0sym i32) + (local $a1 i32) + (local $a2 i32) + (local $let_env i32) + + (set_local $res 0) + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) (return 0)) + + (if (i32.ne $type (get_global $LIST_T)) + (return ($EVAL_AST $ast $env))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (return $res)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res))) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $let_env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) + $let_env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + (set_local $res ($EVAL $a2 $let_env)) + ;; EVAL_RETURN + ($RELEASE $let_env)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) (return $f_args)) + + ;; rest + (set_local $args ($MEM_VAL0_ptr $f_args)) + ;; value + (set_local $f ($MEM_VAL1_ptr $f_args)) + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $type) + (set_local $res 0))) + + ($RELEASE $f_args))))) + + $res + ) + + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast) + ) + + ;; REPL + (func $rep (param $line i32) (param $env i32) (result i32) + (local $mv1 i32) + (local $mv2 i32) + (local $ms i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $mv2 ($EVAL $mv1 $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from MAL_READ and EVAL + ($RELEASE $mv2) + ($RELEASE $mv1) + $ms + ) + + (func $add (param $args i32) (result i32) + ($INTEGER + (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $subtract (param $args i32) (result i32) + ($INTEGER + (i32.sub_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $multiply (param $args i32) (result i32) + ($INTEGER + (i32.mul_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $divide (param $args i32) (result i32) + ($INTEGER + (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $pr_memory (param $args i32) (result i32) + ($PR_MEMORY -1 -1) + ($INC_REF (get_global $NIL))) + + (func $main (result i32) + ;; Constant location/value definitions + (local $line i32) + (local $res i32) + (local $repl_env i32) + + ;; DEBUG + ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) + ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) + ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_local $repl_env ($ENV_NEW (get_global $NIL))) + + (drop ($ENV_SET_S $repl_env "+" ($FUNCTION 0))) + (drop ($ENV_SET_S $repl_env "-" ($FUNCTION 1))) + (drop ($ENV_SET_S $repl_env "*" ($FUNCTION 2))) + (drop ($ENV_SET_S $repl_env "/" ($FUNCTION 3))) + + ($PR_MEMORY -1 -1) +;; ($PR_MEMORY_RAW (get_global $mem) +;; (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) +;; 8))) + + ;; Start + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($rep $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step3_env.wast b/wasm/step3_env.wast deleted file mode 100644 index 21afa31cdf..0000000000 --- a/wasm/step3_env.wast +++ /dev/null @@ -1,329 +0,0 @@ -(module $step1_read_print - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) - - ;; READ - (func $READ (param $str i32) (result i32) - (call $read_str (get_local $str)) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) - (local $res i32) - (local $val2 i32) - (local $val3 i32) - (local $ret i32) - (local $empty i32) - (local $current i32) - (local $type i32) - (local $found i32) - - (if (get_global $error_type) (return (i32.const 0))) - (set_local $type (call $TYPE (get_local $ast))) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 (get_local $type))) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res (call $ENV_GET (get_local $env) (get_local $ast))) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (set_local $res (call $MAP_LOOP_START (get_local $type))) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret (get_local $res)) - (set_local $current (get_local $res)) - (set_local $empty (get_local $res)) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (if (i32.eq (call $VAL0 (get_local $ast)) (i32.const 0)) - (br $done)) - - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (then - (set_local $res (call $EVAL (call $MEM_VAL2_ptr (get_local $ast)) - (get_local $env)))) - (else - (set_local $res (call $EVAL (call $MEM_VAL1_ptr (get_local $ast)) - (get_local $env))))) - (set_local $val2 (get_local $res)) - - ;; if error, release the unattached element - (if (get_global $error_type) - (then - (call $RELEASE (get_local $res)) - (set_local $res (i32.const 0)) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (then - (set_local $val3 (get_local $val2)) - (set_local $val2 (call $MEM_VAL1_ptr (get_local $ast))) - (drop (call $INC_REF (get_local $ast))))) - - ;; MAP_LOOP_UPDATE - (set_local $res (call $MAP_LOOP_UPDATE (get_local $type) - (get_local $empty) (get_local $current) - (get_local $val2) (get_local $val3))) - (if (i32.le_u (get_local $current) (get_global $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (set_local $ret (get_local $res))) - ;; update current to point to new element - (set_local $current (get_local $res)) - - (set_local $ast (call $MEM_VAL0_ptr (get_local $ast))) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (set_local $res (get_local $ret)) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (set_local $res (call $INC_REF (get_local $ast))) - ) - - (get_local $res) - ) - - (type $fnT (func (param i32) (result i32))) - - (table anyfunc - (elem - $add $subtract $multiply $divide)) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - (call $MEM_VAL1_ptr (call $MEM_VAL0_ptr (get_local $ast)))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - (call $MEM_VAL1_ptr (call $MEM_VAL0_ptr (call $MEM_VAL0_ptr (get_local $ast))))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - (call $MEM_VAL1_ptr (call $MEM_VAL0_ptr (call $MEM_VAL0_ptr (call $MEM_VAL0_ptr (get_local $ast)))))) - - (func $EVAL (param $ast i32) (param $env i32) (result i32) - (local $res i32) - (local $f_args i32) - (local $f i32) - (local $args i32) - (local $type i32) - (local $ftype i32) - (local $a0 i32) - (local $a0sym i32) - (local $a1 i32) - (local $a2 i32) - (local $let_env i32) - - (set_local $res (i32.const 0)) - (set_local $f_args (i32.const 0)) - (set_local $f (i32.const 0)) - (set_local $args (i32.const 0)) - (set_local $type (call $TYPE (get_local $ast))) - - ;;(call $PR_VALUE (STRING ">>> EVAL ast: '%s'\n") (get_local $ast)) - - (if (get_global $error_type) (return (i32.const 0))) - - (if (i32.ne (get_local $type) (get_global $LIST_T)) - (return (call $EVAL_AST (get_local $ast) (get_local $env)))) - - ;; APPLY_LIST - (if (call $EMPTY_Q (get_local $ast)) - (return (call $INC_REF (get_local $ast)))) - - (set_local $a0 (call $MEM_VAL1_ptr (get_local $ast))) - (set_local $a0sym (STRING "")) - (if (i32.eq (call $TYPE (get_local $a0)) (get_global $SYMBOL_T)) - (set_local $a0sym (call $to_String (get_local $a0)))) - - (if (i32.eqz (call $strcmp (STRING "def!") (get_local $a0sym))) - (then - (set_local $a1 (call $MAL_GET_A1 (get_local $ast))) - (set_local $a2 (call $MAL_GET_A2 (get_local $ast))) - (set_local $res (call $EVAL (get_local $a2) (get_local $env))) - (if (get_global $error_type) (return (get_local $res))) - - ;; set a1 in env to a2 - (set_local $res (call $ENV_SET (get_local $env) - (get_local $a1) (get_local $res)))) - (else (if (i32.eqz (call $strcmp (STRING "let*") (get_local $a0sym))) - (then - (set_local $a1 (call $MAL_GET_A1 (get_local $ast))) - (set_local $a2 (call $MAL_GET_A2 (get_local $ast))) - - ;; create new environment with outer as current environment - (set_local $let_env (call $ENV_NEW (get_local $env))) - - (block $done - (loop $loop - (if (i32.eqz (call $VAL0 (get_local $a1))) - (br $done)) - ;; eval current A1 odd element - (set_local $res (call $EVAL (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr - (get_local $a1))) - (get_local $let_env))) - - (if (get_global $error_type) (br $done)) - - ;; set key/value in the let environment - (set_local $res (call $ENV_SET (get_local $let_env) - (call $MEM_VAL1_ptr (get_local $a1)) - (get_local $res))) - ;; release our use, ENV_SET took ownership - (call $RELEASE (get_local $res)) - - ;; skip to the next pair of a1 elements - (set_local $a1 (call $MEM_VAL0_ptr - (call $MEM_VAL0_ptr (get_local $a1)))) - (br $loop) - ) - ) - (set_local $res (call $EVAL (get_local $a2) (get_local $let_env))) - ;; EVAL_RETURN - (call $RELEASE (get_local $let_env))) - (else - ;; EVAL_INVOKE - (set_local $res (call $EVAL_AST (get_local $ast) (get_local $env))) - (set_local $f_args (get_local $res)) - - ;; if error, return f/args for release by caller - (if (get_global $error_type) (return (get_local $f_args))) - - ;; rest - (set_local $args (call $MEM_VAL0_ptr (get_local $f_args))) - ;; value - (set_local $f (call $MEM_VAL1_ptr (get_local $f_args))) - - (set_local $ftype (call $TYPE (get_local $f))) - (if (i32.eq (get_local $ftype) (get_global $FUNCTION_T)) - (then - (set_local $res (call_indirect (type $fnT) (get_local $args) - (call $VAL0 (get_local $f))))) - (else - (call $THROW_STR_1 (STRING "apply of non-function type: %d\n") - (get_local $type)) - (set_local $res (i32.const 0)))) - - (call $RELEASE (get_local $f_args)))))) - - (get_local $res) - ) - - (func $PRINT (param $ast i32) (result i32) - (call $pr_str (get_local $ast)) - ) - - ;; REPL - (func $rep (param $line i32) (param $env i32) (result i32) - (local $mv1 i32) - (local $mv2 i32) - (local $ms i32) - (block $rep_done - (set_local $mv1 (call $READ (get_local $line))) - (if (get_global $error_type) (br $rep_done)) - - (set_local $mv2 (call $EVAL (get_local $mv1) (get_local $env))) - (if (get_global $error_type) (br $rep_done)) - -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (set_local $ms (call $PRINT (get_local $mv2))) - ) - - ;; release memory from MAL_READ and EVAL - (call $RELEASE (get_local $mv2)) - (call $RELEASE (get_local $mv1)) - (get_local $ms) - ) - - (func $add (param $args i32) (result i32) - (call $INTEGER - (i32.add (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $subtract (param $args i32) (result i32) - (call $INTEGER - (i32.sub_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $multiply (param $args i32) (result i32) - (call $INTEGER - (i32.mul_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $divide (param $args i32) (result i32) - (call $INTEGER - (i32.div_s (call $VAL0 (call $MEM_VAL1_ptr (get_local $args))) - (call $VAL0 (call $MEM_VAL1_ptr - (call $MEM_VAL0_ptr (get_local $args))))))) - (func $pr_memory (param $args i32) (result i32) - (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (call $INC_REF (get_global $NIL))) - - (func $main (result i32) - ;; Constant location/value definitions - (local $line i32) - (local $res i32) - (local $repl_env i32) - - ;; DEBUG - (call $printf_1 (STRING "memoryBase: 0x%x\n") (get_global $memoryBase)) - (call $printf_1 (STRING "heap_start: 0x%x\n") (get_global $heap_start)) - (call $printf_1 (STRING "heap_end: 0x%x\n") (get_global $heap_end)) - (call $printf_1 (STRING "mem: 0x%x\n") (get_global $mem)) -;; (call $printf_1 (STRING "string_mem: %d\n") (get_global $string_mem)) - - (set_local $repl_env (call $ENV_NEW (get_global $NIL))) - - (drop (call $ENV_SET_S (get_local $repl_env) - (STRING "+") (call $FUNCTION (i32.const 0)))) - (drop (call $ENV_SET_S (get_local $repl_env) - (STRING "-") (call $FUNCTION (i32.const 1)))) - (drop (call $ENV_SET_S (get_local $repl_env) - (STRING "*") (call $FUNCTION (i32.const 2)))) - (drop (call $ENV_SET_S (get_local $repl_env) - (STRING "/") (call $FUNCTION (i32.const 3)))) - - (call $PR_MEMORY (i32.const -1) (i32.const -1)) -;; (call $PR_MEMORY_RAW (get_global $mem) -;; (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) -;; (i32.const 8)))) - - ;; Start - (block $repl_done - (loop $repl_loop - (set_local $line (call $readline (STRING "user> "))) - (if (i32.eqz (get_local $line)) (br $repl_done)) - (if (i32.eq (i32.load8_u (get_local $line)) (i32.const 0)) - (then - (call $free (get_local $line)) - (br $repl_loop))) - (set_local $res (call $rep (get_local $line) (get_local $repl_env))) - (if (get_global $error_type) - (then - (call $printf_1 (STRING "Error: %s\n") (get_global $error_str)) - (set_global $error_type (i32.const 0))) - (else - (call $printf_1 (STRING "%s\n") (call $to_String (get_local $res))))) - (call $RELEASE (get_local $res)) -;; (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (call $free (get_local $line)) - (br $repl_loop))) - - (call $print (STRING "\n")) - (call $PR_MEMORY (i32.const -1) (i32.const -1)) - (i32.const 0) - ) - - - (export "_main" (func $main)) - (export "__post_instantiate" (func $init_memory)) -) - diff --git a/wasm/types.wam b/wasm/types.wam new file mode 100644 index 0000000000..2e809534b9 --- /dev/null +++ b/wasm/types.wam @@ -0,0 +1,186 @@ +;; Mal value memory layout +;; type words +;; ---------- ---------- +;; nil ref/ 0 | 0 | | +;; false ref/ 1 | 0 | | +;; true ref/ 1 | 1 | | +;; integer ref/ 2 | int | | +;; float ref/ 3 | ??? | | +;; string/kw ref/ 4 | string ptr | | +;; symbol ref/ 5 | string ptr | | +;; list ref/ 6 | next mem idx | val mem idx | +;; vector ref/ 7 | next mem idx | val mem idx | +;; hashmap ref/ 8 | next mem idx | key mem idx | val mem idx +;; function ref/ 9 | fn idx | | +;; mal function ref/10 | body mem idx | param mem idx | env mem idx +;; macro fn ref/11 | body mem idx | param mem idx | env mem idx +;; atom ref/12 | val mem idx | | +;; environment ref/13 | hmap mem idx | outer mem idx | +;; metadata ref/14 | obj mem idx | meta mem idx | +;; FREE sz/15 | next mem idx | | + +(module $types + + (global $NIL_T i32 0) + (global $BOOLEAN_T i32 1) + (global $INTEGER_T i32 2) + (global $FLOAT_T i32 3) + (global $STRING_T i32 4) + (global $SYMBOL_T i32 5) + (global $LIST_T i32 6) + (global $VECTOR_T i32 7) + (global $HASHMAP_T i32 8) + (global $FUNCTION_T i32 9) + (global $MALFUNC_T i32 10) + (global $MACRO_T i32 11) + (global $ATOM_T i32 12) + (global $ENVIRONMENT_T i32 13) + (global $METADATA_T i32 14) + (global $FREE_T i32 15) + + (global $error_type (mut i32) 0) + (global $error_val (mut i32) 0) + ;; Index into static string memory (static.wast) + (global $error_str (mut i32) 0) + + (global $NIL (mut i32) 0) + (global $FALSE (mut i32) 0) + (global $TRUE (mut i32) 0) + (global $EMPTY_LIST (mut i32) 0) + (global $EMPTY_VECTOR (mut i32) 0) + (global $EMPTY_HASHMAP (mut i32) 0) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General functions + + (func $INC_REF (param $mv i32) (result i32) + (i32.store $mv (i32.add (i32.load $mv) 32)) + $mv) + + (func $THROW_STR_0 (param $fmt i32) + (drop ($sprintf_1 (get_global $error_str) $fmt "")) + (set_global $error_type 1)) + + (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) + (drop ($sprintf_1 (get_global $error_str) $fmt $v0)) + (set_global $error_type 1)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; numeric functions + + (func $INTEGER (param $val i32) (result i32) + ($ALLOC_SCALAR (get_global $INTEGER_T) $val)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; sequence functions + + (func $MAP_LOOP_START (param $type i32) (result i32) + (local $res i32) + (set_local $res (if i32 (i32.eq $type (get_global $LIST_T)) + (get_global $EMPTY_LIST) + (else (if i32 (i32.eq $type (get_global $VECTOR_T)) + (get_global $EMPTY_VECTOR) + (else (if i32 (i32.eq $type (get_global $HASHMAP_T)) + (get_global $EMPTY_HASHMAP) + (else + ($THROW_STR_1 "read_seq invalid type %d" $type) + 0))))))) + + ($INC_REF $res) + ) + + (func $MAP_LOOP_UPDATE (param $type i32) (param $empty i32) + (param $current i32) (param $val2 i32) (param $val3 i32) + (result i32) + (local $res i32) + + (set_local $res ($ALLOC $type $empty $val2 $val3)) + ;; sequence took ownership + ($RELEASE $empty) + ($RELEASE $val2) + (if (i32.eq $type (get_global $HASHMAP_T)) + ($RELEASE $val3)) + (if (i32.gt_u $current (get_global $EMPTY_HASHMAP)) + ;; if not first element, set current next to point to new element + (i32.store ($VAL0_ptr $current) ($MalVal_index $res))) + + $res + ) + + (func $EMPTY_Q (param $mv i32) (result i32) + (i32.eq ($VAL0 $mv) 0) + ) + + (func $HASHMAP (result i32) + ;; just point to static empty hash-map + ($INC_REF (get_global $EMPTY_HASHMAP)) + ) + + (func $ASSOC1 (param $hm i32) (param $k i32) (param $v i32) (result i32) + (local $res i32) + (set_local $res ($ALLOC (get_global $HASHMAP_T) $hm $k $v)) + ;; we took ownership of previous release + ($RELEASE $hm) + $res + ) + + (func $ASSOC1_S (param $hm i32) (param $k i32) (param $v i32) (result i32) + (local $kmv i32) + (local $res i32) + (set_local $kmv ($STRING (get_global $STRING_T) $k)) + (set_local $res ($ASSOC1 $hm $kmv $v)) + ;; map took ownership of key + ($RELEASE $kmv) + $res + ) + + (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) + (local $res i32) + (local $found i32) + (local $key i32) + (local $test_key_mv i32) + + (set_local $key ($to_String $key_mv)) + (set_local $found 0) + + + (block $done + (loop $loop + ;;; if (VAL0(hm) == 0) + (if (i32.eq ($VAL0 $hm) 0) + (then + (set_local $res (get_global $NIL)) + (br $done))) + ;;; test_key_mv = MEM_VAL1(hm) + (set_local $test_key_mv ($MEM_VAL1_ptr $hm)) + ;;; if (strcmp(key, to_String(test_key_mv)) == 0) + (if (i32.eq ($strcmp $key ($to_String $test_key_mv)) 0) + (then + (set_local $found 1) + (set_local $res ($MEM_VAL2_ptr $hm)) + (br $done))) + (set_local $hm ($MEM_VAL0_ptr $hm)) + + (br $loop) + ) + ) + + ;; combine found/res as hi 32/low 32 of i64 + (i64.or (i64.shl_u (i64.extend_u/i32 $found) (i64.const 32)) + (i64.extend_u/i32 $res)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; function functions + + (func $FUNCTION (param $index i32) (result i32) + ($ALLOC_SCALAR (get_global $FUNCTION_T) $index) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; string functions + + (func $to_String (param $mv i32) (result i32) + ;; skip string refcnt + (i32.add 4 ($MalVal_val ($MalVal_index $mv) 0))) +) diff --git a/wasm/types.wast b/wasm/types.wast deleted file mode 100644 index cd1212c167..0000000000 --- a/wasm/types.wast +++ /dev/null @@ -1,202 +0,0 @@ -;; Mal value memory layout -;; type words -;; ---------- ---------- -;; nil ref/ 0 | 0 | | -;; false ref/ 1 | 0 | | -;; true ref/ 1 | 1 | | -;; integer ref/ 2 | int | | -;; float ref/ 3 | ??? | | -;; string/kw ref/ 4 | string ptr | | -;; symbol ref/ 5 | string ptr | | -;; list ref/ 6 | next mem idx | val mem idx | -;; vector ref/ 7 | next mem idx | val mem idx | -;; hashmap ref/ 8 | next mem idx | key mem idx | val mem idx -;; function ref/ 9 | fn idx | | -;; mal function ref/10 | body mem idx | param mem idx | env mem idx -;; macro fn ref/11 | body mem idx | param mem idx | env mem idx -;; atom ref/12 | val mem idx | | -;; environment ref/13 | hmap mem idx | outer mem idx | -;; metadata ref/14 | obj mem idx | meta mem idx | -;; FREE sz/15 | next mem idx | | - -(module $types - - (global $NIL_T i32 (i32.const 0)) - (global $BOOLEAN_T i32 (i32.const 1)) - (global $INTEGER_T i32 (i32.const 2)) - (global $FLOAT_T i32 (i32.const 3)) - (global $STRING_T i32 (i32.const 4)) - (global $SYMBOL_T i32 (i32.const 5)) - (global $LIST_T i32 (i32.const 6)) - (global $VECTOR_T i32 (i32.const 7)) - (global $HASHMAP_T i32 (i32.const 8)) - (global $FUNCTION_T i32 (i32.const 9)) - (global $MALFUNC_T i32 (i32.const 10)) - (global $MACRO_T i32 (i32.const 11)) - (global $ATOM_T i32 (i32.const 12)) - (global $ENVIRONMENT_T i32 (i32.const 13)) - (global $METADATA_T i32 (i32.const 14)) - (global $FREE_T i32 (i32.const 15)) - - (global $error_type (mut i32) (i32.const 0)) - (global $error_val (mut i32) (i32.const 0)) - ;; Index into static string memory (static.wast) - (global $error_str (mut i32) (i32.const 0)) - - (global $NIL (mut i32) (i32.const 0)) - (global $FALSE (mut i32) (i32.const 0)) - (global $TRUE (mut i32) (i32.const 0)) - (global $EMPTY_LIST (mut i32) (i32.const 0)) - (global $EMPTY_VECTOR (mut i32) (i32.const 0)) - (global $EMPTY_HASHMAP (mut i32) (i32.const 0)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; General functions - - (func $INC_REF (param $mv i32) (result i32) - (i32.store (get_local $mv) - (i32.add (i32.load (get_local $mv)) - (i32.const 32))) - (get_local $mv)) - - (func $THROW_STR_0 (param $fmt i32) - (drop (call $sprintf_1 (get_global $error_str) (get_local $fmt) (STRING ""))) - (set_global $error_type (i32.const 1))) - - (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) - (drop (call $sprintf_1 (get_global $error_str) (get_local $fmt) (get_local $v0))) - (set_global $error_type (i32.const 1))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; numeric functions - - (func $INTEGER (param $val i32) (result i32) - (call $ALLOC_SCALAR (get_global $INTEGER_T) (get_local $val))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; sequence functions - - (func $MAP_LOOP_START (param $type i32) (result i32) - (local $res i32) - (set_local $res (if i32 (i32.eq (get_local $type) - (get_global $LIST_T)) - (get_global $EMPTY_LIST) - (else (if i32 (i32.eq (get_local $type) - (get_global $VECTOR_T)) - (get_global $EMPTY_VECTOR) - (else (if i32 (i32.eq (get_local $type) - (get_global $HASHMAP_T)) - (get_global $EMPTY_HASHMAP) - (else - (call $THROW_STR_1 (STRING "read_seq invalid type %d") - (get_local $type)) - (i32.const 0)))))))) - - (call $INC_REF (get_local $res)) - ) - - (func $MAP_LOOP_UPDATE (param $type i32) (param $empty i32) - (param $current i32) (param $val2 i32) (param $val3 i32) - (result i32) - (local $res i32) - - (set_local $res (call $ALLOC (get_local $type) (get_local $empty) - (get_local $val2) (get_local $val3))) - ;; sequence took ownership - (call $RELEASE (get_local $empty)) - (call $RELEASE (get_local $val2)) - (if (i32.eq (get_local $type) (get_global $HASHMAP_T)) - (call $RELEASE (get_local $val3))) - (if (i32.gt_u (get_local $current) (get_global $EMPTY_HASHMAP)) - ;; if not first element, set current next to point to new element - (i32.store (call $VAL0_ptr (get_local $current)) - (call $MalVal_index (get_local $res)))) - - (get_local $res) - ) - - (func $EMPTY_Q (param $mv i32) (result i32) - (i32.eq (call $VAL0 (get_local $mv)) (i32.const 0)) - ) - - (func $HASHMAP (result i32) - ;; just point to static empty hash-map - (call $INC_REF (get_global $EMPTY_HASHMAP)) - ) - - (func $ASSOC1 (param $hm i32) (param $k i32) (param $v i32) (result i32) - (local $res i32) - (set_local $res (call $ALLOC (get_global $HASHMAP_T) (get_local $hm) - (get_local $k) (get_local $v))) - ;; we took ownership of previous release - (call $RELEASE (get_local $hm)) - (get_local $res) - ) - - (func $ASSOC1_S (param $hm i32) (param $k i32) (param $v i32) (result i32) - (local $kmv i32) - (local $res i32) - (set_local $kmv (call $STRING (get_global $STRING_T) (get_local $k))) - (set_local $res (call $ASSOC1 (get_local $hm) - (get_local $kmv) (get_local $v))) - ;; map took ownership of key - (call $RELEASE (get_local $kmv)) - (get_local $res) - ) - - (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) - (local $res i32) - (local $found i32) - (local $key i32) - (local $test_key_mv i32) - - (set_local $key (call $to_String (get_local $key_mv))) - (set_local $found (i32.const 0)) - - - (block $done - (loop $loop - ;;; if (VAL0(hm) == 0) - (if (i32.eq (call $VAL0 (get_local $hm)) (i32.const 0)) - (then - (set_local $res (get_global $NIL)) - (br $done))) - ;;; test_key_mv = MEM_VAL1(hm) - (set_local $test_key_mv (call $MEM_VAL1_ptr (get_local $hm))) - ;;; if (strcmp(key, to_String(test_key_mv)) == 0) - (if (i32.eq (call $strcmp (get_local $key) - (call $to_String (get_local $test_key_mv))) - (i32.const 0)) - (then - (set_local $found (i32.const 1)) - (set_local $res (call $MEM_VAL2_ptr (get_local $hm))) - (br $done))) - (set_local $hm (call $MEM_VAL0_ptr (get_local $hm))) - - (br $loop) - ) - ) - - ;; combine found/res as hi 32/low 32 of i64 - (i64.or - (i64.shl_u (i64.extend_u/i32 (get_local $found)) - (i64.const 32)) - (i64.extend_u/i32 (get_local $res))) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; function functions - - (func $FUNCTION (param $index i32) (result i32) - (call $ALLOC_SCALAR (get_global $FUNCTION_T) (get_local $index)) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; string functions - - (func $to_String (param $mv i32) (result i32) - (i32.add (i32.const 4) ;; skip string refcnt - (call $MalVal_val - (call $MalVal_index (get_local $mv)) - (i32.const 0)))) -) diff --git a/wasm/util.wam b/wasm/util.wam new file mode 100644 index 0000000000..e663d4adb0 --- /dev/null +++ b/wasm/util.wam @@ -0,0 +1,254 @@ +(module $util + (import "env" "malloc" (func $malloc (param i32) (result i32))) + (import "env" "free" (func $free (param i32))) + (import "env" "exit" (func $exit (param i32))) + + (import "env" "stdout" (global $stdout i32)) + (import "env" "putchar" (func $putchar (param i32) (result i32))) + (import "env" "fputs" (func $fputs (param i32 i32) (result i32))) + ;;(import "env" "readline" (func $readline (param i32) (result i32))) + (import "libedit.so" "readline" (func $readline (param i32) (result i32))) + ;;(import "libreadline.so" "readline" (func $readline (param i32) (result i32))) + + (global $sprintf_buf (mut i32) 0) + + (func $init_sprintf_mem + ;; 256 character sprintf static buffer + (set_global $sprintf_buf " ") + ) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Copy len chatacters from src to dst + ;; Returns len + (func $MEM_COPY (param $dst i32) (param $src i32) (param $len i32) + (local $idx i32) + (set_local $idx 0) + (loop $copy + (i32.store8_u (i32.add $idx $dst) + (i32.load8_u (i32.add $idx $src))) + (set_local $idx (i32.add 1 $idx)) + (br_if $copy (i32.lt_u $idx $len)) + ) + ) + + (func $STRING_LEN (param $str i32) (result i32) + (local $cur i32) + (set_local $cur $str) + (loop $count + (if (i32.ne 0 (i32.load8_u $cur)) + (then + (set_local $cur (i32.add $cur 1)) + (br $count))) + ) + (i32.sub_u $cur $str) + ) + + (func $ATOI (param $str i32) (result i32) + (local $acc i32) + (local $i i32) + (local $neg i32) + (local $ch i32) + (set_local $acc 0) + (set_local $i 0) + (set_local $neg 0) + (block $done + (loop $loop + (set_local $ch (i32.load8_u (i32.add $str $i))) + (if (i32.and (i32.ne $ch (CHR "-")) + (i32.or (i32.lt_u $ch (CHR "0")) + (i32.gt_u $ch (CHR "9")))) + (br $done)) + (set_local $i (i32.add $i 1)) + (if (i32.eq $ch (CHR "-")) + (then + (set_local $neg 1)) + (else + (set_local $acc (i32.add (i32.mul_u $acc 10) + (i32.sub_u $ch (CHR "0")))))) + (br $loop) + ) + ) + (if i32 $neg + (then (i32.sub_s 0 $acc)) + (else $acc)) + ) + + (func $strcmp (param $s1 i32) (param $s2 i32) (result i32) + (block $done + (loop $loop + (if (i32.or (i32.eqz (i32.load8_u $s1)) + (i32.eqz (i32.load8_u $s2))) + (br $done)) + (if (i32.ne (i32.load8_u $s1) + (i32.load8_u $s2)) + (br $done)) + (set_local $s1 (i32.add $s1 1)) + (set_local $s2 (i32.add $s2 1)) + (br $loop) + ) + ) + (if i32 (i32.eq (i32.load8_u $s1) + (i32.load8_u $s2)) + (then 0) + (else + (if i32 (i32.lt_u (i32.load8_u $s1) + (i32.load8_u $s2)) + (then -1) + (else 1)))) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $print (param $addr i32) + (drop ($fputs $addr (get_global $stdout)))) + + (func $printf_1 (param $fmt i32) + (param $v0 i32) + (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 0 0 0 0 0)) + ($print (get_global $sprintf_buf)) + ) + + (func $printf_2 (param $fmt i32) + (param $v0 i32) (param $v1 i32) + (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 0 0 0 0)) + ($print (get_global $sprintf_buf)) + ) + + (func $printf_3 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 0 0 0)) + ($print (get_global $sprintf_buf)) + ) + + (func $printf_4 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) + (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) + ($print (get_global $sprintf_buf)) + ) + + (func $printf_5 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) + (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) + ($print (get_global $sprintf_buf)) + ) + + (func $printf_6 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) (param $v5 i32) + (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) + ($print (get_global $sprintf_buf)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) + (local $n i32) + (local $ch i32) + (set_local $n (i32.rem_u $num $base)) + (set_local $ch (if (result i32) (i32.lt_u $n 10) + 48 + 55)) + (i32.store8_u $str (i32.add $n $ch)) + ) + + ;; TODO: switch to snprint* (add buffer len) + (func $_sprintnum (param $str i32) (param $num i32) (param $base i32) + (result i32) + (if (i32.and (i32.eq $base 10) + (i32.lt_s $num 0)) + (then + ;; Print '-' if negative + (i32.store8_u $str (CHR "-")) + (set_local $str (i32.add $str 1)) + ;; Reverse the sign + (set_local $num (i32.sub_s 0 $num)))) + (if (i32.gt_u (i32.div_u $num $base) 0) + (set_local + $str + ($_sprintnum $str (i32.div_u $num $base) $base))) + ($_sprintdigit $str $num $base) + (i32.add 1 $str) + ) + + ;; TODO: switch to snprint* (add buffer len) + (func $sprintf_1 (param $str i32) (param $fmt i32) + (param $v0 i32) (result i32) + ($sprintf_6 $str $fmt $v0 0 0 0 0 0) + ) + + (func $sprintf_6 (param $str i32) (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) (param $v5 i32) + (result i32) + (local $ch i32) + (local $pstr i32) + (local $v i32) + (local $vidx i32) + (local $len i32) + (set_local $pstr $str) + (set_local $vidx 0) + + (block $done + (loop $loop + (block $after_v + (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 0 $vidx)) + (; 0 ;) (set_local $v $v0) (br $after_v)) + (; 1 ;) (set_local $v $v1) (br $after_v)) + (; 2 ;) (set_local $v $v2) (br $after_v)) + (; 3 ;) (set_local $v $v3) (br $after_v)) + (; 4 ;) (set_local $v $v4) (br $after_v)) + (; 5 ;) (set_local $v $v5) (br $after_v) + ) + + ;;; while ((ch=*(fmt++))) + (set_local $ch (i32.load8_u $fmt)) + (set_local $fmt (i32.add 1 $fmt)) + (if (i32.eqz $ch) (br $done)) + ;; TODO: check buffer length + + (if (i32.ne $ch (CHR "%")) + (then + ;; TODO: check buffer length + (i32.store8_u $pstr $ch) + (set_local $pstr (i32.add 1 $pstr)) + (br $loop))) + + ;;; ch=*(fmt++) + (set_local $ch (i32.load8_u $fmt)) + (set_local $fmt (i32.add 1 $fmt)) + + (if (i32.eq (CHR "d") $ch) + (then + (set_local $pstr ($_sprintnum $pstr $v 10))) + (else (if (i32.eq (CHR "x") $ch) + (then + (set_local $pstr ($_sprintnum $pstr $v 10))) + (else (if (i32.eq (CHR "s") $ch) + (then + (set_local $len ($STRING_LEN $v)) + ($MEM_COPY $pstr $v $len) + (set_local $pstr (i32.add $pstr $len))) + (else (if (i32.eq (CHR "c") $ch) + (then + (i32.store8_u $pstr $v) + (set_local $pstr (i32.add $pstr 1))) + (else + ($print "Illegal format character: ") + (drop ($putchar $ch)) + (drop ($putchar (CHR "\n"))) + ($exit 3))))))))) + + (set_local $vidx (i32.add 1 $vidx)) + (br $loop) + ) + ) + + (i32.store8_u $pstr (CHR "\x00")) + $pstr + ) + +) + diff --git a/wasm/util.wast b/wasm/util.wast deleted file mode 100644 index acbe12285a..0000000000 --- a/wasm/util.wast +++ /dev/null @@ -1,275 +0,0 @@ -(module $util - (import "env" "malloc" (func $malloc (param i32) (result i32))) - (import "env" "free" (func $free (param i32))) - (import "env" "exit" (func $exit (param i32))) - - (import "env" "stdout" (global $stdout i32)) - (import "env" "putchar" (func $putchar (param i32) (result i32))) - (import "env" "fputs" (func $fputs (param i32 i32) (result i32))) - ;;(import "env" "readline" (func $readline (param i32) (result i32))) - (import "libedit.so" "readline" (func $readline (param i32) (result i32))) - ;;(import "libreadline.so" "readline" (func $readline (param i32) (result i32))) - - (global $sprintf_buf (mut i32) (i32.const 0)) - - (func $init_sprintf_mem - ;; 256 character sprintf static buffer - (set_global $sprintf_buf (STRING " ")) - ) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Copy len chatacters from src to dst - ;; Returns len - (func $MEM_COPY (param $dst i32) (param $src i32) (param $len i32) - (local $idx i32) - (set_local $idx (i32.const 0)) - (loop $copy - (i32.store8_u (i32.add (get_local $idx) (get_local $dst)) - (i32.load8_u (i32.add (get_local $idx) - (get_local $src)))) - (set_local $idx (i32.add (i32.const 1) (get_local $idx))) - (br_if $copy (i32.lt_u (get_local $idx) (get_local $len))) - ) - ) - - (func $STRING_LEN (param $str i32) (result i32) - (local $cur i32) - (set_local $cur (get_local $str)) - (loop $count - (if (i32.ne (i32.const 0) (i32.load8_u (get_local $cur))) - (then - (set_local $cur (i32.add (get_local $cur) (i32.const 1))) - (br $count))) - ) - (i32.sub_u (get_local $cur) (get_local $str)) - ) - - (func $ATOI (param $str i32) (result i32) - (local $acc i32) - (local $i i32) - (local $neg i32) - (local $ch i32) - (set_local $acc (i32.const 0)) - (set_local $i (i32.const 0)) - (set_local $neg (i32.const 0)) - (block $done - (loop $loop - (set_local $ch (i32.load8_u (i32.add (get_local $str) - (get_local $i)))) - (if (i32.and (i32.ne (get_local $ch) (CHAR '-')) - (i32.or (i32.lt_u (get_local $ch) (CHAR '0')) - (i32.gt_u (get_local $ch) (CHAR '9')))) - (br $done)) - (set_local $i (i32.add (get_local $i) (i32.const 1))) - (if (i32.eq (get_local $ch) (CHAR '-')) - (then - (set_local $neg (i32.const 1))) - (else - (set_local $acc (i32.add (i32.mul_u (get_local $acc) (i32.const 10)) - (i32.sub_u (get_local $ch) (CHAR '0')))))) - (br $loop) - ) - ) - (if i32 (get_local $neg) - (then (i32.sub_s (i32.const 0) (get_local $acc))) - (else (get_local $acc))) - ) - - (func $strcmp (param $s1 i32) (param $s2 i32) (result i32) - (block $done - (loop $loop - (if (i32.or (i32.eqz (i32.load8_u (get_local $s1))) - (i32.eqz (i32.load8_u (get_local $s2)))) - (br $done)) - (if (i32.ne (i32.load8_u (get_local $s1)) - (i32.load8_u (get_local $s2))) - (br $done)) - (set_local $s1 (i32.add (get_local $s1) (i32.const 1))) - (set_local $s2 (i32.add (get_local $s2) (i32.const 1))) - (br $loop) - ) - ) - (if i32 (i32.eq (i32.load8_u (get_local $s1)) - (i32.load8_u (get_local $s2))) - (then (i32.const 0)) - (else - (if i32 (i32.lt_u (i32.load8_u (get_local $s1)) - (i32.load8_u (get_local $s2))) - (then (i32.const -1)) - (else (i32.const 1))))) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $print (param $addr i32) - (drop (call $fputs (get_local $addr) (get_global $stdout)))) - - (func $printf_1 (param $fmt i32) - (param $v0 i32) - (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) - (get_local $v0) (i32.const 0) (i32.const 0) - (i32.const 0) (i32.const 0) (i32.const 0))) - (call $print (get_global $sprintf_buf)) - ) - - (func $printf_2 (param $fmt i32) - (param $v0 i32) (param $v1 i32) - (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) - (get_local $v0) (get_local $v1) (i32.const 0) - (i32.const 0) (i32.const 0) (i32.const 0))) - (call $print (get_global $sprintf_buf)) - ) - - (func $printf_3 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) - (get_local $v0) (get_local $v1) (get_local $v2) - (i32.const 0) (i32.const 0) (i32.const 0))) - (call $print (get_global $sprintf_buf)) - ) - - (func $printf_4 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) - (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) - (get_local $v0) (get_local $v1) (get_local $v2) - (get_local $v3) (i32.const 0) (i32.const 0))) - (call $print (get_global $sprintf_buf)) - ) - - (func $printf_5 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) (param $v4 i32) - (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) - (get_local $v0) (get_local $v1) (get_local $v2) - (get_local $v3) (get_local $v4) (i32.const 0))) - (call $print (get_global $sprintf_buf)) - ) - - (func $printf_6 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) (param $v4 i32) (param $v5 i32) - (drop (call $sprintf_6 (get_global $sprintf_buf) (get_local $fmt) - (get_local $v0) (get_local $v1) (get_local $v2) - (get_local $v3) (get_local $v4) (get_local $v5))) - (call $print (get_global $sprintf_buf)) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) - (local $n i32) - (local $ch i32) - (set_local $n (i32.rem_u (get_local $num) (get_local $base))) - (set_local $ch (if (result i32) (i32.lt_u (get_local $n) (i32.const 10)) - (i32.const 48) - (i32.const 55))) - (i32.store8_u (get_local $str) (i32.add (get_local $n) (get_local $ch))) - ) - - ;; TODO: switch to snprint* (add buffer len) - (func $_sprintnum (param $str i32) (param $num i32) (param $base i32) - (result i32) - (if (i32.and (i32.eq (get_local $base) (i32.const 10)) - (i32.lt_s (get_local $num) (i32.const 0))) - (then - ;; Print '-' if negative - (i32.store8_u (get_local $str) (CHAR '-')) - (set_local $str (i32.add (get_local $str) (i32.const 1))) - ;; Reverse the sign - (set_local $num (i32.sub_s (i32.const 0) (get_local $num))))) - (if (i32.gt_u (i32.div_u (get_local $num) (get_local $base)) - (i32.const 0)) - (set_local - $str - (call $_sprintnum (get_local $str) - (i32.div_u (get_local $num) (get_local $base)) - (get_local $base)))) - (call $_sprintdigit (get_local $str) (get_local $num) (get_local $base)) - (i32.add (i32.const 1) (get_local $str)) - ) - - ;; TODO: switch to snprint* (add buffer len) - (func $sprintf_1 (param $str i32) (param $fmt i32) - (param $v0 i32) (result i32) - (call $sprintf_6 (get_local $str) (get_local $fmt) - (get_local $v0) (i32.const 0) (i32.const 0) - (i32.const 0) (i32.const 0) (i32.const 0)) - ) - - (func $sprintf_6 (param $str i32) (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) (param $v4 i32) (param $v5 i32) - (result i32) - (local $ch i32) - (local $pstr i32) - (local $v i32) - (local $vidx i32) - (local $len i32) - (set_local $pstr (get_local $str)) - (set_local $vidx (i32.const 0)) - - (block $done - (loop $loop - (block $after_v - (block (block (block (block (block (block - (br_table 0 1 2 3 4 5 0 (get_local $vidx))) - (; 0 ;) (set_local $v (get_local $v0)) (br $after_v)) - (; 1 ;) (set_local $v (get_local $v1)) (br $after_v)) - (; 2 ;) (set_local $v (get_local $v2)) (br $after_v)) - (; 3 ;) (set_local $v (get_local $v3)) (br $after_v)) - (; 4 ;) (set_local $v (get_local $v4)) (br $after_v)) - (; 5 ;) (set_local $v (get_local $v5)) (br $after_v) - ) - - ;;; while ((ch=*(fmt++))) - (set_local $ch (i32.load8_u (get_local $fmt))) - (set_local $fmt (i32.add (i32.const 1) (get_local $fmt))) - (if (i32.eqz (get_local $ch)) (br $done)) - ;; TODO: check buffer length - - (if (i32.ne (get_local $ch) (CHAR '%')) - (then - ;; TODO: check buffer length - (i32.store8_u (get_local $pstr) (get_local $ch)) - (set_local $pstr (i32.add (i32.const 1) (get_local $pstr))) - (br $loop))) - - ;;; ch=*(fmt++) - (set_local $ch (i32.load8_u (get_local $fmt))) - (set_local $fmt (i32.add (i32.const 1) (get_local $fmt))) - - (if (i32.eq (CHAR 'd') (get_local $ch)) - (then - (set_local $pstr (call $_sprintnum (get_local $pstr) - (get_local $v) (i32.const 10)))) - (else (if (i32.eq (CHAR 'x') (get_local $ch)) - (then - (set_local $pstr (call $_sprintnum (get_local $pstr) - (get_local $v) (i32.const 16)))) - (else (if (i32.eq (CHAR 's') (get_local $ch)) - (then - (set_local $len (call $STRING_LEN (get_local $v))) - (call $MEM_COPY (get_local $pstr) (get_local $v) (get_local $len)) - (set_local $pstr (i32.add (get_local $pstr) (get_local $len)))) - (else (if (i32.eq (CHAR 'c') (get_local $ch)) - (then - (i32.store8_u (get_local $pstr) (get_local $v)) - (set_local $pstr (i32.add (get_local $pstr) (i32.const 1)))) - (else - (call $print (STRING "Illegal format character: ")) - (drop (call $putchar (get_local $ch))) - (drop (call $putchar (CHAR '\n'))) - (call $exit (i32.const 3)))))))))) - - (set_local $vidx (i32.add (i32.const 1) (get_local $vidx))) - (br $loop) - ) - ) - - (i32.store8_u (get_local $pstr) (CHAR '\x00')) - (get_local $pstr) - ) - -) - diff --git a/wasm/wastpp.py b/wasm/wastpp.py deleted file mode 100755 index 22266dfcf9..0000000000 --- a/wasm/wastpp.py +++ /dev/null @@ -1,123 +0,0 @@ -#!/usr/bin/env python3 - -from itertools import tee -from ast import literal_eval -import os -import pprint -import re -import sys - -def pairwise(iterable): - "s -> (s0,s1), (s1,s2), (s2, s3), ..." - a, b = tee(iterable) - next(b, None) - return zip(a, b) - -def _escape(s): - return s.replace('\\', '\\\\').replace('"', '\\"').replace('\n', '\\n') - - -tokre = re.compile(r"""([\s][\s]*|[(];|;[)]|[\[\]{}()`~^@]|'(?:[\\].|[^\\'])*'?|"(?:[\\].|[^\\"])*"?|;;.*|[^\s\[\]{}()'"`@,;]+)""") - -file_tokens = [] -strings = [] -string_map = {} - -depth = 0 -module = None -type = None - -for f in sys.argv[1:]: - content = open(f).read() - tokens = [t for t in re.findall(tokre, content)] - #print(tokens[0:100], file=sys.stderr) - pairs = ["".join(p) for p in pairwise(tokens)] - pairs.append("") - - index = 0 - while index < len(tokens): - token = tokens[index] - pair = pairs[index] - if pair in ["(STRING", "(CHAR"]: - arg = tokens[index+3] - #print("arg: %s" % arg, file=sys.stderr) - if tokens[index+4] != ')': - raise Exception("Invalid %s) macro, too many/few args" % pair) - if arg.startswith('"') and arg.endswith('"'): - pass - elif arg.startswith("'") and arg.endswith("'"): - pass - else: - raise Exception ("Invalid %s) macro, invalid string arg" % pair) - if pair == "(STRING": - str = literal_eval(arg) - if str in string_map: - # Duplicate string, re-use address - file_tokens.append("(i32.add (get_global $memoryBase) (get_global %s))" % string_map[str]) - else: - str_name = "$S_STRING_%d" % len(strings) - file_tokens.append("(i32.add (get_global $memoryBase) (get_global %s))" % str_name) - strings.append(str) - string_map[str] = str_name - if pair == "(CHAR": - c = literal_eval(arg) - if len(c) != 1: - raise Exception ("Invalid (CHAR) macro, must be 1 character") - file_tokens.append("(i32.const 0x%x (; %s ;))" % (ord(c), arg)) - # Skip the rest of the macro - index += 5 - continue - index += 1 - if token == '(': - depth += 1 - if token == ')': - depth -= 1 - if depth == 0: - module = None - if token == ')': continue - if depth == 1: - type = None - if pair == '(module': - index += 1 - continue - if token.startswith('$'): - module = token[1:] - #print("module:", module, file=sys.stderr) - file_tokens.append('\n ;;\n ;; module "%s"\n ;;\n' % module) - continue - if depth == 2: - if token == '(': - type = tokens[index] - if type == 'data': - raise Exception("User data section not supported") - #print(" type:", type, file=sys.stderr) - file_tokens.append(token) - -# TODO: remove duplicates -# Create data section with static strings -string_tokens = [] -if strings: - string_tokens.append(" (data\n (get_global $memoryBase)\n") - string_offset = 0 - for string in strings: - string_tokens.append(' %-30s ;; %d\n' % ( - '"'+_escape(string)+'\\00"', string_offset)) - string_offset += len(string)+1 - string_tokens.append(" )\n\n") - - # Create string names/pointers - string_offset = 0 - for index, string in enumerate(strings): - string_tokens.append(' (global $S_STRING_%d i32 (i32.const %d))\n' % ( - index, string_offset)) - string_offset += len(string)+1 - # Terminator so we know how much memory we took - string_tokens.append(' (global $S_STRING_END i32 (i32.const %d))\n' % ( - string_offset)) - -all_tokens = ["(module\n"] -all_tokens.extend(string_tokens) -all_tokens.extend(file_tokens) -all_tokens.append("\n)") - -print("".join(all_tokens)) From 3ea098865215e726a1fb2008fd050bf66cd4c4f3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sun, 14 Oct 2018 16:44:08 -0500 Subject: [PATCH 0404/1998] wasm: Steps 4-A, hashmaps, metadata. - Use more concise param and local syntax. - Separate out string.wam. - Add pr_str_seq functionality and add in print_readably functionality. - Add REPLACE3 function. - Remove use of putchar and simplify util.wam - Move string functions from util.wam to string.wam including some renames to be more consistent with C library names. - Add temporary content to 256 character buffers so that they are de-duplicated/combined. - Use AND/OR macros. - Improve Makefile deps and use more general wasm target. - Properly cleanup memory in try* and use TCO as part of try*. --- wasm/Makefile | 17 +- wasm/core.wam | 754 ++++++++++++++++++++++++++++++++++++++ wasm/debug.wam | 103 +++++- wasm/env.wam | 62 +++- wasm/mem.wam | 122 +++--- wasm/printer.wam | 101 +++-- wasm/reader.wam | 187 ++++++---- wasm/step0_repl.wam | 4 +- wasm/step1_read_print.wam | 28 +- wasm/step2_eval.wam | 61 ++- wasm/step3_env.wam | 70 ++-- wasm/step4_if_fn_do.wam | 325 ++++++++++++++++ wasm/step5_tco.wam | 374 +++++++++++++++++++ wasm/step6_file.wam | 430 ++++++++++++++++++++++ wasm/step7_quote.wam | 494 +++++++++++++++++++++++++ wasm/step8_macros.wam | 580 +++++++++++++++++++++++++++++ wasm/step9_try.wam | 630 +++++++++++++++++++++++++++++++ wasm/stepA_mal.wam | 634 ++++++++++++++++++++++++++++++++ wasm/string.wam | 226 ++++++++++++ wasm/types.wam | 223 ++++++++++- wasm/util.wam | 215 +++++------ 21 files changed, 5203 insertions(+), 437 deletions(-) create mode 100644 wasm/core.wam create mode 100644 wasm/step4_if_fn_do.wam create mode 100644 wasm/step5_tco.wam create mode 100644 wasm/step6_file.wam create mode 100644 wasm/step7_quote.wam create mode 100644 wasm/step8_macros.wam create mode 100644 wasm/step9_try.wam create mode 100644 wasm/stepA_mal.wam create mode 100644 wasm/string.wam diff --git a/wasm/Makefile b/wasm/Makefile index aeac222726..e44953e0f2 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,7 +1,7 @@ -STEP0_DEPS = util.wam +STEP0_DEPS = string.wam util.wam STEP1_DEPS = $(STEP0_DEPS) types.wam mem.wam debug.wam reader.wam printer.wam -STEP2_DEPS = $(STEP1_DEPS) -STEP3_DEPS = $(STEP2_DEPS) env.wam +STEP3_DEPS = $(STEP1_DEPS) env.wam +STEP4_DEPS = $(STEP3_DEPS) core.wam STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ @@ -9,14 +9,15 @@ STEPS = step0_repl step1_read_print step2_eval step3_env \ all: $(foreach s,$(STEPS),$(s).wasm) -%.wasm: +%.wasm: %.wam wamp $^ > $*.wast wasm-as $*.wast -o $@ -step0_repl.wasm: $(STEP0_DEPS) step0_repl.wam -step1_read_print.wasm: $(STEP1_DEPS) step1_read_print.wam -step2_eval.wasm: $(STEP2_DEPS) step2_eval.wam -step3_env.wasm: $(STEP3_DEPS) step3_env.wam +step0_repl.wasm: $(STEP0_DEPS) +step1_read_print.wasm step2_eval.wasm: $(STEP1_DEPS) +step3_env.wasm: $(STEP3_DEPS) +step4_if_fn_do.wasm step5_tco.wasm step6_file.wasm: $(STEP4_DEPS) +step7_quote.wasm step8_macros.wasm step9_try.wasm stepA_mal.wasm: $(STEP4_DEPS) .PHONY: clean diff --git a/wasm/core.wam b/wasm/core.wam new file mode 100644 index 0000000000..ed73dc8138 --- /dev/null +++ b/wasm/core.wam @@ -0,0 +1,754 @@ +(module $core + + + ;; it would be nice to have this in types.wam but it uses + ;; ENV_NEW_BINDS which is not available until step3 but types is + ;; used in step1 + + (func $APPLY (param $f i32) (param $args i32) (result i32) + (local $res i32 $env i32 $ftype i32 $a i32) + (set_local $f ($DEREF_META $f)) + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + ;; Must be kept in sync with EVAL's FUNCTION_T evaluation + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (set_local $res ($EVAL ($MEM_VAL1_ptr $args) + (get_global $repl_env)))) + (else + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))))) + (else (if (OR (i32.eq $ftype (get_global $MALFUNC_T)) + (i32.eq $ftype (get_global $MACRO_T))) + (then + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; claim the AST before releasing the list containing it + (set_local $a ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $a)) + + (set_local $res ($EVAL $a $env)) + + ($RELEASE $env) + ($RELEASE $a)) + (else + ($THROW_STR_1 "APPLY of non-function type: %d\n" $ftype) + (set_local $res 0))))) + $res + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; core functions + + (type $fnT (func (param i32) (result i32))) + + (func $equal_Q (param $args i32) (result i32) + ($TRUE_FALSE ($EQUAL_Q ($MEM_VAL1_ptr $args) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))))) + + (func $throw (param $args i32) (result i32) + (set_global $error_type 2) + (set_global $error_val ($INC_REF ($MEM_VAL1_ptr $args))) + 0 + ) + + (func $nil_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (get_global $NIL_T)))) + (func $true_Q (param $args i32) (result i32) + (local $ast i32) + (set_local $ast ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $BOOLEAN_T)) + (i32.eq ($VAL0 $ast) 1))) + ) + (func $false_Q (param $args i32) (result i32) + (local $ast i32) + (set_local $ast ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $BOOLEAN_T)) + (i32.eq ($VAL0 $ast) 0))) + ) + (func $number_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (get_global $INTEGER_T)))) + (func $string_Q (param $args i32) (result i32) + (local $mv i32) + (set_local $mv ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $mv) (get_global $STRING_T)) + (i32.ne (i32.load8_u ($to_String $mv)) + (CHR "\x7f")))) + ) + + (func $keyword (param $args i32) (result i32) + (local $str i32) + (set_local $str ($to_String ($MEM_VAL1_ptr $args))) + (if i32 (i32.eq (i32.load8_u $str) (CHR "\x7f")) + (then ($INC_REF ($MEM_VAL1_ptr $args))) + (else + (drop ($sprintf_1 (get_global $util_buf) "\x7f%s" $str)) + ($STRING (get_global $STRING_T) (get_global $util_buf)))) + ) + + (func $keyword_Q (param $args i32) (result i32) + (local $ast i32) + (set_local $ast ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $STRING_T)) + (i32.eq (i32.load8_u ($to_String $ast)) + (CHR "\x7f")))) + ) + (func $fn_Q (param $args i32) (result i32) + (local $type i32) + (set_local $type ($TYPE ($MEM_VAL1_ptr $args))) + ($TRUE_FALSE (OR (i32.eq $type (get_global $FUNCTION_T)) + (i32.eq $type (get_global $MALFUNC_T))))) + (func $macro_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (get_global $MACRO_T)))) + + (func $symbol (param $args i32) (result i32) + ($STRING (get_global $SYMBOL_T) ($to_String ($MEM_VAL1_ptr $args)))) + + (func $symbol_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (get_global $SYMBOL_T)))) + + (func $core_pr_str (param $args i32) (result i32) + ($pr_str_seq $args 1 " ")) + (func $str (param $args i32) (result i32) + ($pr_str_seq $args 0 "")) + (func $prn (param $args i32) (result i32) + (local $res i32) + (set_local $res ($pr_str_seq $args 1 " ")) + ($printf_1 "%s\n" ($to_String $res)) + ($RELEASE $res) + ($INC_REF (get_global $NIL)) + ) + (func $println (param $args i32) (result i32) + (local $res i32) + (set_local $res ($pr_str_seq $args 0 " ")) + ($printf_1 "%s\n" ($to_String $res)) + ($RELEASE $res) + ($INC_REF (get_global $NIL)) + ) + + (func $core_readline (param $args i32) (result i32) + (local $line i32 $mv i32) + (set_local $line ($readline ($to_String ($MEM_VAL1_ptr $args)))) + (if (i32.eqz $line) (return ($INC_REF (get_global $NIL)))) + (set_local $mv ($STRING (get_global $STRING_T) $line)) + ($free $line) + $mv + ) + + (func $read_string (param $args i32) (result i32) + ($read_str ($to_String ($MEM_VAL1_ptr $args)))) + + (func $slurp (param $args i32) (result i32) + (local $content i32 $mv i32) + (set_local $content ($read_file ($to_String ($MEM_VAL1_ptr $args)))) + (if (i32.le_s $content 0) + (then + ($THROW_STR_1 "failed to read file '%s'" ($to_String ($MEM_VAL1_ptr $args))) + (return ($INC_REF (get_global $NIL))))) + (set_local $mv ($STRING (get_global $STRING_T) $content)) + ($free $content) + $mv + ) + + (func $lt (param $args i32) (result i32) + ($TRUE_FALSE + (i32.lt_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $lte (param $args i32) (result i32) + ($TRUE_FALSE + (i32.le_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $gt (param $args i32) (result i32) + ($TRUE_FALSE + (i32.gt_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $gte (param $args i32) (result i32) + ($TRUE_FALSE + (i32.ge_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $add (param $args i32) (result i32) + ($INTEGER + (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $subtract (param $args i32) (result i32) + ($INTEGER + (i32.sub_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $multiply (param $args i32) (result i32) + ($INTEGER + (i32.mul_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $divide (param $args i32) (result i32) + ($INTEGER + (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + + (func $time_ms (param $args i32) (result i32) + ($INTEGER ($get_time_ms))) + + ;;; + + (func $list (param $args i32) (result i32) + ($INC_REF $args)) + + (func $list_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) + (get_global $LIST_T)))) + + (func $vector (param $args i32) (result i32) + ($FORCE_SEQ_TYPE (get_global $VECTOR_T) $args)) + + (func $vector_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) + (get_global $VECTOR_T)))) + + (func $hash_map (param $args i32) (result i32) + (local $res i32 $type i32 $val2 i32 $val3 i32 $c i32) + (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP stack + (set_local $type (get_global $HASHMAP_T)) + + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + ;; READ_SEQ_LOOP + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $args)) (br $done)) + + (set_local $val2 ($INC_REF ($MEM_VAL1_ptr $args))) + (set_local $val3 ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + + ;; skip two + (set_local $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + + (func $hash_map_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) + (get_global $HASHMAP_T)))) + + (func $assoc (param $args i32) (result i32) + (local $hm i32 $key i32) + (set_local $hm ($MEM_VAL1_ptr $args)) + (set_local $args ($MEM_VAL0_ptr $args)) + (drop ($INC_REF $hm)) + (block $done + (loop $loop + (if (OR (i32.eqz ($VAL0 $args)) + (i32.eqz ($VAL0 ($MEM_VAL0_ptr $args)))) + (br $done)) + (set_local $hm ($ASSOC1 $hm ($MEM_VAL1_ptr $args) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + (set_local $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) + + (br $loop) + ) + ) + $hm + ) + + (func $get (param $args i32) (result i32) + (local $hm i32 $key i32) + (set_local $hm ($MEM_VAL1_ptr $args)) + (set_local $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + (if i32 (i32.eq $hm (get_global $NIL)) + (then ($INC_REF (get_global $NIL))) + (else ($INC_REF (i32.wrap/i64 ($HASHMAP_GET $hm $key))))) + ) + + (func $contains_Q (param $args i32) (result i32) + (local $hm i32 $key i32) + (set_local $hm ($MEM_VAL1_ptr $args)) + (set_local $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + ($TRUE_FALSE + (if i32 (i32.eq $hm (get_global $NIL)) + (then 0) + (else (i32.wrap/i64 + (i64.shr_u ($HASHMAP_GET $hm $key) (i64.const 32)))))) + ) + + (func $keys_or_vals (param $hm i32 $keys i32) (result i32) + (local $res i32 $val2 i32) + (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP stack + + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $hm)) (br $done)) + + (if $keys + (then (set_local $val2 ($INC_REF ($MEM_VAL1_ptr $hm)))) + (else (set_local $val2 ($INC_REF ($MEM_VAL2_ptr $hm))))) + + ;; next element + (set_local $hm ($MEM_VAL0_ptr $hm)) + + ;; update the return sequence structure + ;; do not release val2 since we are pulling it from the + ;; arguments and not creating it here + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE (get_global $LIST_T) + $empty $current $val2 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + (func $keys (param $args i32) (result i32) + ($keys_or_vals ($MEM_VAL1_ptr $args) 1)) + + (func $vals (param $args i32) (result i32) + ($keys_or_vals ($MEM_VAL1_ptr $args) 0)) + + (func $sequential_Q (param $args i32) (result i32) + ($TRUE_FALSE (OR (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (get_global $LIST_T)) + (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (get_global $VECTOR_T))))) + + (func $cons (param $args i32) (result i32) + ($LIST ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) ($MEM_VAL1_ptr $args))) + + (func $concat (param $args i32) (result i32) + (local $res i32 $current i32 $sl i32 $last i32 $last_sl i64 $arg i32) + (set_local $res ($INC_REF (get_global $EMPTY_LIST))) + (set_local $current $res) + (set_local $sl 0) + (set_local $last 0) + (block $done + (loop $loop + (if (i32.le_u $args (get_global $EMPTY_HASHMAP)) + (br $done)) + (set_local $arg ($MEM_VAL1_ptr $args)) + ;; skip empty elements + (if (i32.le_s $arg (get_global $EMPTY_HASHMAP)) + (then + (set_local $args ($MEM_VAL0_ptr $args)) + (br $loop))) + (set_local $last_sl ($SLICE $arg 0 -1)) + (set_local $sl (i32.wrap/i64 $last_sl)) + (set_local $last (i32.wrap/i64 (i64.shr_u $last_sl (i64.const 32)))) + (if (i32.eq $res (get_global $EMPTY_LIST)) + (then + ;; if this is the first element, set the return to the slice + (set_local $res $sl)) + (else + ;; otherwise attach current to sliced + (i32.store ($VAL0_ptr $current) ($IDX $sl)))) + ;; update current to end of sliced list + (set_local $current $last) + ;; release empty since no longer part of the slice + ($RELEASE (get_global $EMPTY_LIST)) + + (set_local $args ($MEM_VAL0_ptr $args)) + (br $loop) + ) + ) + $res + ) + + (func $nth (param $args i32) (result i32) + (local $a i32 $idx i32 $i i32) + (set_local $a ($MEM_VAL1_ptr $args)) + (set_local $idx ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + + (set_local $i 0) + (block $done + (loop $loop + (if (OR (i32.ge_s $i $idx) (i32.eqz ($VAL0 $a))) + (br $done)) + (set_local $i (i32.add $i 1)) + (set_local $a ($MEM_VAL0_ptr $a)) + (br $loop) + ) + ) + (if (i32.eq ($VAL0 $a) 0) + (then + ($THROW_STR_0 "nth: index out of range") + (return 0))) + + ($INC_REF ($MEM_VAL1_ptr $a)) + ) + + (func $first (param $args i32) (result i32) + (local $res i32 $a i32) + (set_local $res (get_global $NIL)) + (set_local $a ($MEM_VAL1_ptr $args)) + (if (AND (i32.ne $a (get_global $NIL)) + (i32.ne ($VAL0 $a) 0)) + (set_local $res ($MEM_VAL1_ptr $a))) + ($INC_REF $res) + ) + + (func $rest (param $args i32) (result i32) + (local $a i32) + (set_local $a ($MEM_VAL1_ptr $args)) + (if (i32.eq $a (get_global $NIL)) + (return ($INC_REF (get_global $EMPTY_LIST)))) + (if (i32.ne ($VAL0 $a) 0) + (set_local $a ($MEM_VAL0_ptr $a))) + ($FORCE_SEQ_TYPE (get_global $LIST_T) $a) + ) + + ;;; + + (func $empty_Q (param $args i32) (result i32) + ($TRUE_FALSE ($EMPTY_Q ($MEM_VAL1_ptr $args)))) + + (func $count (param $args i32) (result i32) + ($INTEGER ($COUNT ($MEM_VAL1_ptr $args)))) + + (func $apply (param $args i32) (result i32) + (local $f i32 $f_args i32 $rest_args i32 $rest_count i32) + (local $last_sl i64 $last i32 $res i32) + + (set_local $f ($MEM_VAL1_ptr $args)) + (set_local $rest_args ($MEM_VAL0_ptr $args)) + (set_local $rest_count ($COUNT $rest_args)) + + (if (i32.le_s $rest_count 1) + (then + ;; no intermediate args + (if (i32.ne ($TYPE ($MEM_VAL1_ptr $rest_args)) (get_global $LIST_T)) + (then + ;; not a list, so convert it first + (set_local $f_args ($FORCE_SEQ_TYPE (get_global $LIST_T) + ($MEM_VAL1_ptr $rest_args)))) + (else + ;; inc ref since we will release after APPLY + (set_local $f_args ($INC_REF ($MEM_VAL1_ptr $rest_args)))))) + (else + ;; 1 or more intermediate args + (set_local $last_sl ($SLICE $rest_args 0 (i32.sub_s $rest_count 1))) + (set_local $f_args (i32.wrap/i64 $last_sl)) + (set_local $last (i32.wrap/i64 (i64.shr_u $last_sl (i64.const 32)))) + ;; release the terminator of the new list (we skip over it) + ;; we already checked for an empty list above, so $last is + ;; a real non-empty list + ($RELEASE ($MEM_VAL0_ptr $last)) + ;; attach end of slice to final args element + (i32.store ($VAL0_ptr $last) ($IDX ($LAST $rest_args))) + )) + + (set_local $res ($APPLY $f $f_args)) + + ;; release new args + ($RELEASE $f_args) + $res + ) + + (func $map (param $args i32) (result i32) + (local $f i32 $rest_args i32 $f_args i32 $res i32) + (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP stack + + (set_local $f ($MEM_VAL1_ptr $args)) + (set_local $rest_args ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + (if (i32.eqz ($VAL1 $rest_args)) (br $done)) + + ;; create argument list for apply + (set_local $f_args ($ALLOC (get_global $LIST_T) + (get_global $EMPTY_LIST) + ($MEM_VAL1_ptr $rest_args) + 0)) + + (set_local $res ($APPLY $f $f_args)) + ($RELEASE $f_args) + + ;; go to the next element + (set_local $rest_args ($MEM_VAL0_ptr $rest_args)) + + (if (get_global $error_type) + (then + ;; if error, release the unattached element + ($RELEASE $res) + (br $done))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE (get_global $LIST_T) + $empty $current $res 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + ;;; + + (func $with_meta (param $args i32) (result i32) + (local $mv i32 $meta i32) + (set_local $mv ($MEM_VAL1_ptr $args)) + (set_local $meta ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + ;; remove existing metadata first + ($ALLOC (get_global $METADATA_T) ($DEREF_META $mv) $meta 0) + ) + + (func $meta (param $args i32) (result i32) + (if i32 (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $METADATA_T)) + (then ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL1_ptr $args)))) + (else ($INC_REF (get_global $NIL))))) + + (func $atom (param $args i32) (result i32) + ($ALLOC_SCALAR (get_global $ATOM_T) ($VAL1 $args))) + + (func $atom_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $ATOM_T)))) + + (func $deref (param $args i32) (result i32) + ($INC_REF ($MEM_VAL0_ptr ($MEM_VAL1_ptr $args)))) + + (func $_reset_BANG (param $atom i32 $val i32) (result i32) + ;; release current value since we are about to overwrite it + ($RELEASE ($MEM_VAL0_ptr $atom)) + ;; inc ref by 2 for atom ownership and since we are returning it + (drop ($INC_REF ($INC_REF $val))) + ;; update the value + (i32.store ($VAL0_ptr $atom) ($IDX $val)) + $val + ) + + (func $reset_BANG (param $args i32) (result i32) + (local $atom i32 $val i32) + (set_local $atom ($MEM_VAL1_ptr $args)) + (set_local $val ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + ($_reset_BANG $atom $val) + ) + + (func $swap_BANG (param $args i32) (result i32) + (local $atom i32 $f_args i32 $s_args i32 $rest_args i32 $f i32 $res i32) + (set_local $atom ($MEM_VAL1_ptr $args)) + (set_local $f_args ($MEM_VAL0_ptr $args)) + (set_local $rest_args ($MEM_VAL0_ptr $f_args)) + (set_local $f ($MEM_VAL1_ptr $f_args)) + (set_local $res 0) + ;; add atom value to front of the args list + (set_local $s_args ($LIST $rest_args ($MEM_VAL0_ptr $atom))) ;; cons + (set_local $res ($APPLY $f $s_args)) + ;; release args + ($RELEASE $s_args) + ;; use reset to update the value + (drop ($_reset_BANG $atom $res)) + ;; but decrease the ref cnt of return by 1 (not sure why) + ($RELEASE $res) + $res + ) + + ;;; + + (func $pr_memory_summary (param $args i32) (result i32) + ($PR_MEMORY_SUMMARY_SMALL) + ($INC_REF (get_global $NIL)) + ) + + (func $nop (param $args i32) (result i32) + ($INC_REF (get_global $NIL))) + + (table + anyfunc + (elem $nop ;; placeholder for eval which will use 0 + $equal_Q + $throw + $nil_Q + $true_Q + $false_Q + $number_Q + $string_Q + $symbol + $symbol_Q + $keyword + $keyword_Q + $fn_Q + $macro_Q + + ;; 14 + $core_pr_str + $str + $prn + $println + $core_readline + $read_string + $slurp + $lt + $lte + $gt + $gte + $add + $subtract + $multiply + $divide + $time_ms + + ;; 30 + $list + $list_Q + $vector + $vector_Q + $hash_map + $hash_map_Q + $assoc + $nop ;; $dissoc + $get + $contains_Q + $keys + $vals + + ;; 42 + $sequential_Q + $cons + $concat + $nth + $first + $rest + $empty_Q + $count + $apply + $map + $nop ;; $conj + $nop ;; $seq + + ;; 54 + $with_meta + $meta + $atom + $atom_Q + $deref + $reset_BANG + $swap_BANG + + $pr_memory_summary + ) + ) + + (func $add_core_ns (param $env i32) + ;;(drop ($ENV_SET_S $env "eval" ($FUNCTION 0))) + (drop ($ENV_SET_S $env "=" ($FUNCTION 1))) + (drop ($ENV_SET_S $env "throw" ($FUNCTION 2))) + (drop ($ENV_SET_S $env "nil?" ($FUNCTION 3))) + (drop ($ENV_SET_S $env "true?" ($FUNCTION 4))) + (drop ($ENV_SET_S $env "false?" ($FUNCTION 5))) + (drop ($ENV_SET_S $env "number?" ($FUNCTION 6))) + (drop ($ENV_SET_S $env "string?" ($FUNCTION 7))) + (drop ($ENV_SET_S $env "symbol" ($FUNCTION 8))) + (drop ($ENV_SET_S $env "symbol?" ($FUNCTION 9))) + (drop ($ENV_SET_S $env "keyword" ($FUNCTION 10))) + (drop ($ENV_SET_S $env "keyword?" ($FUNCTION 11))) + (drop ($ENV_SET_S $env "fn?" ($FUNCTION 12))) + (drop ($ENV_SET_S $env "macro?" ($FUNCTION 13))) + + (drop ($ENV_SET_S $env "pr-str" ($FUNCTION 14))) + (drop ($ENV_SET_S $env "str" ($FUNCTION 15))) + (drop ($ENV_SET_S $env "prn" ($FUNCTION 16))) + (drop ($ENV_SET_S $env "println" ($FUNCTION 17))) + (drop ($ENV_SET_S $env "readline" ($FUNCTION 18))) + (drop ($ENV_SET_S $env "read-string" ($FUNCTION 19))) + (drop ($ENV_SET_S $env "slurp" ($FUNCTION 20))) + (drop ($ENV_SET_S $env "<" ($FUNCTION 21))) + (drop ($ENV_SET_S $env "<=" ($FUNCTION 22))) + (drop ($ENV_SET_S $env ">" ($FUNCTION 23))) + (drop ($ENV_SET_S $env ">=" ($FUNCTION 24))) + (drop ($ENV_SET_S $env "+" ($FUNCTION 25))) + (drop ($ENV_SET_S $env "-" ($FUNCTION 26))) + (drop ($ENV_SET_S $env "*" ($FUNCTION 27))) + (drop ($ENV_SET_S $env "/" ($FUNCTION 28))) + (drop ($ENV_SET_S $env "time-ms" ($FUNCTION 29))) + + (drop ($ENV_SET_S $env "list" ($FUNCTION 30))) + (drop ($ENV_SET_S $env "list?" ($FUNCTION 31))) + (drop ($ENV_SET_S $env "vector" ($FUNCTION 32))) + (drop ($ENV_SET_S $env "vector?" ($FUNCTION 33))) + (drop ($ENV_SET_S $env "hash-map" ($FUNCTION 34))) + (drop ($ENV_SET_S $env "map?" ($FUNCTION 35))) + (drop ($ENV_SET_S $env "assoc" ($FUNCTION 36))) + (drop ($ENV_SET_S $env "dissoc" ($FUNCTION 37))) + (drop ($ENV_SET_S $env "get" ($FUNCTION 38))) + (drop ($ENV_SET_S $env "contains?" ($FUNCTION 39))) + (drop ($ENV_SET_S $env "keys" ($FUNCTION 40))) + (drop ($ENV_SET_S $env "vals" ($FUNCTION 41))) + + (drop ($ENV_SET_S $env "sequential?" ($FUNCTION 42))) + (drop ($ENV_SET_S $env "cons" ($FUNCTION 43))) + (drop ($ENV_SET_S $env "concat" ($FUNCTION 44))) + (drop ($ENV_SET_S $env "nth" ($FUNCTION 45))) + (drop ($ENV_SET_S $env "first" ($FUNCTION 46))) + (drop ($ENV_SET_S $env "rest" ($FUNCTION 47))) + (drop ($ENV_SET_S $env "empty?" ($FUNCTION 48))) + (drop ($ENV_SET_S $env "count" ($FUNCTION 49))) + (drop ($ENV_SET_S $env "apply" ($FUNCTION 50))) + (drop ($ENV_SET_S $env "map" ($FUNCTION 51))) + + (drop ($ENV_SET_S $env "conj" ($FUNCTION 52))) + (drop ($ENV_SET_S $env "seq" ($FUNCTION 53))) + + (drop ($ENV_SET_S $env "with-meta" ($FUNCTION 54))) + (drop ($ENV_SET_S $env "meta" ($FUNCTION 55))) + (drop ($ENV_SET_S $env "atom" ($FUNCTION 56))) + (drop ($ENV_SET_S $env "atom?" ($FUNCTION 57))) + (drop ($ENV_SET_S $env "deref" ($FUNCTION 58))) + (drop ($ENV_SET_S $env "reset!" ($FUNCTION 59))) + (drop ($ENV_SET_S $env "swap!" ($FUNCTION 60))) + + (drop ($ENV_SET_S $env "pr-memory-summary" ($FUNCTION 61))) + ) +) diff --git a/wasm/debug.wam b/wasm/debug.wam index 7eb0795461..4ad2231482 100644 --- a/wasm/debug.wam +++ b/wasm/debug.wam @@ -1,17 +1,89 @@ (module $debug - (func $PR_VALUE (param $fmt i32) (param $mv i32) + (func $CHECK_FREE_LIST (result i32) + (local $first i32 $count i32) + (set_local $first (i32.add + (get_global $mem) + (i32.mul_u (get_global $mem_free_list) + 4))) + (set_local $count 0) + + (block $done + (loop $loop + (if (i32.ge_s $first (i32.add + (get_global $mem) + (i32.mul_u (get_global $mem_unused_start) + 4))) + (br $done)) + (set_local $count (i32.add $count ($MalVal_size $first))) + (set_local $first (i32.add (get_global $mem) (i32.mul_u 4 ($VAL0 $first)))) + (br $loop) + ) + ) + $count + ) + + (func $PR_MEMORY_SUMMARY_SMALL + (local $free i32 $free_list_count i32 $mv i32 $mem_ref_count i32) + + (set_local $free (i32.sub_s (get_global $MEM_SIZE) + (i32.mul_u (get_global $mem_unused_start) 4))) + (set_local $free_list_count ($CHECK_FREE_LIST)) + (set_local $mem_ref_count 0) + + (set_local $mv (get_global $NIL)) + (block $done + (loop $loop + (if (i32.ge_s $mv (i32.add + (get_global $mem) + (i32.mul_u (get_global $mem_unused_start) 4))) + (br $done)) + (if (i32.ne ($TYPE $mv) (get_global $FREE_T)) + (set_local $mem_ref_count (i32.add $mem_ref_count + (i32.shr_u + (i32.load $mv) + 5)))) + (set_local $mv (i32.add $mv (i32.mul_u 4 ($MalVal_size $mv)))) + (br $loop) + ) + ) + + ($printf_3 "Free: %d, Values: %d (refs: %d), Emptys: " + $free + (i32.sub_s + (i32.sub_s (get_global $mem_unused_start) 1) + $free_list_count) + $mem_ref_count) + (set_local $mv (get_global $NIL)) + (block $done + (loop $loop + (if (i32.gt_s $mv (get_global $TRUE)) (br $done)) + ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) + (set_local $mv (i32.add $mv 8)) + (br $loop) + ) + ) + (set_local $mv (get_global $EMPTY_LIST)) + (block $done + (loop $loop + (if (i32.gt_s $mv (get_global $EMPTY_HASHMAP)) (br $done)) + ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) + (set_local $mv (i32.add $mv 12)) + (br $loop) + ) + ) + ($print "\n") + ) + + (func $PR_VALUE (param $fmt i32 $mv i32) (local $temp i32) - (set_local $temp ($pr_str $mv)) + (set_local $temp ($pr_str $mv 1)) ($printf_1 $fmt ($to_String $temp)) ($RELEASE $temp) ) (func $PR_MEMORY_VALUE (param $idx i32) (result i32) - (local $mv i32) - (local $type i32) - (local $size i32) - (local $val0 i32) + (local $mv i32 $type i32 $size i32 $val0 i32) ;;; mv = mem + idx (set_local $mv ($MalVal_ptr $idx)) (set_local $type ($TYPE $mv)) @@ -19,7 +91,7 @@ (set_local $val0 ($MalVal_val $idx 0)) ;;; printf(" %3d: type: %2d", idx, type) - ($printf_2 " 0x%x: type: %d" $idx $type) + ($printf_2 " %d: type: %d" $idx $type) (if (i32.eq $type 15) (then @@ -30,20 +102,24 @@ ($printf_1 ", refs: %d" ($REFS $mv)))) ;;; printf(", [ %3d | %3d", mv->refcnt_type, val0) - ($printf_2 ", [ 0x%x | 0x%x" ($MalVal_refcnt_type $idx) $val0) + (if (OR (i32.eq $type (get_global $STRING_T)) + (i32.eq $type (get_global $SYMBOL_T))) + ;; for strings/symbolx pointers, print hex values + (then ($printf_2 ", [ 0x%x | 0x%x" ($MalVal_refcnt_type $idx) $val0)) + (else ($printf_2 ", [ %d | %d" ($MalVal_refcnt_type $idx) $val0))) (if (i32.eq $size 2) (then ($print " | --- | --- ]")) (else ;;; printf(" | %3d", mv->val[1]) - ($printf_1 " | 0x%x" ($MalVal_val $idx 1)) + ($printf_1 " | %d" ($MalVal_val $idx 1)) (if (i32.eq $size 3) (then ($print " | --- ]")) (else ;;; printf(" | %3d ]", mv->val[2]) - ($printf_1 " | 0x%x ]" ($MalVal_val $idx 2)))))) + ($printf_1 " | %d ]" ($MalVal_val $idx 2)))))) ;;; printf(" >> ") ($print " >> ") @@ -136,12 +212,12 @@ ($print "unknown") ) - (drop ($putchar 0xA)) + ($print "\n") (i32.add $size $idx) ) - (func $PR_MEMORY (param $start i32) (param $end i32) + (func $PR_MEMORY (param $start i32 $end i32) (local $idx i32) (if (i32.lt_s $start 0) (set_local $start (get_global $mem_user_start))) @@ -171,9 +247,10 @@ (br $loopvals) ) ))) + ($PR_MEMORY_SUMMARY_SMALL) ) - (func $PR_MEMORY_RAW (param $start i32) (param $end i32) + (func $PR_MEMORY_RAW (param $start i32 $end i32) (block $loop_exit (loop $loop (if (i32.ge_u $start $end) (br $loop_exit)) diff --git a/wasm/env.wam b/wasm/env.wam index 88945ff34a..64e7dd9b13 100644 --- a/wasm/env.wam +++ b/wasm/env.wam @@ -1,8 +1,7 @@ (module $env (func $ENV_NEW (param $outer i32) (result i32) - (local $data i32) - (local $env i32) + (local $data i32 $env i32) ;; allocate the data hashmap (set_local $data ($HASHMAP)) @@ -13,26 +12,60 @@ $env ) - (func $ENV_SET (param $env i32) (param $key i32) (param $value i32) - (result i32) + (func $ENV_NEW_BINDS (param $outer i32 $binds i32 $exprs i32) (result i32) + (local $env i32 $key i32) + (set_local $env ($ENV_NEW $outer)) + + ;; process bindings + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $binds)) (br $done)) + + ;; get/deref the key from binds + (set_local $key ($MEM_VAL1_ptr $binds)) + (if (i32.eqz ($strcmp "&" ($to_String $key))) + (then + ;; ENV_NEW_BIND_VARGS + ;; get/deref the key from the next element of binds + (set_local $binds ($MEM_VAL0_ptr $binds)) + (set_local $key ($MEM_VAL1_ptr $binds)) + ;; the value is the remaining list in exprs + (set_local $exprs ($FORCE_SEQ_TYPE (get_global $LIST_T) $exprs)) + ;; set the binding in the environment data + (drop ($ENV_SET $env $key $exprs)) + ;; list is owned by the environment + ($RELEASE $exprs) + (br $done)) + (else + ;; ENV_NEW_BIND_1x1 + ;; set the binding in the environment data + (drop ($ENV_SET $env $key ($MEM_VAL1_ptr $exprs))) + ;; go to next element of binds and exprs + (set_local $binds ($MEM_VAL0_ptr $binds)) + (set_local $exprs ($MEM_VAL0_ptr $exprs)))) + + (br $loop) + ) + ) + $env + ) + + (func $ENV_SET (param $env i32 $key i32 $value i32) (result i32) (local $data i32) (set_local $data ($MEM_VAL0_ptr $env)) - (i32.store ($VAL0_ptr $env) ($MalVal_index ($ASSOC1 $data $key $value))) + (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1 $data $key $value))) $value ) - (func $ENV_SET_S (param $env i32) (param $key i32) (param $value i32) - (result i32) + (func $ENV_SET_S (param $env i32 $key i32 $value i32) (result i32) (local $data i32) (set_local $data ($MEM_VAL0_ptr $env)) - (i32.store ($VAL0_ptr $env) ($MalVal_index ($ASSOC1_S $data $key $value))) + (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1_S $data $key $value))) $value ) - (func $ENV_FIND (param $env i32) (param $key i32) (result i64) - (local $res i32) - (local $data i32) - (local $found_res i64) + (func $ENV_FIND (param $env i32 $key i32) (result i64) + (local $res i32 $data i32 $found_res i64) (set_local $res 0) @@ -61,9 +94,8 @@ (i64.extend_u/i32 $env)) ) - (func $ENV_GET (param $env i32) (param $key i32) (result i32) - (local $res i32) - (local $res_env i64) + (func $ENV_GET (param $env i32 $key i32) (result i32) + (local $res i32 $res_env i64) (set_local $res 0) (set_local $res_env ($ENV_FIND $env $key)) diff --git a/wasm/mem.wam b/wasm/mem.wam index 1134ae1ccc..e67824bd67 100644 --- a/wasm/mem.wam +++ b/wasm/mem.wam @@ -30,13 +30,19 @@ (func $MEM_VAL0_ptr (param $mv i32) (result i32) (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add $mv 4)) 8))) + (i32.mul_u (i32.load (i32.add $mv 4)) 4))) (func $MEM_VAL1_ptr (param $mv i32) (result i32) (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add $mv 8)) 8))) + (i32.mul_u (i32.load (i32.add $mv 8)) 4))) (func $MEM_VAL2_ptr (param $mv i32) (result i32) (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add $mv 12)) 8))) + (i32.mul_u (i32.load (i32.add $mv 12)) 4))) + + ;; Returns the memory index mem of mv + ;; Will usually be used with a load or store by the caller + (func $IDX (param $mv i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + (i32.div_u (i32.sub_u $mv (get_global $mem)) 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -44,13 +50,7 @@ (func $MalVal_ptr (param $mv_idx i32) (result i32) ;; MalVal memory 64 bit (2 * i32) aligned ;;; mem[mv_idx].refcnt_type - (i32.add (get_global $mem) (i32.mul_u $mv_idx 8))) - - ;; Returns the memory index mem of mv - ;; Will usually be used with a load or store by the caller - (func $MalVal_index (param $mv i32) (result i32) - ;; MalVal memory 64 bit (2 * i32) aligned - (i32.div_u (i32.sub_u $mv (get_global $mem)) 8)) + (i32.add (get_global $mem) (i32.mul_u $mv_idx 4))) ;; Returns the address of 'mem[mv_idx].refcnt_type' (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) @@ -60,31 +60,40 @@ ;;; type = mv->refcnt_type & 31 (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 + (func $SET_TYPE (param $mv i32 $type i32) + ;;; type = mv->refcnt_type & 31 + ;;; mv->refcnt_type += - (mv->refcnt_type & 31) + type + (i32.store $mv (i32.or + (i32.and $type 0x1f) ;; 0x1f == 31 + (i32.and (i32.load $mv) 0xffffffe1))) + ) + + (func $REFS (param $mv i32) (result i32) ;;; type = mv->refcnt_type & 31 (i32.shr_u (i32.load $mv) 5)) ;; / 32 ;; Returns the address of 'mem[mv_idx].val[val]' ;; Will usually be used with a load or store by the caller - (func $MalVal_val_ptr (param $mv_idx i32) (param $val i32) (result i32) + (func $MalVal_val_ptr (param $mv_idx i32 $val i32) (result i32) (i32.add (i32.add ($MalVal_ptr $mv_idx) 4) (i32.mul_u $val 4))) ;; Returns the value of 'mem[mv_idx].val[val]' - (func $MalVal_val (param $mv_idx i32) (param $val i32) (result i32) + (func $MalVal_val (param $mv_idx i32 $val i32) (result i32) (i32.load ($MalVal_val_ptr $mv_idx $val))) (func $MalType_size (param $type i32) (result i32) ;;; if (type <= 5 || type == 9 || type == 12) - (if i32 (i32.or (i32.le_u $type 5) - (i32.or (i32.eq $type 9) - (i32.eq $type 12))) + (if i32 (OR (i32.le_u $type 5) + (i32.eq $type 9) + (i32.eq $type 12)) (then 2) (else ;;; else if (type == 8 || type == 10 || type == 11) - (if i32 (i32.or (i32.eq $type 8) - (i32.or (i32.eq $type 10) - (i32.eq $type 11))) + (if i32 (OR (i32.eq $type 8) + (i32.eq $type 10) + (i32.eq $type 11)) (then 4) (else 3))))) @@ -110,10 +119,12 @@ ($init_sprintf_mem) - ;; 100 character error_str static buffer - (set_global $error_str " ") - ;; 256 character token static buffer - (set_global $token " ") + ;; error_str string buffer + (set_global $error_str (STATIC_ARRAY 100)) + ;; reader token string buffer + (set_global $token_buf (STATIC_ARRAY 256)) + ;; printer string buffer + (set_global $printer_buf (STATIC_ARRAY 4096)) (set_local $heap_size (i32.add (get_global $MEM_SIZE) (get_global $STRING_MEM_SIZE))) @@ -154,11 +165,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; memory management - (func $ALLOC_INTERNAL (param $type i32) (param $val1 i32) - (param $val2 i32) (param $val3 i32) (result i32) - (local $prev i32) - (local $res i32) - (local $size i32) + (func $ALLOC_INTERNAL (param $type i32 + $val1 i32 $val2 i32 $val3 i32) (result i32) + (local $prev i32 $res i32 $size i32) (set_local $prev (get_global $mem_free_list)) (set_local $res (get_global $mem_free_list)) (set_local $size ($MalType_size $type)) @@ -218,7 +227,8 @@ ;;; mem[res].val[0] = val1 (i32.store ($MalVal_val_ptr $res 0) $val1) ;;; if (type > 5 && type != 9) - (if (i32.and (i32.gt_u $type 5) (i32.ne $type 9)) + (if (AND (i32.gt_u $type 5) + (i32.ne $type 9)) (then ;; inc refcnt of referenced value ;;; mem[val1].refcnt_type += 32 @@ -247,28 +257,22 @@ ($MalVal_ptr $res) ) - (func $ALLOC_SCALAR (param $type i32) (param $val1 i32) (result i32) + (func $ALLOC_SCALAR (param $type i32 $val1 i32) (result i32) ($ALLOC_INTERNAL $type $val1 0 0) ) - (func $ALLOC (param $type i32) (param $val1 i32) - (param $val2 i32) (param $val3 i32) (result i32) - ($ALLOC_INTERNAL $type - ($MalVal_index $val1) - ($MalVal_index $val2) - ($MalVal_index $val3)) + (func $ALLOC (param $type i32 $val1 i32 $val2 i32 $val3 i32) (result i32) + ($ALLOC_INTERNAL $type ($IDX $val1) ($IDX $val2) ($IDX $val3)) ) (func $RELEASE (param $mv i32) - (local $idx i32) - (local $type i32) - (local $size i32) + (local $idx i32 $type i32 $size i32) ;; Ignore NULLs ;;; if (mv == NULL) { return; } (if (i32.eqz $mv) (return)) ;;; idx = mv - mem - (set_local $idx ($MalVal_index $mv)) + (set_local $idx ($IDX $mv)) ;;; type = mv->refcnt_type & 31 (set_local $type (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 ;;; size = MalType_size(type) @@ -309,8 +313,8 @@ (return)) (block $done - (block (block (block (block (block (block - (br_table 0 0 0 0 1 1 2 2 3 5 5 5 5 4 5 5 5 $type)) + (block (block (block (block (block (block (block (block (block + (br_table 0 0 0 0 1 1 2 2 3 0 4 4 5 6 7 8 8 $type)) ;; nil, boolean, integer, float (br $done)) ;; string, kw, symbol @@ -332,12 +336,27 @@ ($RELEASE ($MEM_VAL2_ptr $mv)) ($RELEASE ($MEM_VAL1_ptr $mv)))) (br $done)) + ;; mal / macro function + ;; release ast, params, and environment + ($RELEASE ($MEM_VAL2_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)) + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) + ;; atom + ;; release contained/referred value + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) ;; env ;; if outer is set then release outer (if (i32.ne ($MalVal_val $idx 1) 0) ($RELEASE ($MEM_VAL1_ptr $mv))) - ;; release the hashmap data + ;; release the env data (hashmap) + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) + ;; metadata + ;; release object and metdata object ($RELEASE ($MEM_VAL0_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)) (br $done)) ;; default/unknown ) @@ -356,13 +375,10 @@ ;; Allocate a string as follows: ;; refcnt (i32 set to 1), string data, NULL byte (func $STRING_DUPE (param $str i32) (result i32) - (local $len i32) - (local $cur i32) - (local $new i32) - (local $idx i32) + (local $len i32 $cur i32 $new i32 $idx i32) ;; Calculate length of string needed - (set_local $len ($STRING_LEN $str)) + (set_local $len ($strlen $str)) ;; leading i32 refcnt + trailing NULL (set_local $new ($malloc (i32.add 5 $len))) @@ -375,23 +391,19 @@ (i32.store8_u (i32.add $cur $len) 0) ;; Copy the characters - ($MEM_COPY $cur $str $len) + ($memmove $cur $str $len) $new ) ;; Duplicate regular character array string into a Mal string and ;; return the MalVal pointer - (func $STRING (param $type i32) (param $str i32) (result i32) - ($ALLOC_SCALAR - $type - ($STRING_DUPE $str)) + (func $STRING (param $type i32 $str i32) (result i32) + ($ALLOC_SCALAR $type ($STRING_DUPE $str)) ) (func $RELEASE_STRING (param $mv i32) (local $str i32) - (set_local $str ($MalVal_val - ($MalVal_index $mv) - 0)) + (set_local $str ($MalVal_val ($IDX $mv) 0)) ;; DEBUG ;; ($printf_1 "RELEASE_STRING - calling free on: %d" $str) diff --git a/wasm/printer.wam b/wasm/printer.wam index 28e9e1a87e..95afdc482d 100644 --- a/wasm/printer.wam +++ b/wasm/printer.wam @@ -1,12 +1,11 @@ (module $printer - (func $pr_str_val (param $res i32) (param $mv i32) (result i32) - (local $type i32) - (local $val0 i32) - (local $sval i32) + (global $printer_buf (mut i32) 0) + + (func $pr_str_val (param $res i32 $mv i32 $print_readably i32) (result i32) + (local $type i32 $val0 i32 $sval i32) (set_local $type ($TYPE $mv)) - (set_local $val0 ($MalVal_val ($MalVal_index $mv) - 0)) + (set_local $val0 ($VAL0 $mv)) ;;; switch(type) (block $done @@ -15,18 +14,18 @@ (block (block (block (block (block (block (block (block (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 $type)) ;; 0: nil - ($MEM_COPY $res "nil" 4) + ($memmove $res "nil" 4) (set_local $res (i32.add 3 $res)) (br $done)) ;; 1: boolean (if (i32.eq $val0 0) (then ;; false - ($MEM_COPY $res "false" 5) + ($memmove $res "false" 6) (set_local $res (i32.add 5 $res))) (else ;; true - ($MEM_COPY $res "true" 4) + ($memmove $res "true" 5) (set_local $res (i32.add 4 $res)))) (br $done)) ;; 2: integer @@ -40,8 +39,17 @@ (if (i32.eq (i32.load8_u $sval) (CHR "\x7f")) (then (set_local $res ($sprintf_1 $res ":%s" (i32.add $sval 1)))) - (else - (set_local $res ($sprintf_1 $res "\"%s\"" ($to_String $mv))))) + (else (if $print_readably + (then + ;; escape backslashes, quotes, and newlines + (set_local $res ($sprintf_1 $res "\"" 0)) + (set_local $res (i32.add $res ($REPLACE3 $res ($to_String $mv) + "\\" "\\\\" + "\"" "\\\"" + "\n" "\\n"))) + (set_local $res ($sprintf_1 $res "\"" 0))) + (else + (set_local $res ($sprintf_1 $res "%s" $sval)))))) (br $done)) ;; 5: symbol (set_local $res ($sprintf_1 $res "%s" ($to_String $mv))) @@ -65,21 +73,21 @@ (if (i32.eq ($VAL0 $mv) 0) (br $done_seq)) ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) - (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv))) + (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) ;; if this is a hash-map, print the next element (if (i32.eq $type (get_global $HASHMAP_T)) (then ;;; res += snprintf(res, 2, " ") (set_local $res ($sprintf_1 $res " " 0)) - (set_local $res ($pr_str_val $res ($MEM_VAL2_ptr $mv))))) + (set_local $res ($pr_str_val $res ($MEM_VAL2_ptr $mv) + $print_readably)))) ;;; mv = MEM_VAL0(mv) (set_local $mv ($MEM_VAL0_ptr $mv)) ;;; if (VAL0(mv) != 0) (if (i32.ne ($VAL0 $mv) 0) ;;; res += snprintf(res, 2, " ") (set_local $res ($sprintf_1 $res " " 0))) - ;;($print "here4\n") (br $seq_loop) ) ) @@ -93,45 +101,80 @@ (else (CHR "}"))))))) (br $done)) ;; 9: function - ($MEM_COPY $res "#" 10) + ($memmove $res "#" 10) (set_local $res (i32.add 9 $res)) (br $done)) ;; 10: mal function - ($MEM_COPY $res "(fn* ...)" 10) - (set_local $res (i32.add 9 $res)) + ($memmove $res "(fn* " 6) + (set_local $res (i32.add 5 $res)) + (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + ($memmove $res " " 2) + (set_local $res (i32.add 1 $res)) + (set_local $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + ($memmove $res ")" 2) + (set_local $res (i32.add 1 $res)) (br $done)) ;; 11: macro fn - ($print "macro fn") - ($MEM_COPY $res "#" 13) + ($memmove $res "#" 13) (set_local $res (i32.add 12 $res)) (br $done)) ;; 12: atom - ($MEM_COPY $res "(atom ...)" 11) - (set_local $res (i32.add 10 $res)) + ($memmove $res "(atom " 7) + (set_local $res (i32.add 6 $res)) + (set_local $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + ($memmove $res ")" 2) + (set_local $res (i32.add 1 $res)) (br $done)) ;; 13: environment - ($MEM_COPY $res "#" 11) + ($memmove $res "#" 11) (set_local $res (i32.add 10 $res)) (br $done)) ;; 14: metadata - ($MEM_COPY $res "#" 12) - (set_local $res (i32.add 11 $res)) + ;; recur on object itself + (set_local $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) (br $done)) ;; 15: FREE - ($MEM_COPY $res "#" 12) + ($memmove $res "#" 12) (set_local $res (i32.add 11 $res)) (br $done)) ;; 16: default - ($MEM_COPY $res "#" 11) + ($memmove $res "#" 11) (set_local $res (i32.add 10 $res)) ) $res ) - (func $pr_str (param $mv i32) (result i32) - (drop ($pr_str_val (get_global $sprintf_buf) $mv)) - ($STRING (get_global $STRING_T) (get_global $sprintf_buf)) + (func $pr_str_internal (param $seq i32) (param $mv i32) + (param $print_readably i32) (param $sep i32) (result i32) + (local $res i32) + (set_local $res (get_global $printer_buf)) + (i32.store8_u $res 0) + + (if $seq + (then + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $mv)) (br $done)) + (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + (set_local $mv ($MEM_VAL0_ptr $mv)) + (if (i32.ne ($VAL0 $mv) 0) + (set_local $res ($sprintf_1 $res "%s" $sep))) + (br $loop) + ) + )) + (else + (set_local $res ($pr_str_val $res $mv $print_readably)))) + + ($STRING (get_global $STRING_T) (get_global $printer_buf)) + ) + + (func $pr_str (param $mv i32 $print_readably i32) (result i32) + ($pr_str_internal 0 $mv $print_readably "") + ) + + (func $pr_str_seq (param $mv i32 $print_readably i32 $sep i32) (result i32) + ($pr_str_internal 1 $mv $print_readably $sep) ) (export "pr_str" (func $pr_str)) diff --git a/wasm/reader.wam b/wasm/reader.wam index af13e90123..6d728d96f3 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -1,21 +1,19 @@ (module $reader ;; TODO: global warning - (global $token (mut i32) 0) + (global $token_buf (mut i32) 0) (global $read_index (mut i32) 0) (func $skip_spaces (param $str i32) (result i32) - (local $found i32) - (local $c i32) + (local $found i32 $c i32) (set_local $found 0) (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) (block $done (loop $loop ;;; while (c == ' ' || c == ',' || c == '\n') - (if (i32.and (i32.and - (i32.ne $c (CHR " ")) - (i32.ne $c (CHR ","))) - (i32.ne $c (CHR "\n"))) + (if (AND (i32.ne $c (CHR " ")) + (i32.ne $c (CHR ",")) + (i32.ne $c (CHR "\n"))) (br $done)) (set_local $found 1) ;;; c=str[++(*index)] @@ -29,8 +27,7 @@ ) (func $skip_to_eol (param $str i32) (result i32) - (local $found i32) - (local $c i32) + (local $found i32 $c i32) (set_local $found 0) (set_local $c (i32.load8_c (i32.add $str (get_global $read_index)))) (if (i32.eq $c (CHR ";")) @@ -43,7 +40,8 @@ (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) ;;; while (c != '\0' && c != '\n') - (if (i32.and (i32.ne $c (CHR "\x00")) (i32.ne $c (CHR "\n"))) + (if (AND (i32.ne $c (CHR "\x00")) + (i32.ne $c (CHR "\n"))) (br $loop)) ) ))) @@ -61,10 +59,7 @@ ) (func $read_token (param $str i32) (result i32) - (local $token_index i32) - (local $instring i32) - (local $escaped i32) - (local $c i32) + (local $token_index i32 $instring i32 $escaped i32 $c i32) (set_local $token_index 0) (set_local $instring 0) (set_local $escaped 0) @@ -77,21 +72,21 @@ (set_global $read_index (i32.add (get_global $read_index) 1)) ;; read first character ;;; token[token_index++] = c - (i32.store8_u (i32.add (get_global $token) $token_index) $c) + (i32.store8_u (i32.add (get_global $token_buf) $token_index) $c) (set_local $token_index (i32.add $token_index 1)) ;; single/double character token - (if (i32.or (i32.eq $c (CHR "(")) - (i32.or (i32.eq $c (CHR ")")) - (i32.or (i32.eq $c (CHR "[")) - (i32.or (i32.eq $c (CHR "]")) - (i32.or (i32.eq $c (CHR "{")) - (i32.or (i32.eq $c (CHR "}")) - (i32.or (i32.eq $c (CHR "'")) - (i32.or (i32.eq $c (CHR "`")) - (i32.or (i32.eq $c (CHR "@")) - (i32.and (i32.eq $c (CHR "~")) - (i32.eq (i32.load8_u (i32.add $str (get_global $read_index))) - (CHR "@")))))))))))) + (if (OR (i32.eq $c (CHR "(")) + (i32.eq $c (CHR ")")) + (i32.eq $c (CHR "[")) + (i32.eq $c (CHR "]")) + (i32.eq $c (CHR "{")) + (i32.eq $c (CHR "}")) + (i32.eq $c (CHR "'")) + (i32.eq $c (CHR "`")) + (i32.eq $c (CHR "@")) + (AND (i32.eq $c (CHR "~")) + (i32.ne (i32.load8_u (i32.add $str (get_global $read_index))) + (CHR "@")))) (then ;; continue @@ -111,32 +106,32 @@ (if (i32.eqz $instring) (then ;; next character is token delimiter - (if (i32.or (i32.eq $c (CHR "(")) - (i32.or (i32.eq $c (CHR ")")) - (i32.or (i32.eq $c (CHR "[")) - (i32.or (i32.eq $c (CHR "]")) - (i32.or (i32.eq $c (CHR "{")) - (i32.or (i32.eq $c (CHR "}")) - (i32.or (i32.eq $c (CHR " ")) - (i32.or (i32.eq $c (CHR ",")) - (i32.eq $c (CHR "\n")))))))))) + (if (OR (i32.eq $c (CHR "(")) + (i32.eq $c (CHR ")")) + (i32.eq $c (CHR "[")) + (i32.eq $c (CHR "]")) + (i32.eq $c (CHR "{")) + (i32.eq $c (CHR "}")) + (i32.eq $c (CHR " ")) + (i32.eq $c (CHR ",")) + (i32.eq $c (CHR "\n"))) (br $done)))) ;; read next character ;;; token[token_index++] = str[(*index)++] - (i32.store8_u (i32.add (get_global $token) $token_index) + (i32.store8_u (i32.add (get_global $token_buf) $token_index) (i32.load8_u (i32.add $str (get_global $read_index)))) (set_local $token_index (i32.add $token_index 1)) (set_global $read_index (i32.add (get_global $read_index) 1)) ;;; if (token[0] == '~' && token[1] == '@') break - (if (i32.and (i32.eq (i32.load8_u (i32.add (get_global $token) 0)) - (CHR "~")) - (i32.eq (i32.load8_u (i32.add (get_global $token) 1)) - 0x40)) + (if (AND (i32.eq (i32.load8_u (i32.add (get_global $token_buf) 0)) + (CHR "~")) + (i32.eq (i32.load8_u (i32.add (get_global $token_buf) 1)) + (CHR "@"))) (br $done)) ;;; if ((!instring) || escaped) - (if (i32.or (i32.eqz $instring) $escaped) + (if (OR (i32.eqz $instring) $escaped) (then (set_local $escaped 0) (br $loop))) @@ -149,21 +144,15 @@ ))) ;;; token[token_index] = '\0' - (i32.store8_u (i32.add (get_global $token) $token_index) 0) - (get_global $token) + (i32.store8_u (i32.add (get_global $token_buf) $token_index) 0) + (get_global $token_buf) ) - (func $read_seq (param $str i32) (param $type i32) (param $end i32) - (result i32) - (local $res i32) - (local $val2 i32) - (local $val3 i32) - (local $c i32) + (func $read_seq (param $str i32 $type i32 $end i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $c i32) ;; MAP_LOOP stack - (local $ret i32) - (local $empty i32) - (local $current i32) + (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP_START (set_local $res ($MAP_LOOP_START $type)) @@ -223,12 +212,29 @@ $ret ) + (func $read_macro (param $str i32 $sym i32 $with_meta i32) (result i32) + (local $first i32 $second i32 $third i32 $res i32) + (set_local $first ($STRING (get_global $SYMBOL_T) $sym)) + (set_local $second ($read_form $str)) + (set_local $res $second) + (if (get_global $error_type) (return $res)) + (if (i32.eqz $with_meta) + (then + (set_local $res ($LIST2 $first $second))) + (else + (set_local $third ($read_form $str)) + (set_local $res ($LIST3 $first $third $second)) + ;; release values, list has ownership + ($RELEASE $third))) + ;; release values, list has ownership + ($RELEASE $second) + ($RELEASE $first) + $res + ) + (func $read_form (param $str i32) (result i32) ;;($STRING (get_global $STRING_T) $str) - (local $tok i32) - (local $c0 i32) - (local $c1 i32) - (local $res i32) + (local $tok i32 $c0 i32 $c1 i32 $res i32 $slen i32) (if (get_global $error_type) (return 0)) @@ -241,40 +247,67 @@ (if (i32.eq $c0 0) (then (return ($INC_REF (get_global $NIL)))) - (else (if (i32.or (i32.and (i32.ge_u $c0 (CHR "0")) - (i32.le_u $c0 (CHR "9"))) - (i32.and (i32.eq $c0 (CHR "-")) - (i32.and (i32.ge_u $c1 (CHR "0")) - (i32.le_u $c1 (CHR "9"))))) + (else (if (OR (AND (i32.ge_u $c0 (CHR "0")) + (i32.le_u $c0 (CHR "9"))) + (AND (i32.eq $c0 (CHR "-")) + (i32.ge_u $c1 (CHR "0")) + (i32.le_u $c1 (CHR "9")))) (then - (return ($INTEGER ($ATOI $tok)))) + (return ($INTEGER ($atoi $tok)))) (else (if (i32.eq $c0 (CHR ":")) (then (i32.store8_u $tok (CHR "\x7f")) (return ($STRING (get_global $STRING_T) $tok))) (else (if (i32.eq $c0 (CHR "\"")) (then - ;; TODO: unescape - (i32.store8_u (i32.sub_u (i32.add $tok ($STRING_LEN $tok)) 1) - (CHR "\x00")) - (return ($STRING (get_global $STRING_T) (i32.add $tok 1)))) + (set_local $slen ($strlen (i32.add $tok 1))) + (if (i32.ne (i32.load8_u (i32.add $tok $slen)) (CHR "\"")) + (then + ($THROW_STR_0 "expected '\"'") + (return 0)) + (else + ;; unescape backslashes, quotes, and newlines + ;; remove the trailing quote + (i32.store8_u (i32.add $tok $slen) (CHR "\x00")) + (set_local $tok (i32.add $tok 1)) + (drop ($REPLACE3 0 $tok + "\\\"" "\"" + "\\n" "\n" + "\\\\" "\\")) + (return ($STRING (get_global $STRING_T) $tok))))) + (else (if (i32.eqz ($strcmp "nil" $tok)) + (then (return ($INC_REF (get_global $NIL)))) + (else (if (i32.eqz ($strcmp "false" $tok)) + (then (return ($INC_REF (get_global $FALSE)))) + (else (if (i32.eqz ($strcmp "true" $tok)) + (then (return ($INC_REF (get_global $TRUE)))) + (else (if (i32.eqz ($strcmp "'" $tok)) + (then (return ($read_macro $str "quote" 0))) + (else (if (i32.eqz ($strcmp "`" $tok)) + (then (return ($read_macro $str "quasiquote" 0))) + (else (if (i32.eqz ($strcmp "~@" $tok)) + (then (return ($read_macro $str "splice-unquote" 0))) + (else (if (i32.eqz ($strcmp "~" $tok)) + (then (return ($read_macro $str "unquote" 0))) + (else (if (i32.eqz ($strcmp "^" $tok)) + (then (return ($read_macro $str "with-meta" 1))) + (else (if (i32.eqz ($strcmp "@" $tok)) + (then (return ($read_macro $str "deref" 0))) (else (if (i32.eq $c0 (CHR "(")) - (then - (return ($read_seq $str (get_global $LIST_T) (CHR ")")))) + (then (return ($read_seq $str (get_global $LIST_T) (CHR ")")))) (else (if (i32.eq $c0 (CHR "[")) - (then - (return ($read_seq $str (get_global $VECTOR_T) (CHR "]")))) + (then (return ($read_seq $str (get_global $VECTOR_T) (CHR "]")))) (else (if (i32.eq $c0 (CHR "{")) - (then - (return ($read_seq $str (get_global $HASHMAP_T) (CHR "}")))) - (else (if (i32.or (i32.eq $c0 (CHR ")")) - (i32.or (i32.eq $c0 (CHR "]")) - (i32.eq $c0 (CHR "}")))) + (then (return ($read_seq $str (get_global $HASHMAP_T) (CHR "}")))) + (else (if (OR (i32.eq $c0 (CHR ")")) + (i32.eq $c0 (CHR "]")) + (i32.eq $c0 (CHR "}"))) (then ($THROW_STR_1 "unexpected '%c'" $c0) (return 0)) (else - (return ($STRING (get_global $SYMBOL_T) $tok)))))))))))))))))) + (return ($STRING (get_global $SYMBOL_T) $tok)))) + )))))))))))))))))))))))))))))))) ) (func $read_str (param $str i32) (result i32) diff --git a/wasm/step0_repl.wam b/wasm/step0_repl.wam index fd663b607c..a1b4a07add 100644 --- a/wasm/step0_repl.wam +++ b/wasm/step0_repl.wam @@ -1,6 +1,4 @@ (module $step0_repl - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) ;; READ (func $READ (param $str i32) (result i32) @@ -25,7 +23,7 @@ ;; Constant location/value definitions (local $line i32) - ;; Start + ;; Start REPL (block $repl_done (loop $repl_loop (set_local $line ($readline "user> ")) diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam index 2253021df1..a9e017b0b0 100644 --- a/wasm/step1_read_print.wam +++ b/wasm/step1_read_print.wam @@ -1,6 +1,4 @@ (module $step1_read_print - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) ;; READ (func $READ (param $str i32) (result i32) @@ -8,20 +6,18 @@ ) ;; EVAL - (func $EVAL (param $ast i32) (param $env i32) (result i32) + (func $EVAL (param $ast i32 $env i32) (result i32) $ast ) ;; PRINT (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast) + ($pr_str $ast 1) ) ;; REPL - (func $rep (param $line i32) (param $env i32) (result i32) - (local $mv1 i32) - (local $mv2 i32) - (local $ms i32) + (func $REP (param $line i32 $env i32) (result i32) + (local $mv1 i32 $mv2 i32 $ms i32) (block $rep_done (set_local $mv1 ($READ $line)) (if (get_global $error_type) (br $rep_done)) @@ -33,15 +29,13 @@ (set_local $ms ($PRINT $mv2)) ) -;; ($PR_MEMORY -1 -1) + ;; release memory from MAL_READ ($RELEASE $mv1) $ms ) (func $main (result i32) - ;; Constant location/value definitions - (local $line i32) - (local $res i32) + (local $line i32 $res i32) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -49,11 +43,7 @@ ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) - ($PR_MEMORY -1 -1) -;; ($PR_MEMORY_RAW (get_global $mem) -;; (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) -;; 8))) + ;;($PR_MEMORY -1 -1) ;; Start (block $repl_done @@ -64,7 +54,7 @@ (then ($free $line) (br $repl_loop))) - (set_local $res ($rep $line 0)) + (set_local $res ($REP $line 0)) (if (get_global $error_type) (then ($printf_1 "Error: %s\n" (get_global $error_str)) @@ -77,7 +67,7 @@ (br $repl_loop))) ($print "\n") - ($PR_MEMORY -1 -1) + ;;($PR_MEMORY -1 -1) 0 ) diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam index ca9a24a7ac..c8852852b2 100644 --- a/wasm/step2_eval.wam +++ b/wasm/step2_eval.wam @@ -1,6 +1,6 @@ -(module $step1_read_print - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) +(module $step2_eval + + (global $repl_env (mut i32) (i32.const 0)) ;; READ (func $READ (param $str i32) (result i32) @@ -8,20 +8,16 @@ ) ;; EVAL - (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) - (local $res i32) - (local $val2 i32) - (local $val3 i32) - (local $ret i32) - (local $empty i32) - (local $current i32) - (local $type i32) + (func $EVAL_AST (param $ast i32 $env i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) (local $res2 i64) - (local $found i32) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + ;;; switch(type) (block $done (block $default (block (block @@ -50,8 +46,7 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) - (br $done)) + (if (i32.eq ($VAL0 $ast) 0) (br $done)) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -73,7 +68,7 @@ (then (set_local $val3 $val2) (set_local $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $ast)))) + (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) @@ -105,13 +100,9 @@ (elem $add $subtract $multiply $divide)) - (func $EVAL (param $ast i32) (param $env i32) (result i32) + (func $EVAL (param $ast i32 $env i32) (result i32) (local $res i32) - (local $f_args i32) - (local $f i32) - (local $args i32) - (local $type i32) - (local $ftype i32) + (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) (set_local $res 0) (set_local $f_args 0) @@ -154,14 +145,12 @@ ;; PRINT (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast) + ($pr_str $ast 1) ) ;; REPL - (func $rep (param $line i32) (param $env i32) (result i32) - (local $mv1 i32) - (local $mv2 i32) - (local $ms i32) + (func $REP (param $line i32 $env i32) (result i32) + (local $mv1 i32 $mv2 i32 $ms i32) (block $rep_done (set_local $mv1 ($READ $line)) (if (get_global $error_type) (br $rep_done)) @@ -197,10 +186,7 @@ ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $main (result i32) - ;; Constant location/value definitions - (local $line i32) - (local $res i32) - (local $repl_env i32) + (local $line i32 $res i32 $repl_env i32) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -209,20 +195,17 @@ ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) - (set_local $repl_env ($HASHMAP)) + (set_global $repl_env ($HASHMAP)) + (set_local $repl_env (get_global $repl_env)) (set_local $repl_env ($ASSOC1_S $repl_env "+" ($FUNCTION 0))) (set_local $repl_env ($ASSOC1_S $repl_env "-" ($FUNCTION 1))) (set_local $repl_env ($ASSOC1_S $repl_env "*" ($FUNCTION 2))) (set_local $repl_env ($ASSOC1_S $repl_env "/" ($FUNCTION 3))) - ($PR_MEMORY -1 -1) -;; ($PR_MEMORY_RAW (get_global $mem) -;; (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) -;; 8))) + ;;($PR_MEMORY -1 -1) - ;; Start + ;; Start REPL (block $repl_done (loop $repl_loop (set_local $line ($readline "user> ")) @@ -231,7 +214,7 @@ (then ($free $line) (br $repl_loop))) - (set_local $res ($rep $line $repl_env)) + (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then ($printf_1 "Error: %s\n" (get_global $error_str)) @@ -244,7 +227,7 @@ (br $repl_loop))) ($print "\n") - ($PR_MEMORY -1 -1) + ;;($PR_MEMORY -1 -1) 0 ) diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam index 8044dff42e..83de79e720 100644 --- a/wasm/step3_env.wam +++ b/wasm/step3_env.wam @@ -1,6 +1,6 @@ -(module $step1_read_print - (import "env" "memory" (memory $0 256)) - (import "env" "memoryBase" (global $memoryBase i32)) +(module $step3_env + + (global $repl_env (mut i32) (i32.const 0)) ;; READ (func $READ (param $str i32) (result i32) @@ -8,19 +8,15 @@ ) ;; EVAL - (func $EVAL_AST (param $ast i32) (param $env i32) (result i32) - (local $res i32) - (local $val2 i32) - (local $val3 i32) - (local $ret i32) - (local $empty i32) - (local $current i32) - (local $type i32) - (local $found i32) + (func $EVAL_AST (param $ast i32 $env i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + ;;; switch(type) (block $done (block $default (block (block @@ -41,8 +37,7 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) - (br $done)) + (if (i32.eq ($VAL0 $ast) 0) (br $done)) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -64,7 +59,7 @@ (then (set_local $val3 $val2) (set_local $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $ast)))) + (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) @@ -103,17 +98,10 @@ (func $MAL_GET_A3 (param $ast i32) (result i32) ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - (func $EVAL (param $ast i32) (param $env i32) (result i32) + (func $EVAL (param $ast i32 $env i32) (result i32) (local $res i32) - (local $f_args i32) - (local $f i32) - (local $args i32) - (local $type i32) - (local $ftype i32) - (local $a0 i32) - (local $a0sym i32) - (local $a1 i32) - (local $a2 i32) + (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) (local $let_env i32) (set_local $res 0) @@ -126,8 +114,7 @@ (if (get_global $error_type) (return 0)) - (if (i32.ne $type (get_global $LIST_T)) - (return ($EVAL_AST $ast $env))) + (if (i32.ne $type (get_global $LIST_T)) (return ($EVAL_AST $ast $env))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) @@ -203,15 +190,14 @@ $res ) + ;; PRINT (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast) + ($pr_str $ast 1) ) ;; REPL - (func $rep (param $line i32) (param $env i32) (result i32) - (local $mv1 i32) - (local $mv2 i32) - (local $ms i32) + (func $REP (param $line i32 $env i32) (result i32) + (local $mv1 i32 $mv2 i32 $ms i32) (block $rep_done (set_local $mv1 ($READ $line)) (if (get_global $error_type) (br $rep_done)) @@ -250,10 +236,7 @@ ($INC_REF (get_global $NIL))) (func $main (result i32) - ;; Constant location/value definitions - (local $line i32) - (local $res i32) - (local $repl_env i32) + (local $line i32 $res i32 $repl_env i32) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -262,20 +245,17 @@ ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) - (set_local $repl_env ($ENV_NEW (get_global $NIL))) + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) (drop ($ENV_SET_S $repl_env "+" ($FUNCTION 0))) (drop ($ENV_SET_S $repl_env "-" ($FUNCTION 1))) (drop ($ENV_SET_S $repl_env "*" ($FUNCTION 2))) (drop ($ENV_SET_S $repl_env "/" ($FUNCTION 3))) - ($PR_MEMORY -1 -1) -;; ($PR_MEMORY_RAW (get_global $mem) -;; (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) -;; 8))) + ;;($PR_MEMORY -1 -1) - ;; Start + ;; Start REPL (block $repl_done (loop $repl_loop (set_local $line ($readline "user> ")) @@ -284,7 +264,7 @@ (then ($free $line) (br $repl_loop))) - (set_local $res ($rep $line $repl_env)) + (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then ($printf_1 "Error: %s\n" (get_global $error_str)) @@ -297,7 +277,7 @@ (br $repl_loop))) ($print "\n") - ($PR_MEMORY -1 -1) + ;;($PR_MEMORY -1 -1) 0 ) diff --git a/wasm/step4_if_fn_do.wam b/wasm/step4_if_fn_do.wam new file mode 100644 index 0000000000..f87754176a --- /dev/null +++ b/wasm/step4_if_fn_do.wam @@ -0,0 +1,325 @@ +(module $step4_if_fn_do + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $ast i32 $env i32) (result i32) + (local $res i32 $el i32) + (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32 $a3 i32) + (local $let_env i32 $fn_env i32 $a i32) + + (set_local $res 0) + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (return 0)) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (return ($EVAL_AST $ast $env))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (return ($INC_REF $ast))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (return $res)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res))) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $let_env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) + $let_env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + (set_local $res ($EVAL $a2 $let_env)) + ;; EVAL_RETURN + ($RELEASE $let_env)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env)) + (set_local $res ($LAST $el)) + ($RELEASE $el)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL)))) + (else + (set_local $a3 ($MAL_GET_A3 $ast)) + (set_local $res ($EVAL $a3 $env))))) + (else + ($RELEASE $res) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env))))))) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($ALLOC (get_global $MALFUNC_T) $a2 $a1 $env))) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) (return $f_args)) + + ;; rest + (set_local $args ($MEM_VAL0_ptr $f_args)) + ;; value + (set_local $f ($MEM_VAL1_ptr $f_args)) + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))) + ;; release f/args + ($RELEASE $f_args)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + (set_local $fn_env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; claim the AST before releasing the list containing it + (set_local $a ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $a)) + + ;; release f/args + ($RELEASE $f_args) + + (set_local $res ($EVAL $a $fn_env)) + ;; EVAL_RETURN + ($RELEASE $fn_env) + ($RELEASE $a)) + (else + ;; create new environment using env and params stored in function + ($THROW_STR_1 "apply of non-function type: %d\n" $type) + (set_local $res 0) + ($RELEASE $f_args))))))))))))))) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (result i32) + (local $line i32 $res i32 $repl_env i32) + + ;; DEBUG + ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) + ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) + ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam new file mode 100644 index 0000000000..e9db72eb5b --- /dev/null +++ b/wasm/step5_tco.wam @@ -0,0 +1,374 @@ +(module $step5_tco + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if $skiplast + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) + (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + + (set_local $ast $orig_ast) + (set_local $env $orig_env) + (set_local $prev_ast 0) + (set_local $prev_env 0) + (set_local $res 0) + + (block $EVAL_return + (loop $TCO_loop + + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (then + (set_local $res 0) + (br $EVAL_return))) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (then + (set_local $res ($INC_REF $ast)) + (br $EVAL_return))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $prev_env $env) ;; save env for later release + (set_local $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (set_local $ast ($LAST $ast)) + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL))) + (br $EVAL_return)) + (else + (set_local $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (set_local $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env 0)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) + (then + (set_local $res $f_args) + (br $EVAL_return))) + + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + ;; save the current environment for release + (set_local $prev_env $env) + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (set_local $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (set_local $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (result i32) + (local $line i32 $res i32 $repl_env i32) + + ;; DEBUG + ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) + ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) + ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam new file mode 100644 index 0000000000..e58c424529 --- /dev/null +++ b/wasm/step6_file.wam @@ -0,0 +1,430 @@ +(module $step6_file + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if $skiplast + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) + (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + + (set_local $ast $orig_ast) + (set_local $env $orig_env) + (set_local $prev_ast 0) + (set_local $prev_env 0) + (set_local $res 0) + + (block $EVAL_return + (loop $TCO_loop + + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (then + (set_local $res 0) + (br $EVAL_return))) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (then + (set_local $res ($INC_REF $ast)) + (br $EVAL_return))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $prev_env $env) ;; save env for later release + (set_local $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (set_local $ast ($LAST $ast)) + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL))) + (br $EVAL_return)) + (else + (set_local $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (set_local $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env 0)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) + (then + (set_local $res $f_args) + (br $EVAL_return))) + + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (set_local $res ($EVAL ($MEM_VAL1_ptr $args) + (get_global $repl_env)))) + (else + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + ;; save the current environment for release + (set_local $prev_env $env) + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (set_local $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (set_local $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (local $line i32 $res i32 $repl_env i32) + ;; argument processing + (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) + + + ;; Command line arguments + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (set_local $i 2) + (block $done + (loop $loop + (if (i32.ge_u $i $argc) (br $done)) + + (set_local $val2 ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv (i32.mul_u $i 4))))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE + (get_global $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam new file mode 100644 index 0000000000..16b4e8555e --- /dev/null +++ b/wasm/step7_quote.wam @@ -0,0 +1,494 @@ +(module $step7_quote + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $is_pair (param $ast i32) (result i32) + (local $type i32) + (set_local $type ($TYPE $ast)) + (AND (OR (i32.eq $type (get_global $LIST_T)) + (i32.eq $type (get_global $VECTOR_T))) + (i32.ne ($VAL0 $ast) 0)) + ) + + (func $QUASIQUOTE (param $ast i32) (result i32) + (local $sym i32 $res i32 $second i32 $third i32) + (set_local $res 0) + (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE + (then + (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + ;; ['quote ast] + (set_local $res ($LIST2 $sym $ast)) + ($RELEASE $sym)) + (else + (set_local $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "unquote" ($to_String $res)))) + (then + ;; ast[1] + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (else (if (AND ($is_pair $res) + (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) + (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "splice-unquote" + ($to_String ($MEM_VAL1_ptr $res))))) + (then + ;; ['concat, ast[0][1], quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) + (set_local $second + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list take ownership + ($RELEASE $third) + ($RELEASE $sym)) + (else + ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) + (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $third) + ($RELEASE $second) + ($RELEASE $sym))))))) + $res + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if $skiplast + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) + (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + + (set_local $ast $orig_ast) + (set_local $env $orig_env) + (set_local $prev_ast 0) + (set_local $prev_env 0) + (set_local $res 0) + + (block $EVAL_return + (loop $TCO_loop + + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (then + (set_local $res 0) + (br $EVAL_return))) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (then + (set_local $res ($INC_REF $ast)) + (br $EVAL_return))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $prev_env $env) ;; save env for later release + (set_local $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (set_local $ast ($LAST $ast)) + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL))) + (br $EVAL_return)) + (else + (set_local $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (set_local $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env 0)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) + (then + (set_local $res $f_args) + (br $EVAL_return))) + + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (set_local $res ($EVAL ($MEM_VAL1_ptr $args) + (get_global $repl_env)))) + (else + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + ;; save the current environment for release + (set_local $prev_env $env) + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (set_local $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (set_local $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (local $line i32 $res i32 $repl_env i32) + ;; argument processing + (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) + + + ;; Command line arguments + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (set_local $i 2) + (block $done + (loop $loop + (if (i32.ge_u $i $argc) (br $done)) + + (set_local $val2 ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv (i32.mul_u $i 4))))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE + (get_global $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam new file mode 100644 index 0000000000..6fb6da1f2e --- /dev/null +++ b/wasm/step8_macros.wam @@ -0,0 +1,580 @@ +(module $step8_macros + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $is_pair (param $ast i32) (result i32) + (local $type i32) + (set_local $type ($TYPE $ast)) + (AND (OR (i32.eq $type (get_global $LIST_T)) + (i32.eq $type (get_global $VECTOR_T))) + (i32.ne ($VAL0 $ast) 0)) + ) + + (func $QUASIQUOTE (param $ast i32) (result i32) + (local $sym i32 $res i32 $second i32 $third i32) + (set_local $res 0) + (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE + (then + (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + ;; ['quote ast] + (set_local $res ($LIST2 $sym $ast)) + ($RELEASE $sym)) + (else + (set_local $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "unquote" ($to_String $res)))) + (then + ;; ast[1] + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (else (if (AND ($is_pair $res) + (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) + (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "splice-unquote" + ($to_String ($MEM_VAL1_ptr $res))))) + (then + ;; ['concat, ast[0][1], quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) + (set_local $second + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list take ownership + ($RELEASE $third) + ($RELEASE $sym)) + (else + ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) + (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $third) + ($RELEASE $second) + ($RELEASE $sym))))))) + $res + ) + + (global $mac_ast_stack (mut i32) (i32.const 0)) + (global $mac_ast_stack_top (mut i32) (i32.const -1)) + + (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) + (local $ast i32 $mac i32 $mac_env i64) + (set_global $mac_ast_stack (STATIC_ARRAY 128)) + (set_local $ast $orig_ast) + (set_local $mac 0) + (block $done + (loop $loop + (if (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (get_global $SYMBOL_T))) + (br $done)) + (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) + (if (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (get_global $MACRO_T))) + (then + (br $done))) + + (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + ;; PEND_A_LV + ;; if ast is not the first ast that was passed in, then add it + ;; to the pending release list. + (if (i32.ne $ast $orig_ast) + (then + (set_global $mac_ast_stack_top + (i32.add (get_global $mac_ast_stack_top) 1)) + (i32.store (i32.add + (get_global $mac_ast_stack) + (i32.mul_s (get_global $mac_ast_stack_top) 4)) + $ast))) + (if (get_global $error_type) + (br $done)) + + (br $loop) + ) + ) + $ast + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if $skiplast + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) + (local $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + + (set_local $ast $orig_ast) + (set_local $env $orig_env) + (set_local $prev_ast 0) + (set_local $prev_env 0) + (set_local $res 0) + + (block $EVAL_return + (loop $TCO_loop + + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (then + (set_local $res 0) + (br $EVAL_return))) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (set_local $ast ($MACROEXPAND $ast $env)) + ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + (if ($EMPTY_Q $ast) + (then + (set_local $res ($INC_REF $ast)) + (br $EVAL_return))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $prev_env $env) ;; save env for later release + (set_local $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (set_local $ast ($LAST $ast)) + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + ($SET_TYPE $res (get_global $MACRO_T)) + (if (get_global $error_type) + (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) + (then + ;; since we are returning it unevaluated, inc the ref cnt + (set_local $res ($INC_REF ($MACROEXPAND + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) + $env)))) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL))) + (br $EVAL_return)) + (else + (set_local $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (set_local $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env 0)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) + (then + (set_local $res $f_args) + (br $EVAL_return))) + + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (set_local $res ($EVAL ($MEM_VAL1_ptr $args) + (get_global $repl_env)))) + (else + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + ;; save the current environment for release + (set_local $prev_env $env) + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (set_local $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (set_local $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + ;; release memory from MACROEXPAND + ;; TODO: needs to happen in EVAL + (block $done + (loop $loop + (if (i32.lt_s (get_global $mac_ast_stack_top) 0) + (br $done)) + ($RELEASE (i32.load (i32.add + (get_global $mac_ast_stack) + (i32.mul_s (get_global $mac_ast_stack_top) 4)))) + (set_global $mac_ast_stack_top + (i32.sub_s (get_global $mac_ast_stack_top) 1)) + (br $loop) + ) + ) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (local $line i32 $res i32 $repl_env i32) + ;; argument processing + (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) + ($RELEASE ($RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env)) + ($RELEASE ($RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" $repl_env)) + + + ;; Command line arguments + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (set_local $i 2) + (block $done + (loop $loop + (if (i32.ge_u $i $argc) (br $done)) + + (set_local $val2 ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv (i32.mul_u $i 4))))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE + (get_global $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam new file mode 100644 index 0000000000..3ebeee1369 --- /dev/null +++ b/wasm/step9_try.wam @@ -0,0 +1,630 @@ +(module $step8_macros + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $is_pair (param $ast i32) (result i32) + (local $type i32) + (set_local $type ($TYPE $ast)) + (AND (OR (i32.eq $type (get_global $LIST_T)) + (i32.eq $type (get_global $VECTOR_T))) + (i32.ne ($VAL0 $ast) 0)) + ) + + (func $QUASIQUOTE (param $ast i32) (result i32) + (local $sym i32 $res i32 $second i32 $third i32) + (set_local $res 0) + (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE + (then + (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + ;; ['quote ast] + (set_local $res ($LIST2 $sym $ast)) + ($RELEASE $sym)) + (else + (set_local $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "unquote" ($to_String $res)))) + (then + ;; ast[1] + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (else (if (AND ($is_pair $res) + (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) + (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "splice-unquote" + ($to_String ($MEM_VAL1_ptr $res))))) + (then + ;; ['concat, ast[0][1], quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) + (set_local $second + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list take ownership + ($RELEASE $third) + ($RELEASE $sym)) + (else + ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) + (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $third) + ($RELEASE $second) + ($RELEASE $sym))))))) + $res + ) + + (global $mac_ast_stack (mut i32) (i32.const 0)) + (global $mac_ast_stack_top (mut i32) (i32.const -1)) + + (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) + (local $ast i32 $mac i32 $mac_env i64) + (set_global $mac_ast_stack (STATIC_ARRAY 128)) + (set_local $ast $orig_ast) + (set_local $mac 0) + (block $done + (loop $loop + (if (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (get_global $SYMBOL_T))) + (br $done)) + (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) + (if (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (get_global $MACRO_T))) + (then + (br $done))) + + (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + ;; PEND_A_LV + ;; if ast is not the first ast that was passed in, then add it + ;; to the pending release list. + (if (i32.ne $ast $orig_ast) + (then + (set_global $mac_ast_stack_top + (i32.add (get_global $mac_ast_stack_top) 1)) + (i32.store (i32.add + (get_global $mac_ast_stack) + (i32.mul_s (get_global $mac_ast_stack_top) 4)) + $ast))) + (if (get_global $error_type) + (br $done)) + + (br $loop) + ) + ) + $ast + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if $skiplast + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) + (local $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + (local $err i32) + + (set_local $ast $orig_ast) + (set_local $env $orig_env) + (set_local $prev_ast 0) + (set_local $prev_env 0) + (set_local $res 0) + + (block $EVAL_return + (loop $TCO_loop + + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (then + (set_local $res 0) + (br $EVAL_return))) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (set_local $ast ($MACROEXPAND $ast $env)) + ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + (if ($EMPTY_Q $ast) + (then + (set_local $res ($INC_REF $ast)) + (br $EVAL_return))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $prev_env $env) ;; save env for later release + (set_local $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (set_local $ast ($LAST $ast)) + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + ($SET_TYPE $res (get_global $MACRO_T)) + (if (get_global $error_type) + (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) + (then + ;; since we are returning it unevaluated, inc the ref cnt + (set_local $res ($INC_REF ($MACROEXPAND + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) + $env)))) + (else (if (i32.eqz ($strcmp "try*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + ;; if there is no error, return + (if (i32.eqz (get_global $error_type)) + (br $EVAL_return)) + ;; if there is an error and res is set, we need to free it + ($printf_1 "res value: %d\n" $res) + ($RELEASE $res) + ;; if there is no catch block then return + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + + ;; save the current environment for release + (set_local $prev_env $env) + ;; create environment for the catch block eval + (set_local $env ($ENV_NEW $env)) + + ;; set a1 and a2 from the catch block + (set_local $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) + (set_local $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) + + ;; create object for string errors + (if (i32.eq (get_global $error_type) 1) + (then + (set_local $err ($STRING (get_global $STRING_T) + (get_global $error_str)))) + (else + (set_local $err (get_global $error_val)))) + ;; bind the catch symbol to the error object + (drop ($ENV_SET $env $a1 $err)) + ;; release our use, env took ownership + ($RELEASE $err) + + ;; unset error for catch eval + (set_global $error_type 0) + (i32.store (get_global $error_str) (CHR "\x00")) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL))) + (br $EVAL_return)) + (else + (set_local $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (set_local $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env 0)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) + (then + (set_local $res $f_args) + (br $EVAL_return))) + + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (set_local $res ($EVAL ($MEM_VAL1_ptr $args) + (get_global $repl_env)))) + (else + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + ;; save the current environment for release + (set_local $prev_env $env) + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (set_local $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (set_local $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + ;; release memory from MACROEXPAND + ;; TODO: needs to happen in EVAL + (block $done + (loop $loop + (if (i32.lt_s (get_global $mac_ast_stack_top) 0) + (br $done)) + ($RELEASE (i32.load (i32.add + (get_global $mac_ast_stack) + (i32.mul_s (get_global $mac_ast_stack_top) 4)))) + (set_global $mac_ast_stack_top + (i32.sub_s (get_global $mac_ast_stack_top) 1)) + (br $loop) + ) + ) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (local $line i32 $res i32 $repl_env i32) + ;; argument processing + (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) + ($RELEASE ($RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env)) + ($RELEASE ($RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" $repl_env)) + + + ;; Command line arguments + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (set_local $i 2) + (block $done + (loop $loop + (if (i32.ge_u $i $argc) (br $done)) + + (set_local $val2 ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv (i32.mul_u $i 4))))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE + (get_global $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) +;; ($PR_MEMORY -1 -1) + ($free $line) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam new file mode 100644 index 0000000000..487cf28b27 --- /dev/null +++ b/wasm/stepA_mal.wam @@ -0,0 +1,634 @@ +(module $step8_macros + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $is_pair (param $ast i32) (result i32) + (local $type i32) + (set_local $type ($TYPE $ast)) + (AND (OR (i32.eq $type (get_global $LIST_T)) + (i32.eq $type (get_global $VECTOR_T))) + (i32.ne ($VAL0 $ast) 0)) + ) + + (func $QUASIQUOTE (param $ast i32) (result i32) + (local $sym i32 $res i32 $second i32 $third i32) + (set_local $res 0) + (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE + (then + (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + ;; ['quote ast] + (set_local $res ($LIST2 $sym $ast)) + ($RELEASE $sym)) + (else + (set_local $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "unquote" ($to_String $res)))) + (then + ;; ast[1] + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (else (if (AND ($is_pair $res) + (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) + (get_global $SYMBOL_T)) + (i32.eqz ($strcmp "splice-unquote" + ($to_String ($MEM_VAL1_ptr $res))))) + (then + ;; ['concat, ast[0][1], quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) + (set_local $second + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list take ownership + ($RELEASE $third) + ($RELEASE $sym)) + (else + ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] + (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) + (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (set_local $res ($LIST3 $sym $second $third)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $third) + ($RELEASE $second) + ($RELEASE $sym))))))) + $res + ) + + (global $mac_ast_stack (mut i32) (i32.const 0)) + (global $mac_ast_stack_top (mut i32) (i32.const -1)) + + (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) + (local $ast i32 $mac i32 $mac_env i64) + (set_global $mac_ast_stack (STATIC_ARRAY 128)) + (set_local $ast $orig_ast) + (set_local $mac 0) + (block $done + (loop $loop + (if (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (get_global $SYMBOL_T))) + (br $done)) + (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) + (if (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (get_global $MACRO_T))) + (then + (br $done))) + + (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + ;; PEND_A_LV + ;; if ast is not the first ast that was passed in, then add it + ;; to the pending release list. + (if (i32.ne $ast $orig_ast) + (then + (set_global $mac_ast_stack_top + (i32.add (get_global $mac_ast_stack_top) 1)) + (i32.store (i32.add + (get_global $mac_ast_stack) + (i32.mul_s (get_global $mac_ast_stack_top) 4)) + $ast))) + (if (get_global $error_type) + (br $done)) + + (br $loop) + ) + ) + $ast + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) + (local $ret i32 $empty i32 $current i32) + + (if (get_global $error_type) (return 0)) + (set_local $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (set_local $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (set_local $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (if (i32.eq ($VAL0 $ast) 0) (br $done)) + + (if $skiplast + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (set_local $val2 $res) + + ;; if error, release the unattached element + (if (get_global $error_type) + (then + ($RELEASE $res) + (set_local $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (get_global $HASHMAP_T)) + (then + (set_local $val3 $val2) + (set_local $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (set_local $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (set_local $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) + (local $ftype i32 $f_args i32 $f i32 $args i32) + (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + (local $err i32) + + (set_local $ast $orig_ast) + (set_local $env $orig_env) + (set_local $prev_ast 0) + (set_local $prev_env 0) + (set_local $res 0) + + (block $EVAL_return + (loop $TCO_loop + + (set_local $f_args 0) + (set_local $f 0) + (set_local $args 0) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (get_global $error_type) + (then + (set_local $res 0) + (br $EVAL_return))) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (set_local $ast ($MACROEXPAND $ast $env)) + ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (then + (set_local $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + (if ($EMPTY_Q $ast) + (then + (set_local $res ($INC_REF $ast)) + (br $EVAL_return))) + + (set_local $a0 ($MEM_VAL1_ptr $ast)) + (set_local $a0sym "") + (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) + (set_local $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + (if (get_global $error_type) (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (set_local $prev_env $env) ;; save env for later release + (set_local $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (if (i32.eqz ($VAL0 $a1)) + (br $done)) + ;; eval current A1 odd element + (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (if (get_global $error_type) (br $done)) + + ;; set key/value in the let environment + (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (set_local $ast ($LAST $ast)) + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($EVAL $a2 $env)) + ($SET_TYPE $res (get_global $MACRO_T)) + (if (get_global $error_type) + (br $EVAL_return)) + + ;; set a1 in env to a2 + (set_local $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) + (then + ;; since we are returning it unevaluated, inc the ref cnt + (set_local $res ($INC_REF ($MACROEXPAND + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) + $env)))) + (else (if (i32.eqz ($strcmp "try*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + ;; if there is no error, return + (if (i32.eqz (get_global $error_type)) + (br $EVAL_return)) + ;; if there is an error and res is set, we need to free it + ($printf_1 "res value: %d\n" $res) + ($RELEASE $res) + ;; if there is no catch block then return + (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + + ;; save the current environment for release + (set_local $prev_env $env) + ;; create environment for the catch block eval + (set_local $env ($ENV_NEW $env)) + + ;; set a1 and a2 from the catch block + (set_local $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) + (set_local $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) + + ;; create object for string errors + (if (i32.eq (get_global $error_type) 1) + (then + (set_local $err ($STRING (get_global $STRING_T) + (get_global $error_str)))) + (else + (set_local $err (get_global $error_val)))) + ;; bind the catch symbol to the error object + (drop ($ENV_SET $env $a1 $err)) + ;; release our use, env took ownership + ($RELEASE $err) + + ;; unset error for catch eval + (set_global $error_type 0) + (i32.store (get_global $error_str) (CHR "\x00")) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + (set_local $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $res ($EVAL $a1 $env)) + + (if (get_global $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (get_global $NIL)) + (i32.eq $res (get_global $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (set_local $res ($INC_REF (get_global $NIL))) + (br $EVAL_return)) + (else + (set_local $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (set_local $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (set_local $a1 ($MAL_GET_A1 $ast)) + (set_local $a2 ($MAL_GET_A2 $ast)) + (set_local $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (set_local $res ($EVAL_AST $ast $env 0)) + (set_local $f_args $res) + + ;; if error, return f/args for release by caller + (if (get_global $error_type) + (then + (set_local $res $f_args) + (br $EVAL_return))) + + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($DEREF_META ($MEM_VAL1_ptr $f_args))) ;; value + + (set_local $ftype ($TYPE $f)) + (if (i32.eq $ftype (get_global $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (set_local $res ($EVAL ($MEM_VAL1_ptr $args) + (get_global $repl_env)))) + (else + (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (then + ;; save the current environment for release + (set_local $prev_env $env) + ;; create new environment using env and params stored in function + (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (set_local $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (set_local $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (set_local $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (set_local $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (local $mv1 i32 $res i32) + (block $rep_done + (set_local $mv1 ($READ $line)) + (if (get_global $error_type) (br $rep_done)) + + (set_local $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + ;; release memory from MACROEXPAND + ;; TODO: needs to happen in EVAL + (block $done + (loop $loop + (if (i32.lt_s (get_global $mac_ast_stack_top) 0) + (br $done)) + ($RELEASE (i32.load (i32.add + (get_global $mac_ast_stack) + (i32.mul_s (get_global $mac_ast_stack_top) 4)))) + (set_global $mac_ast_stack_top + (i32.sub_s (get_global $mac_ast_stack_top) 1)) + (br $loop) + ) + ) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (local $mv2 i32 $ms i32) + (block $rep_done + (set_local $mv2 ($RE $line $env)) + (if (get_global $error_type) (br $rep_done)) + +;; ($PR_MEMORY -1 -1) + (set_local $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (local $line i32 $res i32 $repl_env i32) + ;; argument processing + (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) + + (set_global $repl_env ($ENV_NEW (get_global $NIL))) + (set_local $repl_env (get_global $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! *host-language* \"WebAssembly\")" $repl_env)) + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) + ($RELEASE ($RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env)) + ($RELEASE ($RE "(def! *gensym-counter* (atom 0))" $repl_env)) + ($RELEASE ($RE "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))" $repl_env)) + ($RELEASE ($RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (c (gensym)) `(let* (~c ~(first xs)) (if ~c ~c (or ~@(rest xs)))))))))" $repl_env)) + + ;; Command line arguments + (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (set_local $ret $res) + (set_local $current $res) + (set_local $empty $res) + + (set_local $i 2) + (block $done + (loop $loop + (if (i32.ge_u $i $argc) (br $done)) + + (set_local $val2 ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv (i32.mul_u $i 4))))) + + ;; MAP_LOOP_UPDATE + (set_local $res ($MAP_LOOP_UPDATE + (get_global $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (set_local $ret $res)) + ;; update current to point to new element + (set_local $current $res) + + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (get_global $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (return 1)) + (else + (return 0))))) + + ($RELEASE ($RE "(println (str \"Mal [\" *host-language* \"]\"))" $repl_env)) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (set_local $line ($readline "user> ")) + (if (i32.eqz $line) (br $repl_done)) + (if (i32.eq (i32.load8_u $line) 0) + (then + ($free $line) + (br $repl_loop))) + (set_local $res ($REP $line $repl_env)) + (if (get_global $error_type) + (then + ($printf_1 "Error: %s\n" (get_global $error_str)) + (set_global $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ($free $line) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop))) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + + + (export "_main" (func $main)) + (export "__post_instantiate" (func $init_memory)) +) + diff --git a/wasm/string.wam b/wasm/string.wam new file mode 100644 index 0000000000..4a68c0c369 --- /dev/null +++ b/wasm/string.wam @@ -0,0 +1,226 @@ +(module $string + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Copy len bytes from src to dst + ;; Returns len + (func $memmove (param $dst i32 $src i32 $len i32) + (local $idx i32) + (set_local $idx 0) + (loop $copy + (i32.store8_u (i32.add $idx $dst) + (i32.load8_u (i32.add $idx $src))) + (set_local $idx (i32.add 1 $idx)) + (br_if $copy (i32.lt_u $idx $len)) + ) + ) + + (func $strlen (param $str i32) (result i32) + (local $cur i32) + (set_local $cur $str) + (loop $count + (if (i32.ne 0 (i32.load8_u $cur)) + (then + (set_local $cur (i32.add $cur 1)) + (br $count))) + ) + (i32.sub_u $cur $str) + ) + + ;; Based on https://stackoverflow.com/a/25705264/471795 + ;; This could be made much more efficient + (func $strstr (param $haystack i32 $needle i32) (result i32) + (local $i i32 $needle_len i32 $len i32) + + (set_local $needle_len ($strlen $needle)) + (set_local $len ($strlen $haystack)) + + (if (i32.eq $needle_len 0) (return $haystack)) + + (set_local $i 0) + (block $done + (loop $loop + (if (i32.gt_s $i (i32.sub_s $len $needle_len)) (br $done)) + + (if (AND (i32.eq (i32.load8_u $haystack 0) + (i32.load8_u $needle 0)) + (i32.eqz ($strncmp $haystack $needle $needle_len))) + (return $haystack)) + (set_local $haystack (i32.add $haystack 1)) + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + 0 + ) + + (func $atoi (param $str i32) (result i32) + (local $acc i32) + (local $i i32) + (local $neg i32) + (local $ch i32) + (set_local $acc 0) + (set_local $i 0) + (set_local $neg 0) + (block $done + (loop $loop + (set_local $ch (i32.load8_u (i32.add $str $i))) + (if (AND (i32.ne $ch (CHR "-")) + (OR (i32.lt_u $ch (CHR "0")) + (i32.gt_u $ch (CHR "9")))) + (br $done)) + (set_local $i (i32.add $i 1)) + (if (i32.eq $ch (CHR "-")) + (then + (set_local $neg 1)) + (else + (set_local $acc (i32.add (i32.mul_u $acc 10) + (i32.sub_u $ch (CHR "0")))))) + (br $loop) + ) + ) + (if i32 $neg + (then (i32.sub_s 0 $acc)) + (else $acc)) + ) + + (func $strcmp (param $s1 i32 $s2 i32) (result i32) + (block $done + (loop $loop + (if (OR (i32.eqz (i32.load8_u $s1)) (i32.eqz (i32.load8_u $s2))) + (br $done)) + (if (i32.ne (i32.load8_u $s1) (i32.load8_u $s2)) + (br $done)) + (set_local $s1 (i32.add $s1 1)) + (set_local $s2 (i32.add $s2 1)) + (br $loop) + ) + ) + (if i32 (i32.eq (i32.load8_u $s1) (i32.load8_u $s2)) + (then 0) + (else + (if i32 (i32.lt_u (i32.load8_u $s1) (i32.load8_u $s2)) + (then -1) + (else 1)))) + ) + + (func $strncmp (param $s1 i32 $s2 i32 $len i32) (result i32) + (local $i i32) + (set_local $i 0) + (if (i32.eq $len 0) (return 0)) + (block $done + (loop $loop + (if (i32.ge_u $i $len) (br $done)) + (if (i32.eqz (i32.load8_u (i32.add $i $s1))) (br $done)) + (if (i32.ne (i32.load8_u (i32.add $i $s1)) + (i32.load8_u (i32.add $i $s2))) (br $done)) + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + (if (OR (i32.eq $i $len) + (i32.eq (i32.load8_u (i32.add $i $s1)) + (i32.load8_u (i32.add $i $s2)))) + (return 0)) + (if i32 (i32.lt_u (i32.load8_u (i32.add $i $s1)) + (i32.load8_u (i32.add $i $s2))) + (then -1) + (else 1)) + ) + + ;; Writes new string to grass with all needles in haystack replaced. + ;; If the length of replace is equal to of less than needle then + ;; grass can be NULL. + ;; Returns length of grass. + (func $REPLACE3 (param $grass i32 $haystack i32 + $needle0 i32 $replace0 i32 + $needle1 i32 $replace1 i32 + $needle2 i32 $replace2 i32) (result i32) + (local $needle i32 $replace i32) + (local $haystack_len i32 $needle_len i32 $replace_len i32) + (local $src_str i32 $dst_str i32 $s i32 $found_tmp i32 $found i32) + (local $replace_s i32 $replace_len_s i32 $needle_len_s i32) + + (set_local $haystack_len ($strlen $haystack)) + (set_local $src_str $haystack) + (set_local $dst_str $grass) + + ;; in-place + (if (i32.eqz $grass) + (then + ;; check that we aren't expanding in place + (set_local $s 0) + (block $done + (loop $loop + (if (i32.ge_u $s 3) (br $done)) + (set_local $needle (if i32 (i32.eq $s 0) $needle0 + (if i32 (i32.eq $s 1) $needle1 + $needle2))) + (set_local $replace (if i32 (i32.eq $s 0) $replace0 + (if i32 (i32.eq $s 1) $replace1 + $replace2))) + (set_local $needle_len ($strlen $needle)) + (set_local $replace_len ($strlen $replace)) + (if (i32.gt_u $replace_len $needle_len) + (then + ($print "REPLACE: invalid expanding in-place call\n") + ($exit 1))) + (set_local $s (i32.add $s 1)) + (br $loop) + ) + ) + (set_local $grass $haystack) + (set_local $dst_str $grass))) + + (block $done1 + (loop $loop1 + (if (i32.ge_s (i32.sub_s $src_str $haystack) $haystack_len) + (br $done1)) + + ;; Find the earliest match + (set_local $found 0) + (set_local $s 0) + (block $done2 + (loop $loop2 + (if (i32.ge_u $s 3) (br $done2)) + (set_local $needle (if i32 (i32.eq $s 0) $needle0 + (if i32 (i32.eq $s 1) $needle1 + $needle2))) + (set_local $replace (if i32 (i32.eq $s 0) $replace0 + (if i32 (i32.eq $s 1) $replace1 + $replace2))) + (set_local $s (i32.add $s 1)) + (set_local $found_tmp ($strstr $src_str $needle)) + (if (i32.eqz $found_tmp) (br $loop2)) + (if (OR (i32.eqz $found) (i32.lt_s $found_tmp $found)) + (then + (set_local $found $found_tmp) + (set_local $needle_len_s ($strlen $needle)) + (set_local $replace_s $replace) + (set_local $replace_len_s ($strlen $replace)))) + (br $loop2) + ) + ) + (if (i32.eqz $found) (br $done1)) + ;; copy before the match + ($memmove $dst_str $src_str (i32.add (i32.sub_s $found $src_str) 1)) + (set_local $dst_str (i32.add $dst_str (i32.sub_s $found $src_str))) + ;; add the replace string + ($memmove $dst_str $replace_s (i32.add $replace_len_s 1)) + (set_local $dst_str (i32.add $dst_str $replace_len_s)) + ;; Move to after the match + (set_local $src_str (i32.add $found $needle_len_s)) + (br $loop1) + ) + ) + + ;; Copy the left-over + ($memmove $dst_str $src_str ($strlen $src_str)) + (set_local $dst_str (i32.add $dst_str ($strlen $src_str))) + (i32.store8_u $dst_str (CHR "\x00")) + + (i32.sub_s $dst_str $grass) + ) + +) + diff --git a/wasm/types.wam b/wasm/types.wam index 2e809534b9..8f14ad9a3a 100644 --- a/wasm/types.wam +++ b/wasm/types.wam @@ -55,21 +55,87 @@ (func $INC_REF (param $mv i32) (result i32) (i32.store $mv (i32.add (i32.load $mv) 32)) - $mv) + $mv + ) + + (func $TRUE_FALSE (param $val i32) (result i32) + ($INC_REF (if i32 $val (get_global $TRUE) (get_global $FALSE))) + ) (func $THROW_STR_0 (param $fmt i32) (drop ($sprintf_1 (get_global $error_str) $fmt "")) - (set_global $error_type 1)) + (set_global $error_type 1) + ) (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) (drop ($sprintf_1 (get_global $error_str) $fmt $v0)) - (set_global $error_type 1)) + (set_global $error_type 1) + ) + + (func $EQUAL_Q (param $a i32 $b i32) (result i32) + (local $ta i32 $tb i32) + (set_local $ta ($TYPE $a)) + (set_local $tb ($TYPE $b)) + + (if (AND (OR (i32.eq $ta (get_global $LIST_T)) + (i32.eq $ta (get_global $VECTOR_T))) + (OR (i32.eq $tb (get_global $LIST_T)) + (i32.eq $tb (get_global $VECTOR_T)))) + (then + ;; EQUAL_Q_SEQ + (block $done + (loop $loop + (if (OR (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)) + (br $done)) + (if ($EQUAL_Q ($MEM_VAL1_ptr $a) ($MEM_VAL1_ptr $b)) + (then + (set_local $a ($MEM_VAL0_ptr $a)) + (set_local $b ($MEM_VAL0_ptr $b))) + (else + (return 0))) + (br $loop) + ) + ) + (return (AND (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)))) + (else (if (AND (i32.eq $ta (get_global $HASHMAP_T)) + (i32.eq $tb (get_global $HASHMAP_T))) + ;; EQUAL_Q_HM + (return 1)) + ;; TODO: remove this once strings are interned + (else (if (OR (AND (i32.eq $ta (get_global $STRING_T)) + (i32.eq $tb (get_global $STRING_T))) + (AND (i32.eq $ta (get_global $SYMBOL_T)) + (i32.eq $tb (get_global $SYMBOL_T)))) + (return (i32.eqz ($strcmp ($to_String $a) ($to_String $b)))) + (else + (return (AND (i32.eq $ta $tb) + (i32.eq ($VAL0 $a) ($VAL0 $b))))))))) + ) + + (func $DEREF_META (param $mv i32) (result i32) + (loop $loop + (if (i32.eq ($TYPE $mv) (get_global $METADATA_T)) + (then + (set_local $mv ($MEM_VAL0_ptr $mv)) + (br $loop))) + ) + $mv + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; string functions + + (func $to_String (param $mv i32) (result i32) + ;; skip string refcnt + (i32.add 4 ($VAL0 $mv)) + ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; numeric functions (func $INTEGER (param $val i32) (result i32) - ($ALLOC_SCALAR (get_global $INTEGER_T) $val)) + ($ALLOC_SCALAR (get_global $INTEGER_T) $val) + ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; sequence functions @@ -102,21 +168,148 @@ ($RELEASE $val3)) (if (i32.gt_u $current (get_global $EMPTY_HASHMAP)) ;; if not first element, set current next to point to new element - (i32.store ($VAL0_ptr $current) ($MalVal_index $res))) + (i32.store ($VAL0_ptr $current) ($IDX $res))) + + $res + ) + + (func $FORCE_SEQ_TYPE (param $type i32) (param $mv i32) (result i32) + (local $res i32) + ;; if it's already the right type, inc ref cnt and return it + (if (i32.eq $type ($TYPE $mv)) (return ($INC_REF $mv))) + ;; if it's empty, return the sequence match + (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (return ($MAP_LOOP_START $type))) + ;; otherwise, copy first element to turn it into correct type + ($ALLOC $type ($MEM_VAL0_ptr $mv) ($MEM_VAL1_ptr $mv) 0) + ) + + (func $LIST (param $seq i32 $first i32) (result i32) + ($ALLOC (get_global $LIST_T) $seq $first 0) + ) + (func $LIST2 (param $first i32 $second i32) (result i32) + ;; last element is empty list + (local $tmp i32 $res i32) + (set_local $tmp ($LIST (get_global $EMPTY_LIST) $second)) + (set_local $res ($LIST $tmp $first)) + ($RELEASE $tmp) ;; new list takes ownership of previous $res ) + (func $LIST3 (param $first i32 $second i32 $third i32) (result i32) + (local $tmp i32 $res i32) + (set_local $tmp ($LIST2 $second $third)) + (set_local $res ($LIST $tmp $first)) + ($RELEASE $tmp) ;; new list takes ownership of previous + $res + ) + + (func $LIST_Q (param $mv i32) (result i32) + (i32.eq ($TYPE $mv) (get_global $LIST_T)) + ) + (func $EMPTY_Q (param $mv i32) (result i32) (i32.eq ($VAL0 $mv) 0) ) + (func $COUNT (param $mv i32) (result i32) + (local $cnt i32) + (set_local $cnt 0) + (block $done + (loop $loop + (if (i32.eq ($VAL0 $mv) 0) (br $done)) + (set_local $cnt (i32.add $cnt 1)) + (set_local $mv ($MEM_VAL0_ptr $mv)) + (br $loop) + ) + ) + $cnt + ) + + (func $LAST (param $mv i32) (result i32) + (local $cur i32) + ;; TODO: check that actually a list/vector + (if (i32.eq ($VAL0 $mv) 0) + ;; empty seq, return nil + (return ($INC_REF (get_global $NIL)))) + (block $done + (loop $loop + ;; end, return previous value + (if (i32.eq ($VAL0 $mv) 0) (br $done)) + ;; current becomes previous entry + (set_local $cur $mv) + ;; next entry + (set_local $mv ($MEM_VAL0_ptr $mv)) + (br $loop) + ) + ) + ($INC_REF ($MEM_VAL1_ptr $cur)) + ) + + ;; make a copy of sequence seq from index start to end + ;; set last to last element of slice before the empty + ;; set after to element following slice (or original) + (func $SLICE (param $seq i32) (param $start i32) (param $end i32) + (result i64) + (local $idx i32 $res i32 $tmp i32 $last i32) + (set_local $idx 0) + (set_local $res ($INC_REF (get_global $EMPTY_LIST))) + (set_local $last 0) + (set_local $tmp $res) + ;; advance seq to start + (block $done + (loop $loop + (if (OR (i32.ge_s $idx $start) + (i32.eqz ($VAL0 $seq))) + (br $done)) + (set_local $seq ($MEM_VAL0_ptr $seq)) + (set_local $idx (i32.add $idx 1)) + (br $loop) + ) + ) + (block $done + (loop $loop + ;; if current position is at end, then return or if we reached + ;; end seq, then return + (if (OR (AND (i32.ne $end -1) + (i32.ge_s $idx $end)) + (i32.eqz ($VAL0 $seq))) + (then + (set_local $res $tmp) + (br $done))) + ;; allocate new list element with copied value + (set_local $res ($LIST (get_global $EMPTY_LIST) + ($MEM_VAL1_ptr $seq))) + ;; sequence took ownership + ($RELEASE (get_global $EMPTY_LIST)) + (if (i32.eqz $last) + (then + ;; if first element, set return value to new element + (set_local $tmp $res)) + (else + ;; if not the first element, set return value to new element + (i32.store ($VAL0_ptr $last) ($IDX $res)))) + (set_local $last $res) ;; update last list element + ;; advance to next element of seq + (set_local $seq ($MEM_VAL0_ptr $seq)) + (set_local $idx (i32.add $idx 1)) + (br $loop) + ) + ) + + ;; combine last/res as hi 32/low 32 of i64 + (i64.or + (i64.shl_u (i64.extend_u/i32 $last) (i64.const 32)) + (i64.extend_u/i32 $res)) + ) + (func $HASHMAP (result i32) ;; just point to static empty hash-map ($INC_REF (get_global $EMPTY_HASHMAP)) ) - (func $ASSOC1 (param $hm i32) (param $k i32) (param $v i32) (result i32) + (func $ASSOC1 (param $hm i32 $k i32 $v i32) (result i32) (local $res i32) (set_local $res ($ALLOC (get_global $HASHMAP_T) $hm $k $v)) ;; we took ownership of previous release @@ -124,9 +317,8 @@ $res ) - (func $ASSOC1_S (param $hm i32) (param $k i32) (param $v i32) (result i32) - (local $kmv i32) - (local $res i32) + (func $ASSOC1_S (param $hm i32 $k i32 $v i32) (result i32) + (local $kmv i32 $res i32) (set_local $kmv ($STRING (get_global $STRING_T) $k)) (set_local $res ($ASSOC1 $hm $kmv $v)) ;; map took ownership of key @@ -135,10 +327,7 @@ ) (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) - (local $res i32) - (local $found i32) - (local $key i32) - (local $test_key_mv i32) + (local $res i32 $found i32 $key i32 $test_key_mv i32) (set_local $key ($to_String $key_mv)) (set_local $found 0) @@ -177,10 +366,8 @@ ($ALLOC_SCALAR (get_global $FUNCTION_T) $index) ) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; string functions + (func $MALFUNC (param $ast i32 $params i32 $env i32) (result i32) + ($ALLOC (get_global $MALFUNC_T) $ast $params $env) + ) - (func $to_String (param $mv i32) (result i32) - ;; skip string refcnt - (i32.add 4 ($MalVal_val ($MalVal_index $mv) 0))) ) diff --git a/wasm/util.wam b/wasm/util.wam index e663d4adb0..926d26765d 100644 --- a/wasm/util.wam +++ b/wasm/util.wam @@ -4,160 +4,85 @@ (import "env" "exit" (func $exit (param i32))) (import "env" "stdout" (global $stdout i32)) - (import "env" "putchar" (func $putchar (param i32) (result i32))) (import "env" "fputs" (func $fputs (param i32 i32) (result i32))) ;;(import "env" "readline" (func $readline (param i32) (result i32))) (import "libedit.so" "readline" (func $readline (param i32) (result i32))) ;;(import "libreadline.so" "readline" (func $readline (param i32) (result i32))) - (global $sprintf_buf (mut i32) 0) + (global $util_buf (mut i32) 0) + + ;; read_file defintions / FFI information + (global $STAT_SIZE i32 88) + (global $STAT_ST_SIZE_OFFSET i32 44) + (global $STAT_VER_LINUX i32 3) + (global $O_RDONLY i32 0) + (import "env" "open" (func $open (param i32 i32 i32) (result i32))) + (import "env" "read" (func $read (param i32 i32 i32) (result i32))) + (import "env" "__fxstat" (func $__fxstat (param i32 i32 i32) (result i32))) + (global $TIMEVAL_SIZE i32 8) + (global $TV_SEC_OFFSET i32 0) + (global $TV_USEC_OFFSET i32 4) + (import "env" "gettimeofday" (func $gettimeofday (param i32 i32) (result i32))) (func $init_sprintf_mem - ;; 256 character sprintf static buffer - (set_global $sprintf_buf " ") + ;; sprintf static buffer + (set_global $util_buf (STATIC_ARRAY 256)) ) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Copy len chatacters from src to dst - ;; Returns len - (func $MEM_COPY (param $dst i32) (param $src i32) (param $len i32) - (local $idx i32) - (set_local $idx 0) - (loop $copy - (i32.store8_u (i32.add $idx $dst) - (i32.load8_u (i32.add $idx $src))) - (set_local $idx (i32.add 1 $idx)) - (br_if $copy (i32.lt_u $idx $len)) - ) - ) - - (func $STRING_LEN (param $str i32) (result i32) - (local $cur i32) - (set_local $cur $str) - (loop $count - (if (i32.ne 0 (i32.load8_u $cur)) - (then - (set_local $cur (i32.add $cur 1)) - (br $count))) - ) - (i32.sub_u $cur $str) - ) - - (func $ATOI (param $str i32) (result i32) - (local $acc i32) - (local $i i32) - (local $neg i32) - (local $ch i32) - (set_local $acc 0) - (set_local $i 0) - (set_local $neg 0) - (block $done - (loop $loop - (set_local $ch (i32.load8_u (i32.add $str $i))) - (if (i32.and (i32.ne $ch (CHR "-")) - (i32.or (i32.lt_u $ch (CHR "0")) - (i32.gt_u $ch (CHR "9")))) - (br $done)) - (set_local $i (i32.add $i 1)) - (if (i32.eq $ch (CHR "-")) - (then - (set_local $neg 1)) - (else - (set_local $acc (i32.add (i32.mul_u $acc 10) - (i32.sub_u $ch (CHR "0")))))) - (br $loop) - ) - ) - (if i32 $neg - (then (i32.sub_s 0 $acc)) - (else $acc)) - ) - - (func $strcmp (param $s1 i32) (param $s2 i32) (result i32) - (block $done - (loop $loop - (if (i32.or (i32.eqz (i32.load8_u $s1)) - (i32.eqz (i32.load8_u $s2))) - (br $done)) - (if (i32.ne (i32.load8_u $s1) - (i32.load8_u $s2)) - (br $done)) - (set_local $s1 (i32.add $s1 1)) - (set_local $s2 (i32.add $s2 1)) - (br $loop) - ) - ) - (if i32 (i32.eq (i32.load8_u $s1) - (i32.load8_u $s2)) - (then 0) - (else - (if i32 (i32.lt_u (i32.load8_u $s1) - (i32.load8_u $s2)) - (then -1) - (else 1)))) - ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $print (param $addr i32) (drop ($fputs $addr (get_global $stdout)))) - (func $printf_1 (param $fmt i32) - (param $v0 i32) - (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 0 0 0 0 0)) - ($print (get_global $sprintf_buf)) + (func $printf_1 (param $fmt i32) (param $v0 i32) + (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 0 0 0 0 0)) + ($print (get_global $util_buf)) ) - (func $printf_2 (param $fmt i32) - (param $v0 i32) (param $v1 i32) - (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 0 0 0 0)) - ($print (get_global $sprintf_buf)) + (func $printf_2 (param $fmt i32 $v0 i32 $v1 i32) + (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 0 0 0 0)) + ($print (get_global $util_buf)) ) (func $printf_3 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) - (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 0 0 0)) - ($print (get_global $sprintf_buf)) + (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 0 0 0)) + ($print (get_global $util_buf)) ) (func $printf_4 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) - (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) - ($print (get_global $sprintf_buf)) + (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 $v3 0 0)) + ($print (get_global $util_buf)) ) (func $printf_5 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) - (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) - ($print (get_global $sprintf_buf)) + (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) + ($print (get_global $util_buf)) ) (func $printf_6 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) (param $v5 i32) - (drop ($sprintf_6 (get_global $sprintf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) - ($print (get_global $sprintf_buf)) + (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) + ($print (get_global $util_buf)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) - (local $n i32) - (local $ch i32) + (local $n i32 $ch i32) (set_local $n (i32.rem_u $num $base)) - (set_local $ch (if (result i32) (i32.lt_u $n 10) - 48 - 55)) + (set_local $ch (if (result i32) (i32.lt_u $n 10) 48 55)) (i32.store8_u $str (i32.add $n $ch)) ) ;; TODO: switch to snprint* (add buffer len) - (func $_sprintnum (param $str i32) (param $num i32) (param $base i32) - (result i32) - (if (i32.and (i32.eq $base 10) - (i32.lt_s $num 0)) + (func $_sprintnum (param $str i32 $num i32 $base i32) (result i32) + (if (AND (i32.eq $base 10) (i32.lt_s $num 0)) (then ;; Print '-' if negative (i32.store8_u $str (CHR "-")) @@ -225,20 +150,18 @@ (set_local $pstr ($_sprintnum $pstr $v 10))) (else (if (i32.eq (CHR "x") $ch) (then - (set_local $pstr ($_sprintnum $pstr $v 10))) + (set_local $pstr ($_sprintnum $pstr $v 16))) (else (if (i32.eq (CHR "s") $ch) (then - (set_local $len ($STRING_LEN $v)) - ($MEM_COPY $pstr $v $len) + (set_local $len ($strlen $v)) + ($memmove $pstr $v $len) (set_local $pstr (i32.add $pstr $len))) (else (if (i32.eq (CHR "c") $ch) (then (i32.store8_u $pstr $v) (set_local $pstr (i32.add $pstr 1))) (else - ($print "Illegal format character: ") - (drop ($putchar $ch)) - (drop ($putchar (CHR "\n"))) + ($printf_1 "Illegal format character: '%c'\n" $ch) ($exit 3))))))))) (set_local $vidx (i32.add 1 $vidx)) @@ -250,5 +173,65 @@ $pstr ) -) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Returns malloc'd string. Must be free by caller + (func $read_file (param $path i32) (result i32) + (local $fst i32 $fd i32 $str i32 $st_size i32 $sz i32) + (set_local $str 0) + (set_local $fst ($malloc (get_global $STAT_SIZE))) + (if (i32.le_s $fst 0) + (then + ($printf_1 "ERROR: malloc of %d bytes failed\n" + (get_global $STAT_SIZE)) + (return 0))) + (block $free_fst + (set_local $fd ($open $path (get_global $O_RDONLY) 0)) + (if (i32.lt_s $fd 0) + (then + ($printf_1 "ERROR: slurp failed to open '%s'\n" $path) + (br $free_fst))) + (if (i32.lt_s ($__fxstat (get_global $STAT_VER_LINUX) $fd $fst) 0) + (then + ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) + (br $free_fst))) + (set_local $st_size (i32.load + (i32.add $fst (get_global $STAT_ST_SIZE_OFFSET)))) + (set_local $str ($malloc (i32.add 1 $st_size))) + (if (i32.le_s $str 0) + (then + ($printf_1 "ERROR: malloc of %d bytes failed\n" $st_size) + (br $free_fst))) + (set_local $sz ($read $fd $str $st_size)) + (if (i32.ne $sz $st_size) + (then + ($free $str) + (set_local $str 0) + ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) + (br $free_fst))) + ;; Add null to string + (i32.store8_u (i32.add $str $st_size) 0) + ) + ($free $fst) + $str + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + (func $get_time_ms (result i32) + (local $tv i32 $secs i32 $usecs i32 $msecs i32) + (set_local $tv ($malloc (get_global $TIMEVAL_SIZE))) + (drop ($gettimeofday $tv 0)) + (set_local $secs (i32.load (i32.add $tv (get_global $TV_SEC_OFFSET)))) + ;; subtract 30 years to make sure secs is positive and can be + ;; multiplied by 1000 + (set_local $secs (i32.sub_s $secs 0x38640900)) + (set_local $usecs (i32.load (i32.add $tv (get_global $TV_USEC_OFFSET)))) + (set_local $msecs (i32.add (i32.mul_u $secs 1000) + (i32.div_u $usecs 1000))) + ($free $tv) + $msecs + ) +) From 456d0a21beb08af77a2c0310c39c95baf17a4684 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sun, 11 Nov 2018 15:07:27 -0600 Subject: [PATCH 0405/1998] wasm: improve debug output using padding. --- wasm/debug.wam | 34 +++++------- wasm/reader.wam | 3 +- wasm/stepA_mal.wam | 1 + wasm/util.wam | 125 +++++++++++++++++++++++++++++++++++++-------- 4 files changed, 119 insertions(+), 44 deletions(-) diff --git a/wasm/debug.wam b/wasm/debug.wam index 4ad2231482..8ec023d9e6 100644 --- a/wasm/debug.wam +++ b/wasm/debug.wam @@ -1,5 +1,9 @@ (module $debug + (func $checkpoint_user_memory + (set_global $mem_user_start (get_global $mem_unused_start)) + ) + (func $CHECK_FREE_LIST (result i32) (local $first i32 $count i32) (set_local $first (i32.add @@ -90,36 +94,26 @@ (set_local $size ($MalVal_size $mv)) (set_local $val0 ($MalVal_val $idx 0)) - ;;; printf(" %3d: type: %2d", idx, type) - ($printf_2 " %d: type: %d" $idx $type) + ($printf_2 "%4d: type %2d" $idx $type) (if (i32.eq $type 15) - (then - ;;; printf(", size: %2d", size) - ($printf_1 ", size: %d" $size)) - (else - ;;; printf(", refs: %2d", (mv->refcnt_type - type)>>5) - ($printf_1 ", refs: %d" ($REFS $mv)))) + (then ($printf_1 ", size %2d" $size)) + (else ($printf_1 ", refs %2d" ($REFS $mv)))) - ;;; printf(", [ %3d | %3d", mv->refcnt_type, val0) (if (OR (i32.eq $type (get_global $STRING_T)) (i32.eq $type (get_global $SYMBOL_T))) ;; for strings/symbolx pointers, print hex values - (then ($printf_2 ", [ 0x%x | 0x%x" ($MalVal_refcnt_type $idx) $val0)) - (else ($printf_2 ", [ %d | %d" ($MalVal_refcnt_type $idx) $val0))) + (then ($printf_2 " [%4d|%3ds" ($MalVal_refcnt_type $idx) $val0)) + (else ($printf_2 " [%4d|%4d" ($MalVal_refcnt_type $idx) $val0))) (if (i32.eq $size 2) (then - ($print " | --- | --- ]")) + ($print "|----|----]")) (else - ;;; printf(" | %3d", mv->val[1]) - ($printf_1 " | %d" ($MalVal_val $idx 1)) + ($printf_1 "|%4d" ($MalVal_val $idx 1)) (if (i32.eq $size 3) - (then - ($print " | --- ]")) - (else - ;;; printf(" | %3d ]", mv->val[2]) - ($printf_1 " | %d ]" ($MalVal_val $idx 2)))))) + (then ($print "|----]")) + (else ($printf_1 "|%4d]" ($MalVal_val $idx 2)))))) ;;; printf(" >> ") ($print " >> ") @@ -157,7 +151,7 @@ ($print "()")) (else ;;; printf("(... %d ...), next: %d\n", mv->val[1], mv->val[0]) - ($printf_2 "(... 0x%x ...), next: 0x%x" + ($printf_2 "(... %d ...), next: %d" ($MalVal_val $idx 1) ($MalVal_val $idx 0)))) (br $done)) diff --git a/wasm/reader.wam b/wasm/reader.wam index 6d728d96f3..05890c7051 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -233,13 +233,12 @@ ) (func $read_form (param $str i32) (result i32) - ;;($STRING (get_global $STRING_T) $str) (local $tok i32 $c0 i32 $c1 i32 $res i32 $slen i32) (if (get_global $error_type) (return 0)) (set_local $tok ($read_token $str)) -;; ($debug ">>> read_form 1:" $tok) + ;;($printf_1 ">>> read_form 1: %s\n" $tok) ;;; c0 = token[0] (set_local $c0 (i32.load8_u $tok)) (set_local $c1 (i32.load8_u (i32.add $tok 1))) diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index 487cf28b27..4d0788fd54 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -542,6 +542,7 @@ ($add_core_ns $repl_env) (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + ($checkpoint_user_memory) ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! *host-language* \"WebAssembly\")" $repl_env)) diff --git a/wasm/util.wam b/wasm/util.wam index 926d26765d..f0238101df 100644 --- a/wasm/util.wam +++ b/wasm/util.wam @@ -80,21 +80,65 @@ (i32.store8_u $str (i32.add $n $ch)) ) - ;; TODO: switch to snprint* (add buffer len) - (func $_sprintnum (param $str i32 $num i32 $base i32) (result i32) - (if (AND (i32.eq $base 10) (i32.lt_s $num 0)) + ;; TODO: add max buf length (i.e. snprintnum) + (func $_sprintnum (param $buf i32) (param $val i32) (param $radix i32) + (param $pad_cnt i32) (param $pad_char i32) (result i32) + (local $pbuf i32 $i i32 $j i32 $k i32 $len i32 $neg i32 $digit i32) + (set_local $pbuf $buf) + (set_local $neg 0) + + (if (AND (i32.lt_s $val 0) (i32.eq $radix 10)) (then - ;; Print '-' if negative - (i32.store8_u $str (CHR "-")) - (set_local $str (i32.add $str 1)) - ;; Reverse the sign - (set_local $num (i32.sub_s 0 $num)))) - (if (i32.gt_u (i32.div_u $num $base) 0) - (set_local - $str - ($_sprintnum $str (i32.div_u $num $base) $base))) - ($_sprintdigit $str $num $base) - (i32.add 1 $str) + (set_local $neg 1) + (set_local $val (i32.sub_s 0 $val)))) + + ;; Calculate smallest to most significant digit + (loop $loop + (set_local $digit (i32.rem_u $val $radix)) + (i32.store8_u $pbuf (if i32 (i32.lt_s $digit 10) + (i32.add (CHR "0") $digit) + (i32.sub_s (i32.add (CHR "A") $digit) 10))) + (set_local $pbuf (i32.add $pbuf 1)) + (set_local $val (i32.div_s $val $radix)) + (if (i32.gt_s $val 0) (br $loop)) + ) + + (set_local $i (i32.sub_s $pbuf $buf)) + (block $done + (loop $loop + (if (i32.ge_s $i $pad_cnt) (br $done)) + (i32.store8_u $pbuf $pad_char) + (set_local $pbuf (i32.add $pbuf 1)) + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + + (if $neg + (then + (i32.store8_u $pbuf (CHR "-")) + (set_local $pbuf (i32.add $pbuf 1)))) + + (i32.store8_u $pbuf (CHR "\x00")) + + ;; now reverse it + (set_local $len (i32.sub_s $pbuf $buf)) + (set_local $i 0) + (block $done + (loop $loop + (if (i32.ge_s $i (i32.div_s $len 2)) + (br $done)) + + (set_local $j (i32.load8_u (i32.add $buf $i))) + (set_local $k (i32.add $buf (i32.sub_s (i32.sub_s $len $i) 1))) + (i32.store8_u (i32.add $buf $i) (i32.load8_u $k)) + (i32.store8_u $k $j) + (set_local $i (i32.add $i 1)) + (br $loop) + ) + ) + + (i32.add $buf $len) ) ;; TODO: switch to snprint* (add buffer len) @@ -107,17 +151,15 @@ (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) (param $v5 i32) (result i32) - (local $ch i32) - (local $pstr i32) - (local $v i32) - (local $vidx i32) - (local $len i32) + (local $ch i32 $pstr i32 $v i32 $vidx i32 $len i32) + (local $pad_cnt i32 $pad_char i32) (set_local $pstr $str) (set_local $vidx 0) (block $done (loop $loop (block $after_v + ;; set $v to the current parameter (block (block (block (block (block (block (br_table 0 1 2 3 4 5 0 $vidx)) (; 0 ;) (set_local $v $v0) (br $after_v)) @@ -144,25 +186,64 @@ ;;; ch=*(fmt++) (set_local $ch (i32.load8_u $fmt)) (set_local $fmt (i32.add 1 $fmt)) + (if (i32.eqz $ch) (br $done)) + + (set_local $pad_cnt 0) + (set_local $pad_char (CHR " ")) + (if (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9"))) + (then + ;; padding requested + (if (i32.eq $ch (CHR "0")) + (then + ;; zero padding requested + (set_local $pad_char (CHR "0")) + ;;; ch=*(fmt++) + (set_local $ch (i32.load8_u $fmt)) + (set_local $fmt (i32.add 1 $fmt)) + (if (i32.eqz $ch) (br $done)))) + (loop $loop + (set_local $pad_cnt (i32.mul_s $pad_cnt 10)) + (set_local $pad_cnt (i32.add $pad_cnt + (i32.sub_s $ch (CHR "0")))) + (set_local $ch (i32.load8_u $fmt)) + (set_local $fmt (i32.add 1 $fmt)) + (if (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9"))) + (br $loop)) + ))) (if (i32.eq (CHR "d") $ch) (then - (set_local $pstr ($_sprintnum $pstr $v 10))) + (set_local $pstr ($_sprintnum $pstr $v 10 $pad_cnt $pad_char))) (else (if (i32.eq (CHR "x") $ch) (then - (set_local $pstr ($_sprintnum $pstr $v 16))) + (set_local $pstr ($_sprintnum $pstr $v 16 $pad_cnt $pad_char))) (else (if (i32.eq (CHR "s") $ch) (then (set_local $len ($strlen $v)) + (block $done + (loop $loop + (if (i32.le_s $pad_cnt $len) + (br $done)) + (i32.store8_u $pstr (CHR " ")) + (set_local $pstr (i32.add $pstr 1)) + (set_local $pad_cnt (i32.sub_s $pad_cnt 1)) + (br $loop) + ) + ) ($memmove $pstr $v $len) (set_local $pstr (i32.add $pstr $len))) (else (if (i32.eq (CHR "c") $ch) (then (i32.store8_u $pstr $v) (set_local $pstr (i32.add $pstr 1))) + (else (if (i32.eq (CHR "%") $ch) + (then + (i32.store8_u $pstr (CHR "%")) + (set_local $pstr (i32.add $pstr 1)) + (br $loop)) ;; don't increase vidx (else ($printf_1 "Illegal format character: '%c'\n" $ch) - ($exit 3))))))))) + ($exit 3))))))))))) (set_local $vidx (i32.add 1 $vidx)) (br $loop) From 50eea9ad9caa6aa31c7a39f98a9f712133923e07 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sun, 11 Nov 2018 15:30:42 -0600 Subject: [PATCH 0406/1998] wasm: String refactor. Release macro memory Also split platform out. --- wasm/Makefile | 4 +- wasm/core.wam | 21 ++--- wasm/debug.wam | 38 ++++++++- wasm/mem.wam | 149 +++++++++++++++++++++++----------- wasm/platform_libc.wam | 98 ++++++++++++++++++++++ wasm/platform_os.wam | 54 ++++++++++++ wasm/printer.wam | 18 ++-- wasm/{util.wam => printf.wam} | 140 ++++++-------------------------- wasm/step0_repl.wam | 16 ++-- wasm/step1_read_print.wam | 30 ++++--- wasm/step2_eval.wam | 21 +++-- wasm/step3_env.wam | 28 +++---- wasm/step4_if_fn_do.wam | 25 +++--- wasm/step5_tco.wam | 32 ++++---- wasm/step6_file.wam | 23 +++--- wasm/step7_quote.wam | 23 +++--- wasm/step8_macros.wam | 74 +++++++++-------- wasm/step9_try.wam | 76 +++++++++-------- wasm/stepA_mal.wam | 73 +++++++++-------- wasm/string.wam | 4 +- wasm/types.wam | 61 +++++++++++++- 21 files changed, 625 insertions(+), 383 deletions(-) create mode 100644 wasm/platform_libc.wam create mode 100644 wasm/platform_os.wam rename wasm/{util.wam => printf.wam} (57%) diff --git a/wasm/Makefile b/wasm/Makefile index e44953e0f2..c4bb8544fc 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,4 +1,6 @@ -STEP0_DEPS = string.wam util.wam +MODE ?= libc + +STEP0_DEPS = platform_$(MODE).wam string.wam printf.wam STEP1_DEPS = $(STEP0_DEPS) types.wam mem.wam debug.wam reader.wam printer.wam STEP3_DEPS = $(STEP1_DEPS) env.wam STEP4_DEPS = $(STEP3_DEPS) core.wam diff --git a/wasm/core.wam b/wasm/core.wam index ed73dc8138..1709018c8c 100644 --- a/wasm/core.wam +++ b/wasm/core.wam @@ -86,8 +86,8 @@ (if i32 (i32.eq (i32.load8_u $str) (CHR "\x7f")) (then ($INC_REF ($MEM_VAL1_ptr $args))) (else - (drop ($sprintf_1 (get_global $util_buf) "\x7f%s" $str)) - ($STRING (get_global $STRING_T) (get_global $util_buf)))) + (drop ($sprintf_1 (get_global $printf_buf) "\x7f%s" $str)) + ($STRING (get_global $STRING_T) (get_global $printf_buf)))) ) (func $keyword_Q (param $args i32) (result i32) @@ -134,10 +134,10 @@ (func $core_readline (param $args i32) (result i32) (local $line i32 $mv i32) - (set_local $line ($readline ($to_String ($MEM_VAL1_ptr $args)))) - (if (i32.eqz $line) (return ($INC_REF (get_global $NIL)))) + (set_local $line (STATIC_ARRAY 201)) + (if (i32.eqz ($readline ($to_String ($MEM_VAL1_ptr $args)) $line)) + (return ($INC_REF (get_global $NIL)))) (set_local $mv ($STRING (get_global $STRING_T) $line)) - ($free $line) $mv ) @@ -145,14 +145,15 @@ ($read_str ($to_String ($MEM_VAL1_ptr $args)))) (func $slurp (param $args i32) (result i32) - (local $content i32 $mv i32) - (set_local $content ($read_file ($to_String ($MEM_VAL1_ptr $args)))) - (if (i32.le_s $content 0) + (local $mv i32 $size i32) + (set_local $mv ($STRING_INIT (get_global $STRING_T))) + (set_local $size ($read_file ($to_String ($MEM_VAL1_ptr $args)) + ($to_String $mv))) + (if (i32.eqz $size) (then ($THROW_STR_1 "failed to read file '%s'" ($to_String ($MEM_VAL1_ptr $args))) (return ($INC_REF (get_global $NIL))))) - (set_local $mv ($STRING (get_global $STRING_T) $content)) - ($free $content) + (set_local $mv ($STRING_FINALIZE $mv $size)) $mv ) diff --git a/wasm/debug.wam b/wasm/debug.wam index 8ec023d9e6..b998b9614b 100644 --- a/wasm/debug.wam +++ b/wasm/debug.wam @@ -2,6 +2,7 @@ (func $checkpoint_user_memory (set_global $mem_user_start (get_global $mem_unused_start)) + (set_global $string_mem_user_start (get_global $string_mem_next)) ) (func $CHECK_FREE_LIST (result i32) @@ -211,10 +212,42 @@ (i32.add $size $idx) ) + (func $PR_STRINGS (param $start i32) + (local $ms i32 $idx i32) + ($printf_2 "String - showing %d -> %d:\n" + $start (i32.sub_s (get_global $string_mem_next) + (get_global $string_mem))) + (if (i32.le_s (i32.sub_s (get_global $string_mem_next) + (get_global $string_mem)) + $start) + (then ($print " ---\n")) + (else + (set_local $ms (get_global $string_mem)) + (block $done + (loop $loop + (if (i32.ge_u $ms (get_global $string_mem_next)) + (br $done)) + (set_local $idx (i32.sub_u $ms (get_global $string_mem))) + (if (i32.ge_s $idx $start) + ($printf_4 "%4d: refs %2d, size %2d >> '%s'\n" + $idx + (i32.load16_u $ms) + (i32.load16_u (i32.add $ms 2)) + (i32.add $ms 4))) + + (set_local $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (br $loop) + ) + ))) + ) + (func $PR_MEMORY (param $start i32 $end i32) - (local $idx i32) + (local $string_start i32 $idx i32) (if (i32.lt_s $start 0) - (set_local $start (get_global $mem_user_start))) + (then + (set_local $start (get_global $mem_user_start)) + (set_local $string_start (i32.sub_s (get_global $string_mem_user_start) + (get_global $string_mem))))) (if (i32.lt_s $end 0) (set_local $end (get_global $mem_unused_start))) ;;; printf("Values - (mem) showing %d -> %d", start, end) @@ -241,6 +274,7 @@ (br $loopvals) ) ))) + ($PR_STRINGS $string_start) ($PR_MEMORY_SUMMARY_SMALL) ) diff --git a/wasm/mem.wam b/wasm/mem.wam index e67824bd67..8a416ee2bd 100644 --- a/wasm/mem.wam +++ b/wasm/mem.wam @@ -10,9 +10,9 @@ (global $mem_free_list (mut i32) 0) (global $mem_user_start (mut i32) 0) -;; (global $string_mem (mut i32) 0) -;; (global $string_mem_next (mut i32) 0) -;; (global $string_mem_user_start (mut i32) 0) + (global $string_mem (mut i32) 0) + (global $string_mem_next (mut i32) 0) + (global $string_mem_user_start (mut i32) 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General type storage/pointer functions @@ -117,7 +117,7 @@ ;; ($print ">>> init_memory\n") - ($init_sprintf_mem) + ($init_printf_mem) ;; error_str string buffer (set_global $error_str (STATIC_ARRAY 100)) @@ -137,9 +137,12 @@ (set_global $mem_unused_start 0) (set_global $mem_free_list 0) -;; (set_global $string_mem (i32.add (get_global $heap_start) -;; (get_global $MEM_SIZE))) -;; (set_global $string_mem_next (get_global $string_mem)) + (set_global $string_mem (i32.add (get_global $heap_start) + (get_global $MEM_SIZE))) + (set_global $string_mem_next (get_global $string_mem)) + + (set_global $mem_user_start (get_global $mem_unused_start)) + (set_global $string_mem_user_start (get_global $string_mem_next)) ;; Empty values (set_global $NIL @@ -180,10 +183,8 @@ ;; ALLOC_UNUSED ;;; if (res + size > MEM_SIZE) (if (i32.gt_u (i32.add $res $size) (get_global $MEM_SIZE)) - (then - ;; Out of memory, exit - ($print "Out of mal memory!\n") - ($exit 1))) + ;; Out of memory, exit + ($fatal 7 "Out of mal memory!\n")) ;;; if (mem_unused_start += size) (set_global $mem_unused_start (i32.add (get_global $mem_unused_start) $size)) @@ -282,18 +283,16 @@ ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) (if (i32.eq 0 $mv) - (then - ($print "RELEASE of NULL!\n") - ($exit 1))) + ($fatal 7 "RELEASE of NULL!\n")) (if (i32.eq (get_global $FREE_T) $type) (then ($printf_2 "RELEASE of already free mv: 0x%x, idx: 0x%x\n" $mv $idx) - ($exit 1))) + ($fatal 1 ""))) (if (i32.lt_u ($MalVal_refcnt_type $idx) 15) (then ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) - ($exit 1))) + ($fatal 1 ""))) ;; decrease reference count by one (i32.store ($MalVal_ptr $idx) @@ -305,7 +304,7 @@ (if (i32.lt_u ($MalVal_refcnt_type $idx) 32) (then ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) - ($exit 1))) + ($fatal 1 ""))) (return))) ;; our reference count is not 0, so don't release @@ -319,7 +318,7 @@ (br $done)) ;; string, kw, symbol ;; release string, then FREE reference - ($RELEASE_STRING $mv) + ($RELEASE_STRING (i32.add (get_global $string_mem) ($VAL0 $mv))) (br $done)) ;; list, vector (if (i32.ne ($MalVal_val $idx 0) 0) @@ -372,42 +371,98 @@ (if (i32.eq $size 4) (i32.store ($MalVal_val_ptr $idx 2) 0)) ) - ;; Allocate a string as follows: - ;; refcnt (i32 set to 1), string data, NULL byte - (func $STRING_DUPE (param $str i32) (result i32) - (local $len i32 $cur i32 $new i32 $idx i32) - - ;; Calculate length of string needed - (set_local $len ($strlen $str)) + ;; find string in string memory or 0 if not found + (func $FIND_STRING (param $str i32) (result i32) + (local $ms i32) + (set_local $ms (get_global $string_mem)) + (block $done + (loop $loop + (br_if $done (i32.ge_s $ms (get_global $string_mem_next))) + (if (i32.eqz ($strcmp $str (i32.add $ms 4))) + (return $ms)) - ;; leading i32 refcnt + trailing NULL - (set_local $new ($malloc (i32.add 5 $len))) + (set_local $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (br $loop) + ) + ) + 0 + ) - ;; set initial refcnt to 1 - (i32.store $new 1) - ;; skip refcnt - (set_local $cur (i32.add $new 4)) - ;; Set NULL terminator - (i32.store8_u (i32.add $cur $len) 0) + ;; str is a NULL terminated string + ;; size is number of characters in the string not including the + ;; trailing NULL + (func $ALLOC_STRING (param $str i32 $size i32 $intern i32) (result i32) + (local $ms i32) - ;; Copy the characters - ($memmove $cur $str $len) - $new + ;; search for matching string in string_mem + (if $intern + (then + (set_local $ms ($FIND_STRING $str)) + (if $ms + (then + ;;; ms->refcnt += 1 + (i32.store16_u $ms (i32.add (i32.load16_u $ms) 1)) + (return $ms))))) + + ;; no existing matching string so create a new one + (set_local $ms (get_global $string_mem_next)) + (i32.store16_u $ms 1) + ;;; ms->size = sizeof(MalString)+size+1 + (i32.store16_u offset=2 $ms (i32.add (i32.add 4 $size) 1)) + ($memmove (i32.add $ms 4) $str (i32.add $size 1)) + ;;; string_mem_next = (void *)ms + ms->size + (set_global $string_mem_next + ;;(i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (i32.add $ms (i32.load16_u offset=2 $ms))) + +;;($printf_2 "ALLOC_STRING 6 ms 0x%x, refs: %d\n" $ms (i32.load16_u $ms)) + $ms ) - ;; Duplicate regular character array string into a Mal string and - ;; return the MalVal pointer - (func $STRING (param $type i32 $str i32) (result i32) - ($ALLOC_SCALAR $type ($STRING_DUPE $str)) - ) + (func $RELEASE_STRING (param $ms i32) + (local $size i32 $next i32 $ms_idx i32 $idx i32 $type i32 $mv i32) - (func $RELEASE_STRING (param $mv i32) - (local $str i32) - (set_local $str ($MalVal_val ($IDX $mv) 0)) + (if (i32.le_s (i32.load16_u $ms) 0) + (then + ($printf_2 "Release of already free string: %d (0x%x)\n" + (i32.sub_s $ms (get_global $string_mem)) $ms) + ($fatal 1 ""))) - ;; DEBUG -;; ($printf_1 "RELEASE_STRING - calling free on: %d" $str) + ;;; size = ms->size + (set_local $size (i32.load16_u (i32.add $ms 2))) + ;;; *next = (void *)ms + size + (set_local $next (i32.add $ms $size)) + + ;;; ms->refcnt -= 1 + (i32.store16_u $ms (i32.sub_u (i32.load16_u $ms) 1)) - ($free $str) + (if (i32.eqz (i32.load16_u $ms)) + (then + (if (i32.gt_s (get_global $string_mem_next) $next) + (then + ;; If no more references to this string then free it up by + ;; shifting up every string afterwards to fill the gap + ;; (splice). + ($memmove $ms $next (i32.sub_s (get_global $string_mem_next) + $next)) + + ;; Scan the mem values for string types after the freed + ;; string and shift their indexes by size + (set_local $ms_idx (i32.sub_s $ms (get_global $string_mem))) + (set_local $idx ($IDX (get_global $EMPTY_HASHMAP))) + (loop $loop + (set_local $mv ($MalVal_ptr $idx)) + (set_local $type ($TYPE $mv)) + (if (AND (i32.gt_s ($VAL0 $mv) $ms_idx) + (OR (i32.eq $type (get_global $STRING_T)) + (i32.eq $type (get_global $SYMBOL_T)))) + (i32.store ($VAL0_ptr $mv) (i32.sub_s ($VAL0 $mv) $size))) + (set_local $idx (i32.add $idx ($MalVal_size $mv))) + + (br_if $loop (i32.lt_s $idx (get_global $mem_unused_start))) + ))) + + (set_global $string_mem_next + (i32.sub_s (get_global $string_mem_next) $size)))) ) ) diff --git a/wasm/platform_libc.wam b/wasm/platform_libc.wam new file mode 100644 index 0000000000..c561d64952 --- /dev/null +++ b/wasm/platform_libc.wam @@ -0,0 +1,98 @@ +(module $platform_libc + + (import "env" "exit" (func $lib_exit (param i32))) + + (import "env" "stdout" (global $lib_stdout i32)) + (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) + + (import "env" "free" (func $lib_free (param i32))) + (import "env" "readline" (func $lib_readline (param i32) (result i32))) + (import "env" "add_history" (func $lib_add_history (param i32))) + + ;; read_file defintions / FFI information + (global $STAT_SIZE i32 88) + (global $STAT_ST_SIZE_OFFSET i32 44) + (global $STAT_VER_LINUX i32 3) + (global $O_RDONLY i32 0) + (import "env" "open" (func $lib_open (param i32 i32 i32) (result i32))) + (import "env" "read" (func $lib_read (param i32 i32 i32) (result i32))) + (import "env" "__fxstat" (func $lib___fxstat (param i32 i32 i32) (result i32))) + (global $TIMEVAL_SIZE i32 8) + (global $TV_SEC_OFFSET i32 0) + (global $TV_USEC_OFFSET i32 4) + (import "env" "gettimeofday" (func $lib_gettimeofday (param i32 i32) (result i32))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $fatal (param $code i32 $msg i32) + ($print $msg) + ($lib_exit $code) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $print (param $addr i32) + (drop ($lib_fputs $addr (get_global $lib_stdout)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $readline (param $prompt i32 $buf i32) (result i32) + (local $line i32 $len i32) + (set_local $len 0) + + (set_local $line ($lib_readline $prompt)) + (if $line + (then + ($lib_add_history $line) + (set_local $len ($strlen $line)) + ($memmove $buf $line $len) + ($lib_free $line))) + (i32.store8_u (i32.add $buf $len) (CHR "\x00")) + (return (if i32 $line 1 0)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Returns malloc'd string. Must be free by caller + (func $read_file (param $path i32 $buf i32) (result i32) + (local $fst i32 $fd i32 $st_size i32 $sz i32) + (set_local $fst (STATIC_ARRAY 100)) ;; at least STAT_SIZE + + (set_local $fd ($lib_open $path (get_global $O_RDONLY) 0)) + (if (i32.lt_s $fd 0) + (then + ($printf_1 "ERROR: slurp failed to open '%s'\n" $path) + (return 0))) + (if (i32.lt_s ($lib___fxstat (get_global $STAT_VER_LINUX) $fd $fst) 0) + (then + ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) + (return 0))) + (set_local $st_size (i32.load + (i32.add $fst (get_global $STAT_ST_SIZE_OFFSET)))) + (set_local $sz ($lib_read $fd $buf $st_size)) + (if (i32.ne $sz $st_size) + (then + ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) + (return 0))) + ;; Add null to string + (i32.store8_u (i32.add $buf $st_size) 0) + (i32.add 1 $st_size) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + (func $get_time_ms (result i32) + (local $tv i32 $secs i32 $usecs i32 $msecs i32) + (set_local $tv (STATIC_ARRAY 10)) ;; at least TIMEVAL_SIZE + (drop ($lib_gettimeofday $tv 0)) + (set_local $secs (i32.load (i32.add $tv (get_global $TV_SEC_OFFSET)))) + ;; subtract 30 years to make sure secs is positive and can be + ;; multiplied by 1000 + (set_local $secs (i32.sub_s $secs 0x38640900)) + (set_local $usecs (i32.load (i32.add $tv (get_global $TV_USEC_OFFSET)))) + (set_local $msecs (i32.add (i32.mul_u $secs 1000) + (i32.div_u $usecs 1000))) + $msecs + ) +) diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam new file mode 100644 index 0000000000..f7e0ec029a --- /dev/null +++ b/wasm/platform_os.wam @@ -0,0 +1,54 @@ +(module $platform_os + + (import "env" "exit" (func $lib_exit (param i32))) + + (import "env" "stdout" (global $lib_stdout i32)) + (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) + + (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) + (import "env" "add_history" (func $lib_add_history (param i32))) + + (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $fatal (param $code i32 $msg i32) + ($print $msg) + ($lib_exit $code) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $print (param $addr i32) + (drop ($lib_fputs $addr (get_global $lib_stdout)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $readline (param $prompt i32 $buf i32) (result i32) + (local $res i32) + + ;; TODO: don't hardcode count to 200 + (set_local $res ($lib_readline $prompt $buf 200)) + (if $res + ($lib_add_history $buf)) + $res + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $read_file (param $path i32 $buf i32) (result i32) + (local $size i32) + (set_local $size ($lib_read_file $path $buf)) + ;; Add null to string + (i32.store8_u (i32.add $buf $size) 0) + (i32.add $size 1) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + (func $get_time_ms (result i32) + 0 + ) + +) diff --git a/wasm/printer.wam b/wasm/printer.wam index 95afdc482d..34cba901e5 100644 --- a/wasm/printer.wam +++ b/wasm/printer.wam @@ -147,26 +147,28 @@ (func $pr_str_internal (param $seq i32) (param $mv i32) (param $print_readably i32) (param $sep i32) (result i32) - (local $res i32) - (set_local $res (get_global $printer_buf)) - (i32.store8_u $res 0) + (local $res i32 $res_str i32) + (set_local $res ($STRING_INIT (get_global $STRING_T))) + (set_local $res_str ($to_String $res)) (if $seq (then (block $done (loop $loop - (if (i32.eqz ($VAL0 $mv)) (br $done)) - (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + (br_if $done (i32.eqz ($VAL0 $mv))) + (set_local $res_str ($pr_str_val $res_str ($MEM_VAL1_ptr $mv) $print_readably)) (set_local $mv ($MEM_VAL0_ptr $mv)) (if (i32.ne ($VAL0 $mv) 0) - (set_local $res ($sprintf_1 $res "%s" $sep))) + (set_local $res_str ($sprintf_1 $res_str "%s" $sep))) (br $loop) ) )) (else - (set_local $res ($pr_str_val $res $mv $print_readably)))) + (set_local $res_str ($pr_str_val $res_str $mv $print_readably)))) - ($STRING (get_global $STRING_T) (get_global $printer_buf)) + (set_local $res ($STRING_FINALIZE $res (i32.sub_s $res_str ($to_String $res)))) + + $res ) (func $pr_str (param $mv i32 $print_readably i32) (result i32) diff --git a/wasm/util.wam b/wasm/printf.wam similarity index 57% rename from wasm/util.wam rename to wasm/printf.wam index f0238101df..68ca24ca43 100644 --- a/wasm/util.wam +++ b/wasm/printf.wam @@ -1,74 +1,49 @@ -(module $util - (import "env" "malloc" (func $malloc (param i32) (result i32))) - (import "env" "free" (func $free (param i32))) - (import "env" "exit" (func $exit (param i32))) +(module $printf - (import "env" "stdout" (global $stdout i32)) - (import "env" "fputs" (func $fputs (param i32 i32) (result i32))) - ;;(import "env" "readline" (func $readline (param i32) (result i32))) - (import "libedit.so" "readline" (func $readline (param i32) (result i32))) - ;;(import "libreadline.so" "readline" (func $readline (param i32) (result i32))) + (global $printf_buf (mut i32) 0) - (global $util_buf (mut i32) 0) - - ;; read_file defintions / FFI information - (global $STAT_SIZE i32 88) - (global $STAT_ST_SIZE_OFFSET i32 44) - (global $STAT_VER_LINUX i32 3) - (global $O_RDONLY i32 0) - (import "env" "open" (func $open (param i32 i32 i32) (result i32))) - (import "env" "read" (func $read (param i32 i32 i32) (result i32))) - (import "env" "__fxstat" (func $__fxstat (param i32 i32 i32) (result i32))) - (global $TIMEVAL_SIZE i32 8) - (global $TV_SEC_OFFSET i32 0) - (global $TV_USEC_OFFSET i32 4) - (import "env" "gettimeofday" (func $gettimeofday (param i32 i32) (result i32))) - - (func $init_sprintf_mem + (func $init_printf_mem ;; sprintf static buffer - (set_global $util_buf (STATIC_ARRAY 256)) - ) + (set_global $printf_buf (STATIC_ARRAY 256)) + ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (func $print (param $addr i32) - (drop ($fputs $addr (get_global $stdout)))) - (func $printf_1 (param $fmt i32) (param $v0 i32) - (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 0 0 0 0 0)) - ($print (get_global $util_buf)) + (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 0 0 0 0 0)) + ($print (get_global $printf_buf)) ) (func $printf_2 (param $fmt i32 $v0 i32 $v1 i32) - (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 0 0 0 0)) - ($print (get_global $util_buf)) + (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 0 0 0 0)) + ($print (get_global $printf_buf)) ) (func $printf_3 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) - (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 0 0 0)) - ($print (get_global $util_buf)) + (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 0 0 0)) + ($print (get_global $printf_buf)) ) (func $printf_4 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) - (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 $v3 0 0)) - ($print (get_global $util_buf)) + (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) + ($print (get_global $printf_buf)) ) (func $printf_5 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) - (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) - ($print (get_global $util_buf)) + (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) + ($print (get_global $printf_buf)) ) (func $printf_6 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) (param $v5 i32) - (drop ($sprintf_6 (get_global $util_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) - ($print (get_global $util_buf)) + (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) + ($print (get_global $printf_buf)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -95,18 +70,18 @@ ;; Calculate smallest to most significant digit (loop $loop (set_local $digit (i32.rem_u $val $radix)) - (i32.store8_u $pbuf (if i32 (i32.lt_s $digit 10) + (i32.store8_u $pbuf (if i32 (i32.lt_u $digit 10) (i32.add (CHR "0") $digit) - (i32.sub_s (i32.add (CHR "A") $digit) 10))) + (i32.sub_u (i32.add (CHR "A") $digit) 10))) (set_local $pbuf (i32.add $pbuf 1)) - (set_local $val (i32.div_s $val $radix)) - (if (i32.gt_s $val 0) (br $loop)) + (set_local $val (i32.div_u $val $radix)) + (if (i32.gt_u $val 0) (br $loop)) ) - (set_local $i (i32.sub_s $pbuf $buf)) + (set_local $i (i32.sub_u $pbuf $buf)) (block $done (loop $loop - (if (i32.ge_s $i $pad_cnt) (br $done)) + (if (i32.ge_u $i $pad_cnt) (br $done)) (i32.store8_u $pbuf $pad_char) (set_local $pbuf (i32.add $pbuf 1)) (set_local $i (i32.add $i 1)) @@ -122,15 +97,15 @@ (i32.store8_u $pbuf (CHR "\x00")) ;; now reverse it - (set_local $len (i32.sub_s $pbuf $buf)) + (set_local $len (i32.sub_u $pbuf $buf)) (set_local $i 0) (block $done (loop $loop - (if (i32.ge_s $i (i32.div_s $len 2)) + (if (i32.ge_u $i (i32.div_u $len 2)) (br $done)) (set_local $j (i32.load8_u (i32.add $buf $i))) - (set_local $k (i32.add $buf (i32.sub_s (i32.sub_s $len $i) 1))) + (set_local $k (i32.add $buf (i32.sub_u (i32.sub_u $len $i) 1))) (i32.store8_u (i32.add $buf $i) (i32.load8_u $k)) (i32.store8_u $k $j) (set_local $i (i32.add $i 1)) @@ -243,7 +218,7 @@ (br $loop)) ;; don't increase vidx (else ($printf_1 "Illegal format character: '%c'\n" $ch) - ($exit 3))))))))))) + ($fatal 3 ""))))))))))) (set_local $vidx (i32.add 1 $vidx)) (br $loop) @@ -254,65 +229,4 @@ $pstr ) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Returns malloc'd string. Must be free by caller - (func $read_file (param $path i32) (result i32) - (local $fst i32 $fd i32 $str i32 $st_size i32 $sz i32) - (set_local $str 0) - (set_local $fst ($malloc (get_global $STAT_SIZE))) - (if (i32.le_s $fst 0) - (then - ($printf_1 "ERROR: malloc of %d bytes failed\n" - (get_global $STAT_SIZE)) - (return 0))) - - (block $free_fst - (set_local $fd ($open $path (get_global $O_RDONLY) 0)) - (if (i32.lt_s $fd 0) - (then - ($printf_1 "ERROR: slurp failed to open '%s'\n" $path) - (br $free_fst))) - (if (i32.lt_s ($__fxstat (get_global $STAT_VER_LINUX) $fd $fst) 0) - (then - ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) - (br $free_fst))) - (set_local $st_size (i32.load - (i32.add $fst (get_global $STAT_ST_SIZE_OFFSET)))) - (set_local $str ($malloc (i32.add 1 $st_size))) - (if (i32.le_s $str 0) - (then - ($printf_1 "ERROR: malloc of %d bytes failed\n" $st_size) - (br $free_fst))) - (set_local $sz ($read $fd $str $st_size)) - (if (i32.ne $sz $st_size) - (then - ($free $str) - (set_local $str 0) - ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) - (br $free_fst))) - ;; Add null to string - (i32.store8_u (i32.add $str $st_size) 0) - ) - ($free $fst) - $str - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - (func $get_time_ms (result i32) - (local $tv i32 $secs i32 $usecs i32 $msecs i32) - (set_local $tv ($malloc (get_global $TIMEVAL_SIZE))) - (drop ($gettimeofday $tv 0)) - (set_local $secs (i32.load (i32.add $tv (get_global $TV_SEC_OFFSET)))) - ;; subtract 30 years to make sure secs is positive and can be - ;; multiplied by 1000 - (set_local $secs (i32.sub_s $secs 0x38640900)) - (set_local $usecs (i32.load (i32.add $tv (get_global $TV_USEC_OFFSET)))) - (set_local $msecs (i32.add (i32.mul_u $secs 1000) - (i32.div_u $usecs 1000))) - ($free $tv) - $msecs - ) ) diff --git a/wasm/step0_repl.wam b/wasm/step0_repl.wam index a1b4a07add..167c773335 100644 --- a/wasm/step0_repl.wam +++ b/wasm/step0_repl.wam @@ -22,15 +22,21 @@ (func $main (result i32) ;; Constant location/value definitions (local $line i32) + (set_local $line (STATIC_ARRAY 201)) + + ;; DEBUG + ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + ;;($printf_1 "here1 %d\n", 7); ($printf_1 "%s\n" ($rep $line)) - ($free $line) - (br $repl_loop))) + (br $repl_loop) + ) + ) ($print "\n") 0 @@ -38,6 +44,6 @@ (export "_main" (func $main)) - (export "__post_instantiate" (func $init_sprintf_mem)) + (export "__post_instantiate" (func $init_printf_mem)) ) diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam index a9e017b0b0..d9ef2b85ef 100644 --- a/wasm/step1_read_print.wam +++ b/wasm/step1_read_print.wam @@ -20,13 +20,14 @@ (local $mv1 i32 $mv2 i32 $ms i32) (block $rep_done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $rep_done (get_global $error_type)) (set_local $mv2 ($EVAL $mv1 $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $rep_done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) + ) ;; release memory from MAL_READ @@ -36,6 +37,7 @@ (func $main (result i32) (local $line i32 $res i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -43,17 +45,18 @@ ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) - ;;($PR_MEMORY -1 -1) - ;; Start +;; ($PR_MEMORY_RAW +;; (get_global $mem) (i32.add (get_global $mem) +;; (i32.mul_u (get_global $mem_unused_start) 4))) + + ($PR_MEMORY -1 -1) + + ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line 0)) (if (get_global $error_type) (then @@ -62,9 +65,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam index c8852852b2..656dca3bf7 100644 --- a/wasm/step2_eval.wam +++ b/wasm/step2_eval.wam @@ -112,8 +112,9 @@ (if (get_global $error_type) (return 0)) - (if (i32.ne $type (get_global $LIST_T)) - (return ($EVAL_AST $ast $env))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne $type (get_global $LIST_T)) (return ($EVAL_AST $ast $env))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) @@ -187,6 +188,7 @@ (func $main (result i32) (local $line i32 $res i32 $repl_env i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -208,12 +210,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -222,9 +220,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam index 83de79e720..f089c98c9d 100644 --- a/wasm/step3_env.wam +++ b/wasm/step3_env.wam @@ -100,7 +100,7 @@ (func $EVAL (param $ast i32 $env i32) (result i32) (local $res i32) - (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $ftype i32 $f_args i32 $f i32 $args i32) (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) (local $let_env i32) @@ -108,13 +108,13 @@ (set_local $f_args 0) (set_local $f 0) (set_local $args 0) - (set_local $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) (if (get_global $error_type) (return 0)) - (if (i32.ne $type (get_global $LIST_T)) (return ($EVAL_AST $ast $env))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (return ($EVAL_AST $ast $env))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) @@ -182,7 +182,7 @@ (then (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))) (else - ($THROW_STR_1 "apply of non-function type: %d\n" $type) + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) (set_local $res 0))) ($RELEASE $f_args))))) @@ -237,6 +237,7 @@ (func $main (result i32) (local $line i32 $res i32 $repl_env i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -258,12 +259,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -272,9 +269,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step4_if_fn_do.wam b/wasm/step4_if_fn_do.wam index f87754176a..273ccf7b76 100644 --- a/wasm/step4_if_fn_do.wam +++ b/wasm/step4_if_fn_do.wam @@ -94,7 +94,7 @@ (func $EVAL (param $ast i32 $env i32) (result i32) (local $res i32 $el i32) - (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (local $ftype i32 $f_args i32 $f i32 $args i32) (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32 $a3 i32) (local $let_env i32 $fn_env i32 $a i32) @@ -103,10 +103,9 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (get_global $error_type) (return 0)) - (if (get_global $error_type) - (return 0)) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (return ($EVAL_AST $ast $env))) @@ -229,7 +228,7 @@ ($RELEASE $a)) (else ;; create new environment using env and params stored in function - ($THROW_STR_1 "apply of non-function type: %d\n" $type) + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) (set_local $res 0) ($RELEASE $f_args))))))))))))))) @@ -273,6 +272,7 @@ (func $main (result i32) (local $line i32 $res i32 $repl_env i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -295,12 +295,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -309,9 +305,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam index e9db72eb5b..2aca251315 100644 --- a/wasm/step5_tco.wam +++ b/wasm/step5_tco.wam @@ -113,13 +113,13 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (get_global $error_type) (then (set_local $res 0) (br $EVAL_return))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (then (set_local $res ($EVAL_AST $ast $env 0)) @@ -188,6 +188,7 @@ ;; EVAL the rest through second to last (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) (set_local $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) @@ -322,12 +323,14 @@ (func $main (result i32) (local $line i32 $res i32 $repl_env i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG - ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) - ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) - ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) - ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) (set_global $repl_env ($ENV_NEW (get_global $NIL))) @@ -336,6 +339,8 @@ ;; core.EXT: defined in wasm ($add_core_ns $repl_env) + ($checkpoint_user_memory) + ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) @@ -344,12 +349,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -358,9 +359,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam index e58c424529..33da6cfdff 100644 --- a/wasm/step6_file.wam +++ b/wasm/step6_file.wam @@ -113,13 +113,13 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (get_global $error_type) (then (set_local $res 0) (br $EVAL_return))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (then (set_local $res ($EVAL_AST $ast $env 0)) @@ -188,6 +188,7 @@ ;; EVAL the rest through second to last (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) (set_local $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) @@ -329,6 +330,7 @@ (local $line i32 $res i32 $repl_env i32) ;; argument processing (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -345,6 +347,8 @@ ($add_core_ns $repl_env) (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + ($checkpoint_user_memory) + ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) @@ -400,12 +404,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -414,9 +414,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam index 16b4e8555e..9a718cc1a9 100644 --- a/wasm/step7_quote.wam +++ b/wasm/step7_quote.wam @@ -165,13 +165,13 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (get_global $error_type) (then (set_local $res 0) (br $EVAL_return))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (then (set_local $res ($EVAL_AST $ast $env 0)) @@ -240,6 +240,7 @@ ;; EVAL the rest through second to last (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) (set_local $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) @@ -393,6 +394,7 @@ (local $line i32 $res i32 $repl_env i32) ;; argument processing (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -409,6 +411,8 @@ ($add_core_ns $repl_env) (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + ($checkpoint_user_memory) + ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) @@ -464,12 +468,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -478,9 +478,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam index 6fb6da1f2e..389977b532 100644 --- a/wasm/step8_macros.wam +++ b/wasm/step8_macros.wam @@ -60,12 +60,12 @@ $res ) - (global $mac_ast_stack (mut i32) (i32.const 0)) - (global $mac_ast_stack_top (mut i32) (i32.const -1)) + (global $mac_stack (mut i32) (i32.const 0)) + (global $mac_stack_top (mut i32) (i32.const -1)) (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) (local $ast i32 $mac i32 $mac_env i64) - (set_global $mac_ast_stack (STATIC_ARRAY 128)) + (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4 (set_local $ast $orig_ast) (set_local $mac 0) (block $done @@ -89,16 +89,18 @@ ;; to the pending release list. (if (i32.ne $ast $orig_ast) (then - (set_global $mac_ast_stack_top - (i32.add (get_global $mac_ast_stack_top) 1)) + (set_global $mac_stack_top + (i32.add (get_global $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul_s (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add - (get_global $mac_ast_stack) - (i32.mul_s (get_global $mac_ast_stack_top) 4)) + (get_global $mac_stack) + (i32.mul_s (get_global $mac_stack_top) 4)) $ast))) (if (get_global $error_type) (br $done)) - (br $loop) + (br $loop) ) ) $ast @@ -195,12 +197,14 @@ (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) (local $ftype i32 $f_args i32 $f i32 $args i32) (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) + (local $orig_mac_stack_top i32) (set_local $ast $orig_ast) (set_local $env $orig_env) (set_local $prev_ast 0) (set_local $prev_env 0) (set_local $res 0) + (set_local $orig_mac_stack_top (get_global $mac_stack_top)) (block $EVAL_return (loop $TCO_loop @@ -209,13 +213,13 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (get_global $error_type) (then (set_local $res 0) (br $EVAL_return))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (then (set_local $res ($EVAL_AST $ast $env 0)) @@ -292,6 +296,7 @@ ;; EVAL the rest through second to last (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) (set_local $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) @@ -421,6 +426,23 @@ (if (i32.ne $env $orig_env) ($RELEASE $env)) (if $prev_ast ($RELEASE $prev_ast)) + ;; release memory from MACROEXPAND + ;; TODO: needs to happen here so self-hosting doesn't leak + (block $done + (loop $loop + (if (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top) + (br $done)) +;;($printf_1 "free orig_mac_stack_top: %d\n" $orig_mac_stack_top) +;;($printf_1 "free mac_stack_top: %d\n" (get_global $mac_stack_top)) + ($RELEASE (i32.load (i32.add + (get_global $mac_stack) + (i32.mul_s (get_global $mac_stack_top) 4)))) + (set_global $mac_stack_top + (i32.sub_s (get_global $mac_stack_top) 1)) + (br $loop) + ) + ) + $res ) @@ -441,20 +463,6 @@ ;; release memory from MAL_READ ($RELEASE $mv1) - ;; release memory from MACROEXPAND - ;; TODO: needs to happen in EVAL - (block $done - (loop $loop - (if (i32.lt_s (get_global $mac_ast_stack_top) 0) - (br $done)) - ($RELEASE (i32.load (i32.add - (get_global $mac_ast_stack) - (i32.mul_s (get_global $mac_ast_stack_top) 4)))) - (set_global $mac_ast_stack_top - (i32.sub_s (get_global $mac_ast_stack_top) 1)) - (br $loop) - ) - ) $res ) @@ -477,6 +485,7 @@ (local $line i32 $res i32 $repl_env i32) ;; argument processing (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -493,6 +502,8 @@ ($add_core_ns $repl_env) (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + ($checkpoint_user_memory) + ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env)) @@ -550,12 +561,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -564,9 +571,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam index 3ebeee1369..67fd7fda36 100644 --- a/wasm/step9_try.wam +++ b/wasm/step9_try.wam @@ -1,4 +1,4 @@ -(module $step8_macros +(module $step9_try (global $repl_env (mut i32) (i32.const 0)) @@ -60,12 +60,12 @@ $res ) - (global $mac_ast_stack (mut i32) (i32.const 0)) - (global $mac_ast_stack_top (mut i32) (i32.const -1)) + (global $mac_stack (mut i32) (i32.const 0)) + (global $mac_stack_top (mut i32) (i32.const -1)) (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) (local $ast i32 $mac i32 $mac_env i64) - (set_global $mac_ast_stack (STATIC_ARRAY 128)) + (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4 (set_local $ast $orig_ast) (set_local $mac 0) (block $done @@ -89,16 +89,18 @@ ;; to the pending release list. (if (i32.ne $ast $orig_ast) (then - (set_global $mac_ast_stack_top - (i32.add (get_global $mac_ast_stack_top) 1)) + (set_global $mac_stack_top + (i32.add (get_global $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul_s (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add - (get_global $mac_ast_stack) - (i32.mul_s (get_global $mac_ast_stack_top) 4)) + (get_global $mac_stack) + (i32.mul_s (get_global $mac_stack_top) 4)) $ast))) (if (get_global $error_type) (br $done)) - (br $loop) + (br $loop) ) ) $ast @@ -196,12 +198,14 @@ (local $ftype i32 $f_args i32 $f i32 $args i32) (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) (local $err i32) + (local $orig_mac_stack_top i32) (set_local $ast $orig_ast) (set_local $env $orig_env) (set_local $prev_ast 0) (set_local $prev_env 0) (set_local $res 0) + (set_local $orig_mac_stack_top (get_global $mac_stack_top)) (block $EVAL_return (loop $TCO_loop @@ -210,13 +214,13 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (get_global $error_type) (then (set_local $res 0) (br $EVAL_return))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (then (set_local $res ($EVAL_AST $ast $env 0)) @@ -293,6 +297,7 @@ ;; EVAL the rest through second to last (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) (set_local $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) @@ -334,7 +339,6 @@ (if (i32.eqz (get_global $error_type)) (br $EVAL_return)) ;; if there is an error and res is set, we need to free it - ($printf_1 "res value: %d\n" $res) ($RELEASE $res) ;; if there is no catch block then return (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) @@ -470,6 +474,23 @@ (if (i32.ne $env $orig_env) ($RELEASE $env)) (if $prev_ast ($RELEASE $prev_ast)) + ;; release memory from MACROEXPAND + ;; TODO: needs to happen here so self-hosting doesn't leak + (block $done + (loop $loop + (if (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top) + (br $done)) +;;($printf_1 "free orig_mac_stack_top: %d\n" $orig_mac_stack_top) +;;($printf_1 "free mac_stack_top: %d\n" (get_global $mac_stack_top)) + ($RELEASE (i32.load (i32.add + (get_global $mac_stack) + (i32.mul_s (get_global $mac_stack_top) 4)))) + (set_global $mac_stack_top + (i32.sub_s (get_global $mac_stack_top) 1)) + (br $loop) + ) + ) + $res ) @@ -490,20 +511,6 @@ ;; release memory from MAL_READ ($RELEASE $mv1) - ;; release memory from MACROEXPAND - ;; TODO: needs to happen in EVAL - (block $done - (loop $loop - (if (i32.lt_s (get_global $mac_ast_stack_top) 0) - (br $done)) - ($RELEASE (i32.load (i32.add - (get_global $mac_ast_stack) - (i32.mul_s (get_global $mac_ast_stack_top) 4)))) - (set_global $mac_ast_stack_top - (i32.sub_s (get_global $mac_ast_stack_top) 1)) - (br $loop) - ) - ) $res ) @@ -526,6 +533,7 @@ (local $line i32 $res i32 $repl_env i32) ;; argument processing (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -542,6 +550,7 @@ ($add_core_ns $repl_env) (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + ($checkpoint_user_memory) ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) @@ -600,12 +609,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -614,9 +619,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) -;; ($PR_MEMORY -1 -1) - ($free $line) - (br $repl_loop))) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index 4d0788fd54..f196fabc98 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -1,4 +1,4 @@ -(module $step8_macros +(module $stepA_mal (global $repl_env (mut i32) (i32.const 0)) @@ -60,12 +60,12 @@ $res ) - (global $mac_ast_stack (mut i32) (i32.const 0)) - (global $mac_ast_stack_top (mut i32) (i32.const -1)) + (global $mac_stack (mut i32) (i32.const 0)) + (global $mac_stack_top (mut i32) (i32.const -1)) (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) (local $ast i32 $mac i32 $mac_env i64) - (set_global $mac_ast_stack (STATIC_ARRAY 128)) + (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4 (set_local $ast $orig_ast) (set_local $mac 0) (block $done @@ -89,16 +89,18 @@ ;; to the pending release list. (if (i32.ne $ast $orig_ast) (then - (set_global $mac_ast_stack_top - (i32.add (get_global $mac_ast_stack_top) 1)) + (set_global $mac_stack_top + (i32.add (get_global $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul_s (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add - (get_global $mac_ast_stack) - (i32.mul_s (get_global $mac_ast_stack_top) 4)) + (get_global $mac_stack) + (i32.mul_s (get_global $mac_stack_top) 4)) $ast))) (if (get_global $error_type) (br $done)) - (br $loop) + (br $loop) ) ) $ast @@ -196,12 +198,14 @@ (local $ftype i32 $f_args i32 $f i32 $args i32) (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) (local $err i32) + (local $orig_mac_stack_top i32) (set_local $ast $orig_ast) (set_local $env $orig_env) (set_local $prev_ast 0) (set_local $prev_env 0) (set_local $res 0) + (set_local $orig_mac_stack_top (get_global $mac_stack_top)) (block $EVAL_return (loop $TCO_loop @@ -210,13 +214,13 @@ (set_local $f 0) (set_local $args 0) - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (get_global $error_type) (then (set_local $res 0) (br $EVAL_return))) + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) (then (set_local $res ($EVAL_AST $ast $env 0)) @@ -293,6 +297,7 @@ ;; EVAL the rest through second to last (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) (set_local $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) @@ -334,7 +339,6 @@ (if (i32.eqz (get_global $error_type)) (br $EVAL_return)) ;; if there is an error and res is set, we need to free it - ($printf_1 "res value: %d\n" $res) ($RELEASE $res) ;; if there is no catch block then return (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) @@ -470,6 +474,23 @@ (if (i32.ne $env $orig_env) ($RELEASE $env)) (if $prev_ast ($RELEASE $prev_ast)) + ;; release memory from MACROEXPAND + ;; TODO: needs to happen here so self-hosting doesn't leak + (block $done + (loop $loop + (if (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top) + (br $done)) +;;($printf_1 "free orig_mac_stack_top: %d\n" $orig_mac_stack_top) +;;($printf_1 "free mac_stack_top: %d\n" (get_global $mac_stack_top)) + ($RELEASE (i32.load (i32.add + (get_global $mac_stack) + (i32.mul_s (get_global $mac_stack_top) 4)))) + (set_global $mac_stack_top + (i32.sub_s (get_global $mac_stack_top) 1)) + (br $loop) + ) + ) + $res ) @@ -490,20 +511,6 @@ ;; release memory from MAL_READ ($RELEASE $mv1) - ;; release memory from MACROEXPAND - ;; TODO: needs to happen in EVAL - (block $done - (loop $loop - (if (i32.lt_s (get_global $mac_ast_stack_top) 0) - (br $done)) - ($RELEASE (i32.load (i32.add - (get_global $mac_ast_stack) - (i32.mul_s (get_global $mac_ast_stack_top) 4)))) - (set_global $mac_ast_stack_top - (i32.sub_s (get_global $mac_ast_stack_top) 1)) - (br $loop) - ) - ) $res ) @@ -526,6 +533,7 @@ (local $line i32 $res i32 $repl_env i32) ;; argument processing (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) + (set_local $line (STATIC_ARRAY 201)) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -605,12 +613,8 @@ ;; Start REPL (block $repl_done (loop $repl_loop - (set_local $line ($readline "user> ")) - (if (i32.eqz $line) (br $repl_done)) - (if (i32.eq (i32.load8_u $line) 0) - (then - ($free $line) - (br $repl_loop))) + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then @@ -619,9 +623,10 @@ (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) - ($free $line) ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop))) + (br $repl_loop) + ) + ) ($print "\n") ;;($PR_MEMORY -1 -1) diff --git a/wasm/string.wam b/wasm/string.wam index 4a68c0c369..dd2ff3cd04 100644 --- a/wasm/string.wam +++ b/wasm/string.wam @@ -162,9 +162,7 @@ (set_local $needle_len ($strlen $needle)) (set_local $replace_len ($strlen $replace)) (if (i32.gt_u $replace_len $needle_len) - (then - ($print "REPLACE: invalid expanding in-place call\n") - ($exit 1))) + ($fatal 7 "REPLACE: invalid expanding in-place call\n")) (set_local $s (i32.add $s 1)) (br $loop) ) diff --git a/wasm/types.wam b/wasm/types.wam index 8f14ad9a3a..5574c3d3be 100644 --- a/wasm/types.wam +++ b/wasm/types.wam @@ -125,9 +125,66 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; string functions + (func $to_MalString (param $mv i32) (result i32) + ;; TODO: assert mv is a string/keyword/symbol + (i32.add (get_global $string_mem) ($VAL0 $mv)) + ) + (func $to_String (param $mv i32) (result i32) - ;; skip string refcnt - (i32.add 4 ($VAL0 $mv)) + ;; skip string refcnt and size + (i32.add 4 ($to_MalString $mv)) + ) + + ;; Duplicate regular character array string into a Mal string and + ;; return the MalVal pointer + (func $STRING (param $type i32 $str i32) (result i32) + (local $ms i32) + ;; TODO: assert mv is a string/keyword/symbol + (set_local $ms ($ALLOC_STRING $str ($strlen $str) 1)) + ($ALLOC_SCALAR $type (i32.sub_u $ms (get_global $string_mem))) + ) + + ;; Find first duplicate (internet) of mv. If one is found, free up + ;; mv and return the interned version. If no duplicate is found, + ;; return NULL. + (func $INTERN_STRING (param $mv i32) (result i32) + (local $res i32 $ms i32 $existing_ms i32 $tmp i32) + (set_local $res 0) + (set_local $ms ($to_MalString $mv)) + (set_local $existing_ms ($FIND_STRING (i32.add $ms 4))) + (if (AND $existing_ms (i32.lt_s $existing_ms $ms)) + (then + (set_local $tmp $mv) + (set_local $res ($ALLOC_SCALAR (get_global $STRING_T) + (i32.sub_s $existing_ms + (get_global $string_mem)))) + (i32.store16_u $existing_ms (i32.add (i32.load16_u $existing_ms) 1)) + ($RELEASE $tmp))) + $res + ) + + (func $STRING_INIT (param $type i32) (result i32) + (local $ms i32) + (set_local $ms ($ALLOC_STRING "" 0 0)) + ($ALLOC_SCALAR $type (i32.sub_s $ms (get_global $string_mem))) + ) + + (func $STRING_FINALIZE (param $mv i32 $size i32) (result i32) + (local $tmp i32 $ms i32) + ;; Check if the new string can be interned. + (set_local $tmp ($INTERN_STRING $mv)) + (set_local $ms ($to_MalString $mv)) + (if $tmp + (then + (set_local $mv $tmp)) + (else + ;;; ms->size = sizeof(MalString) + size + 1 + (i32.store16_u (i32.add $ms 2) + (i32.add (i32.add 4 $size) 1)) + ;;; string_mem_next = (void *)ms + ms->size + (set_global $string_mem_next + (i32.add $ms (i32.load16_u (i32.add $ms 2)))))) + $mv ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 349faa83e3e8ffd96851514dbe6243ef3353ab7f Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sun, 11 Nov 2018 17:55:38 -0600 Subject: [PATCH 0407/1998] wasm: use LET macro and br_if. --- wasm/core.wam | 188 ++++++++++++++++---------------------- wasm/debug.wam | 70 +++++++------- wasm/env.wam | 31 +++---- wasm/mem.wam | 21 ++--- wasm/platform_libc.wam | 18 ++-- wasm/platform_os.wam | 7 +- wasm/printer.wam | 14 ++- wasm/printf.wam | 36 +++----- wasm/reader.wam | 99 +++++++++----------- wasm/step0_repl.wam | 4 +- wasm/step1_read_print.wam | 27 +++--- wasm/step2_eval.wam | 50 +++++----- wasm/step3_env.wam | 53 ++++++----- wasm/step4_if_fn_do.wam | 56 ++++++------ wasm/step5_tco.wam | 45 ++++----- wasm/step6_file.wam | 51 +++++------ wasm/step7_quote.wam | 57 +++++------- wasm/step8_macros.wam | 97 +++++++++----------- wasm/step9_try.wam | 106 +++++++++------------ wasm/stepA_mal.wam | 106 +++++++++------------ wasm/string.wam | 41 ++++----- wasm/types.wam | 90 ++++++++---------- 22 files changed, 560 insertions(+), 707 deletions(-) diff --git a/wasm/core.wam b/wasm/core.wam index 1709018c8c..12d2090849 100644 --- a/wasm/core.wam +++ b/wasm/core.wam @@ -58,14 +58,12 @@ ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $NIL_T)))) (func $true_Q (param $args i32) (result i32) - (local $ast i32) - (set_local $ast ($MEM_VAL1_ptr $args)) + (LET $ast ($MEM_VAL1_ptr $args)) ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $BOOLEAN_T)) (i32.eq ($VAL0 $ast) 1))) ) (func $false_Q (param $args i32) (result i32) - (local $ast i32) - (set_local $ast ($MEM_VAL1_ptr $args)) + (LET $ast ($MEM_VAL1_ptr $args)) ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $BOOLEAN_T)) (i32.eq ($VAL0 $ast) 0))) ) @@ -73,16 +71,14 @@ ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $INTEGER_T)))) (func $string_Q (param $args i32) (result i32) - (local $mv i32) - (set_local $mv ($MEM_VAL1_ptr $args)) + (LET $mv ($MEM_VAL1_ptr $args)) ($TRUE_FALSE (AND (i32.eq ($TYPE $mv) (get_global $STRING_T)) (i32.ne (i32.load8_u ($to_String $mv)) (CHR "\x7f")))) ) (func $keyword (param $args i32) (result i32) - (local $str i32) - (set_local $str ($to_String ($MEM_VAL1_ptr $args))) + (LET $str ($to_String ($MEM_VAL1_ptr $args))) (if i32 (i32.eq (i32.load8_u $str) (CHR "\x7f")) (then ($INC_REF ($MEM_VAL1_ptr $args))) (else @@ -91,15 +87,13 @@ ) (func $keyword_Q (param $args i32) (result i32) - (local $ast i32) - (set_local $ast ($MEM_VAL1_ptr $args)) + (LET $ast ($MEM_VAL1_ptr $args)) ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $STRING_T)) (i32.eq (i32.load8_u ($to_String $ast)) (CHR "\x7f")))) ) (func $fn_Q (param $args i32) (result i32) - (local $type i32) - (set_local $type ($TYPE ($MEM_VAL1_ptr $args))) + (LET $type ($TYPE ($MEM_VAL1_ptr $args))) ($TRUE_FALSE (OR (i32.eq $type (get_global $FUNCTION_T)) (i32.eq $type (get_global $MALFUNC_T))))) (func $macro_Q (param $args i32) (result i32) @@ -118,23 +112,21 @@ (func $str (param $args i32) (result i32) ($pr_str_seq $args 0 "")) (func $prn (param $args i32) (result i32) - (local $res i32) - (set_local $res ($pr_str_seq $args 1 " ")) + (LET $res ($pr_str_seq $args 1 " ")) ($printf_1 "%s\n" ($to_String $res)) ($RELEASE $res) ($INC_REF (get_global $NIL)) ) (func $println (param $args i32) (result i32) - (local $res i32) - (set_local $res ($pr_str_seq $args 0 " ")) + (LET $res ($pr_str_seq $args 0 " ")) ($printf_1 "%s\n" ($to_String $res)) ($RELEASE $res) ($INC_REF (get_global $NIL)) ) (func $core_readline (param $args i32) (result i32) - (local $line i32 $mv i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $mv 0) (if (i32.eqz ($readline ($to_String ($MEM_VAL1_ptr $args)) $line)) (return ($INC_REF (get_global $NIL)))) (set_local $mv ($STRING (get_global $STRING_T) $line)) @@ -145,10 +137,9 @@ ($read_str ($to_String ($MEM_VAL1_ptr $args)))) (func $slurp (param $args i32) (result i32) - (local $mv i32 $size i32) - (set_local $mv ($STRING_INIT (get_global $STRING_T))) - (set_local $size ($read_file ($to_String ($MEM_VAL1_ptr $args)) - ($to_String $mv))) + (LET $mv ($STRING_INIT (get_global $STRING_T)) + $size ($read_file ($to_String ($MEM_VAL1_ptr $args)) + ($to_String $mv))) (if (i32.eqz $size) (then ($THROW_STR_1 "failed to read file '%s'" ($to_String ($MEM_VAL1_ptr $args))) @@ -210,22 +201,20 @@ (get_global $VECTOR_T)))) (func $hash_map (param $args i32) (result i32) - (local $res i32 $type i32 $val2 i32 $val3 i32 $c i32) - (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP stack - (set_local $type (get_global $HASHMAP_T)) - - ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (LET $type (get_global $HASHMAP_T) + $res ($MAP_LOOP_START $type) + $val2 0 + $val3 0 + $c 0 + ;; push MAP_LOOP stack + $ret $res + $current $res + $empty $res) ;; READ_SEQ_LOOP (block $done (loop $loop - (if (i32.eqz ($VAL0 $args)) (br $done)) + (br_if $done (i32.eqz ($VAL0 $args))) (set_local $val2 ($INC_REF ($MEM_VAL1_ptr $args))) (set_local $val3 ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) @@ -256,15 +245,15 @@ (get_global $HASHMAP_T)))) (func $assoc (param $args i32) (result i32) - (local $hm i32 $key i32) - (set_local $hm ($MEM_VAL1_ptr $args)) + (LET $hm ($MEM_VAL1_ptr $args) + $key 0) (set_local $args ($MEM_VAL0_ptr $args)) + (drop ($INC_REF $hm)) (block $done (loop $loop - (if (OR (i32.eqz ($VAL0 $args)) - (i32.eqz ($VAL0 ($MEM_VAL0_ptr $args)))) - (br $done)) + (br_if $done (OR (i32.eqz ($VAL0 $args)) + (i32.eqz ($VAL0 ($MEM_VAL0_ptr $args))))) (set_local $hm ($ASSOC1 $hm ($MEM_VAL1_ptr $args) ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) (set_local $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) @@ -276,18 +265,16 @@ ) (func $get (param $args i32) (result i32) - (local $hm i32 $key i32) - (set_local $hm ($MEM_VAL1_ptr $args)) - (set_local $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + (LET $hm ($MEM_VAL1_ptr $args) + $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) (if i32 (i32.eq $hm (get_global $NIL)) (then ($INC_REF (get_global $NIL))) (else ($INC_REF (i32.wrap/i64 ($HASHMAP_GET $hm $key))))) ) (func $contains_Q (param $args i32) (result i32) - (local $hm i32 $key i32) - (set_local $hm ($MEM_VAL1_ptr $args)) - (set_local $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + (LET $hm ($MEM_VAL1_ptr $args) + $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ($TRUE_FALSE (if i32 (i32.eq $hm (get_global $NIL)) (then 0) @@ -296,20 +283,16 @@ ) (func $keys_or_vals (param $hm i32 $keys i32) (result i32) - (local $res i32 $val2 i32) - (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP stack - - ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (LET $res ($MAP_LOOP_START (get_global $LIST_T)) + $val2 0 + ;; MAP_LOOP stack + $ret $res + $current $res + $empty $res) (block $done (loop $loop - (if (i32.eqz ($VAL0 $hm)) (br $done)) + (br_if $done (i32.eqz ($VAL0 $hm))) (if $keys (then (set_local $val2 ($INC_REF ($MEM_VAL1_ptr $hm)))) @@ -354,15 +337,15 @@ ($LIST ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) ($MEM_VAL1_ptr $args))) (func $concat (param $args i32) (result i32) - (local $res i32 $current i32 $sl i32 $last i32 $last_sl i64 $arg i32) - (set_local $res ($INC_REF (get_global $EMPTY_LIST))) - (set_local $current $res) - (set_local $sl 0) - (set_local $last 0) + (local $last_sl i64) + (LET $res ($INC_REF (get_global $EMPTY_LIST)) + $current $res + $sl 0 + $last 0 + $arg 0) (block $done (loop $loop - (if (i32.le_u $args (get_global $EMPTY_HASHMAP)) - (br $done)) + (br_if $done (i32.le_u $args (get_global $EMPTY_HASHMAP))) (set_local $arg ($MEM_VAL1_ptr $args)) ;; skip empty elements (if (i32.le_s $arg (get_global $EMPTY_HASHMAP)) @@ -392,15 +375,13 @@ ) (func $nth (param $args i32) (result i32) - (local $a i32 $idx i32 $i i32) - (set_local $a ($MEM_VAL1_ptr $args)) - (set_local $idx ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + (LET $a ($MEM_VAL1_ptr $args) + $idx ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + $i 0) - (set_local $i 0) (block $done (loop $loop - (if (OR (i32.ge_s $i $idx) (i32.eqz ($VAL0 $a))) - (br $done)) + (br_if $done (OR (i32.ge_s $i $idx) (i32.eqz ($VAL0 $a)))) (set_local $i (i32.add $i 1)) (set_local $a ($MEM_VAL0_ptr $a)) (br $loop) @@ -415,9 +396,8 @@ ) (func $first (param $args i32) (result i32) - (local $res i32 $a i32) - (set_local $res (get_global $NIL)) - (set_local $a ($MEM_VAL1_ptr $args)) + (LET $res (get_global $NIL) + $a ($MEM_VAL1_ptr $args)) (if (AND (i32.ne $a (get_global $NIL)) (i32.ne ($VAL0 $a) 0)) (set_local $res ($MEM_VAL1_ptr $a))) @@ -425,8 +405,7 @@ ) (func $rest (param $args i32) (result i32) - (local $a i32) - (set_local $a ($MEM_VAL1_ptr $args)) + (LET $a ($MEM_VAL1_ptr $args)) (if (i32.eq $a (get_global $NIL)) (return ($INC_REF (get_global $EMPTY_LIST)))) (if (i32.ne ($VAL0 $a) 0) @@ -443,12 +422,13 @@ ($INTEGER ($COUNT ($MEM_VAL1_ptr $args)))) (func $apply (param $args i32) (result i32) - (local $f i32 $f_args i32 $rest_args i32 $rest_count i32) - (local $last_sl i64 $last i32 $res i32) - - (set_local $f ($MEM_VAL1_ptr $args)) - (set_local $rest_args ($MEM_VAL0_ptr $args)) - (set_local $rest_count ($COUNT $rest_args)) + (local $last_sl i64) + (LET $f ($MEM_VAL1_ptr $args) + $f_args 0 + $rest_args ($MEM_VAL0_ptr $args) + $rest_count ($COUNT $rest_args) + $last 0 + $res 0) (if (i32.le_s $rest_count 1) (then @@ -482,23 +462,18 @@ ) (func $map (param $args i32) (result i32) - (local $f i32 $rest_args i32 $f_args i32 $res i32) - (local $ret i32 $empty i32 $current i32) ;; MAP_LOOP stack - - (set_local $f ($MEM_VAL1_ptr $args)) - (set_local $rest_args ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - - ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (LET $f ($MEM_VAL1_ptr $args) + $rest_args ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) + $f_args 0 + $res ($MAP_LOOP_START (get_global $LIST_T)) + ;; push MAP_LOOP stack + $ret $res + $current $res + $empty $res) (block $done (loop $loop - (if (i32.eqz ($VAL1 $rest_args)) (br $done)) + (br_if $done (i32.eqz ($VAL1 $rest_args))) ;; create argument list for apply (set_local $f_args ($ALLOC (get_global $LIST_T) @@ -539,9 +514,8 @@ ;;; (func $with_meta (param $args i32) (result i32) - (local $mv i32 $meta i32) - (set_local $mv ($MEM_VAL1_ptr $args)) - (set_local $meta ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + (LET $mv ($MEM_VAL1_ptr $args) + $meta ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ;; remove existing metadata first ($ALLOC (get_global $METADATA_T) ($DEREF_META $mv) $meta 0) ) @@ -572,21 +546,19 @@ (func $reset_BANG (param $args i32) (result i32) (local $atom i32 $val i32) - (set_local $atom ($MEM_VAL1_ptr $args)) - (set_local $val ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + (LET $atom ($MEM_VAL1_ptr $args) + $val ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ($_reset_BANG $atom $val) ) (func $swap_BANG (param $args i32) (result i32) - (local $atom i32 $f_args i32 $s_args i32 $rest_args i32 $f i32 $res i32) - (set_local $atom ($MEM_VAL1_ptr $args)) - (set_local $f_args ($MEM_VAL0_ptr $args)) - (set_local $rest_args ($MEM_VAL0_ptr $f_args)) - (set_local $f ($MEM_VAL1_ptr $f_args)) - (set_local $res 0) - ;; add atom value to front of the args list - (set_local $s_args ($LIST $rest_args ($MEM_VAL0_ptr $atom))) ;; cons - (set_local $res ($APPLY $f $s_args)) + (LET $atom ($MEM_VAL1_ptr $args) + $f_args ($MEM_VAL0_ptr $args) + $rest_args ($MEM_VAL0_ptr $f_args) + ;; add atom value to front of the args list + $s_args ($LIST $rest_args ($MEM_VAL0_ptr $atom)) ;; cons + $f ($MEM_VAL1_ptr $f_args) + $res ($APPLY $f $s_args)) ;; release args ($RELEASE $s_args) ;; use reset to update the value diff --git a/wasm/debug.wam b/wasm/debug.wam index b998b9614b..6afbd5bedb 100644 --- a/wasm/debug.wam +++ b/wasm/debug.wam @@ -6,20 +6,18 @@ ) (func $CHECK_FREE_LIST (result i32) - (local $first i32 $count i32) - (set_local $first (i32.add - (get_global $mem) - (i32.mul_u (get_global $mem_free_list) - 4))) - (set_local $count 0) + (LET $first (i32.add + (get_global $mem) + (i32.mul_u (get_global $mem_free_list) 4)) + $count 0) (block $done (loop $loop - (if (i32.ge_s $first (i32.add - (get_global $mem) - (i32.mul_u (get_global $mem_unused_start) - 4))) - (br $done)) + (br_if $done + (i32.ge_s $first + (i32.add (get_global $mem) + (i32.mul_u (get_global $mem_unused_start) + 4)))) (set_local $count (i32.add $count ($MalVal_size $first))) (set_local $first (i32.add (get_global $mem) (i32.mul_u 4 ($VAL0 $first)))) (br $loop) @@ -29,20 +27,18 @@ ) (func $PR_MEMORY_SUMMARY_SMALL - (local $free i32 $free_list_count i32 $mv i32 $mem_ref_count i32) + (LET $free (i32.sub_s (get_global $MEM_SIZE) + (i32.mul_u (get_global $mem_unused_start) 4)) + $free_list_count ($CHECK_FREE_LIST) + $mv (get_global $NIL) + $mem_ref_count 0) - (set_local $free (i32.sub_s (get_global $MEM_SIZE) - (i32.mul_u (get_global $mem_unused_start) 4))) - (set_local $free_list_count ($CHECK_FREE_LIST)) - (set_local $mem_ref_count 0) - - (set_local $mv (get_global $NIL)) (block $done (loop $loop - (if (i32.ge_s $mv (i32.add - (get_global $mem) - (i32.mul_u (get_global $mem_unused_start) 4))) - (br $done)) + (br_if $done (i32.ge_s $mv (i32.add + (get_global $mem) + (i32.mul_u (get_global $mem_unused_start) + 4)))) (if (i32.ne ($TYPE $mv) (get_global $FREE_T)) (set_local $mem_ref_count (i32.add $mem_ref_count (i32.shr_u @@ -62,7 +58,7 @@ (set_local $mv (get_global $NIL)) (block $done (loop $loop - (if (i32.gt_s $mv (get_global $TRUE)) (br $done)) + (br_if $done (i32.gt_s $mv (get_global $TRUE))) ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) (set_local $mv (i32.add $mv 8)) (br $loop) @@ -71,7 +67,7 @@ (set_local $mv (get_global $EMPTY_LIST)) (block $done (loop $loop - (if (i32.gt_s $mv (get_global $EMPTY_HASHMAP)) (br $done)) + (br_if $done (i32.gt_s $mv (get_global $EMPTY_HASHMAP))) ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) (set_local $mv (i32.add $mv 12)) (br $loop) @@ -81,19 +77,17 @@ ) (func $PR_VALUE (param $fmt i32 $mv i32) - (local $temp i32) - (set_local $temp ($pr_str $mv 1)) + (LET $temp ($pr_str $mv 1)) ($printf_1 $fmt ($to_String $temp)) ($RELEASE $temp) ) (func $PR_MEMORY_VALUE (param $idx i32) (result i32) - (local $mv i32 $type i32 $size i32 $val0 i32) ;;; mv = mem + idx - (set_local $mv ($MalVal_ptr $idx)) - (set_local $type ($TYPE $mv)) - (set_local $size ($MalVal_size $mv)) - (set_local $val0 ($MalVal_val $idx 0)) + (LET $mv ($MalVal_ptr $idx) + $type ($TYPE $mv) + $size ($MalVal_size $mv) + $val0 ($MalVal_val $idx 0)) ($printf_2 "%4d: type %2d" $idx $type) @@ -213,7 +207,8 @@ ) (func $PR_STRINGS (param $start i32) - (local $ms i32 $idx i32) + (LET $ms 0 + $idx 0) ($printf_2 "String - showing %d -> %d:\n" $start (i32.sub_s (get_global $string_mem_next) (get_global $string_mem))) @@ -225,8 +220,7 @@ (set_local $ms (get_global $string_mem)) (block $done (loop $loop - (if (i32.ge_u $ms (get_global $string_mem_next)) - (br $done)) + (br_if $done (i32.ge_u $ms (get_global $string_mem_next))) (set_local $idx (i32.sub_u $ms (get_global $string_mem))) (if (i32.ge_s $idx $start) ($printf_4 "%4d: refs %2d, size %2d >> '%s'\n" @@ -242,7 +236,8 @@ ) (func $PR_MEMORY (param $start i32 $end i32) - (local $string_start i32 $idx i32) + (LET $string_start 0 + $idx 0) (if (i32.lt_s $start 0) (then (set_local $start (get_global $mem_user_start)) @@ -268,8 +263,7 @@ ;;; while (idx < end) (block $loopvals_exit (loop $loopvals - (if (i32.ge_s $idx $end) - (br $loopvals_exit)) + (br_if $loopvals_exit (i32.ge_s $idx $end)) (set_local $idx ($PR_MEMORY_VALUE $idx)) (br $loopvals) ) @@ -281,7 +275,7 @@ (func $PR_MEMORY_RAW (param $start i32 $end i32) (block $loop_exit (loop $loop - (if (i32.ge_u $start $end) (br $loop_exit)) + (br_if $loop_exit (i32.ge_u $start $end)) ($printf_2 "0x%x 0x%x\n" $start (i32.load $start)) (set_local $start (i32.add 4 $start)) (br $loop) diff --git a/wasm/env.wam b/wasm/env.wam index 64e7dd9b13..6515375dca 100644 --- a/wasm/env.wam +++ b/wasm/env.wam @@ -3,23 +3,21 @@ (func $ENV_NEW (param $outer i32) (result i32) (local $data i32 $env i32) - ;; allocate the data hashmap - (set_local $data ($HASHMAP)) - - (set_local $env ($ALLOC (get_global $ENVIRONMENT_T) $data $outer 0)) + (LET $data ($HASHMAP) ;; allocate the data hashmap + $env ($ALLOC (get_global $ENVIRONMENT_T) $data $outer 0)) ;; environment takes ownership ($RELEASE $data) $env ) (func $ENV_NEW_BINDS (param $outer i32 $binds i32 $exprs i32) (result i32) - (local $env i32 $key i32) - (set_local $env ($ENV_NEW $outer)) + (LET $env ($ENV_NEW $outer) + $key 0) ;; process bindings (block $done (loop $loop - (if (i32.eqz ($VAL0 $binds)) (br $done)) + (br_if $done (i32.eqz ($VAL0 $binds))) ;; get/deref the key from binds (set_local $key ($MEM_VAL1_ptr $binds)) @@ -51,29 +49,26 @@ ) (func $ENV_SET (param $env i32 $key i32 $value i32) (result i32) - (local $data i32) - (set_local $data ($MEM_VAL0_ptr $env)) + (LET $data ($MEM_VAL0_ptr $env)) (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1 $data $key $value))) $value ) (func $ENV_SET_S (param $env i32 $key i32 $value i32) (result i32) - (local $data i32) - (set_local $data ($MEM_VAL0_ptr $env)) + (LET $data ($MEM_VAL0_ptr $env)) (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1_S $data $key $value))) $value ) (func $ENV_FIND (param $env i32 $key i32) (result i64) - (local $res i32 $data i32 $found_res i64) - - (set_local $res 0) + (local $found_res i64) + (LET $res 0 + $data 0) (block $done (loop $loop (set_local $data ($MEM_VAL0_ptr $env)) - (set_local $found_res ($HASHMAP_GET $data - $key)) + (set_local $found_res ($HASHMAP_GET $data $key)) ;;; if (found) (if (i32.wrap/i64 (i64.shr_u $found_res (i64.const 32))) (then @@ -95,8 +90,8 @@ ) (func $ENV_GET (param $env i32 $key i32) (result i32) - (local $res i32 $res_env i64) - (set_local $res 0) + (local $res_env i64) + (LET $res 0) (set_local $res_env ($ENV_FIND $env $key)) (set_local $env (i32.wrap/i64 $res_env)) diff --git a/wasm/mem.wam b/wasm/mem.wam index 8a416ee2bd..67d0dc3325 100644 --- a/wasm/mem.wam +++ b/wasm/mem.wam @@ -98,8 +98,7 @@ (else 3))))) (func $MalVal_size (param $mv i32) (result i32) - (local $type i32) - (set_local $type ($TYPE $mv)) + (LET $type ($TYPE $mv)) ;; if (type == FREE_T) (if i32 (i32.eq $type (get_global $FREE_T)) (then @@ -113,7 +112,7 @@ ;; init_memory (func $init_memory - (local $heap_size i32) + (LET $heap_size 0) ;; ($print ">>> init_memory\n") @@ -170,10 +169,9 @@ (func $ALLOC_INTERNAL (param $type i32 $val1 i32 $val2 i32 $val3 i32) (result i32) - (local $prev i32 $res i32 $size i32) - (set_local $prev (get_global $mem_free_list)) - (set_local $res (get_global $mem_free_list)) - (set_local $size ($MalType_size $type)) + (LET $prev (get_global $mem_free_list) + $res (get_global $mem_free_list) + $size ($MalType_size $type)) (block $loop_done (loop $loop @@ -267,7 +265,7 @@ ) (func $RELEASE (param $mv i32) - (local $idx i32 $type i32 $size i32) + (LET $idx 0 $type 0 $size 0) ;; Ignore NULLs ;;; if (mv == NULL) { return; } @@ -373,8 +371,7 @@ ;; find string in string memory or 0 if not found (func $FIND_STRING (param $str i32) (result i32) - (local $ms i32) - (set_local $ms (get_global $string_mem)) + (LET $ms (get_global $string_mem)) (block $done (loop $loop (br_if $done (i32.ge_s $ms (get_global $string_mem_next))) @@ -392,7 +389,7 @@ ;; size is number of characters in the string not including the ;; trailing NULL (func $ALLOC_STRING (param $str i32 $size i32 $intern i32) (result i32) - (local $ms i32) + (LET $ms 0) ;; search for matching string in string_mem (if $intern @@ -420,7 +417,7 @@ ) (func $RELEASE_STRING (param $ms i32) - (local $size i32 $next i32 $ms_idx i32 $idx i32 $type i32 $mv i32) + (LET $size 0 $next 0 $ms_idx 0 $idx 0 $type 0 $mv 0) (if (i32.le_s (i32.load16_u $ms) 0) (then diff --git a/wasm/platform_libc.wam b/wasm/platform_libc.wam index c561d64952..7965b6ca58 100644 --- a/wasm/platform_libc.wam +++ b/wasm/platform_libc.wam @@ -37,10 +37,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $readline (param $prompt i32 $buf i32) (result i32) - (local $line i32 $len i32) - (set_local $len 0) + (LET $line ($lib_readline $prompt) + $len 0) - (set_local $line ($lib_readline $prompt)) (if $line (then ($lib_add_history $line) @@ -55,10 +54,11 @@ ;; Returns malloc'd string. Must be free by caller (func $read_file (param $path i32 $buf i32) (result i32) - (local $fst i32 $fd i32 $st_size i32 $sz i32) - (set_local $fst (STATIC_ARRAY 100)) ;; at least STAT_SIZE + (LET $fst (STATIC_ARRAY 100) ;; at least STAT_SIZE + $fd ($lib_open $path (get_global $O_RDONLY) 0) + $st_size 0 + $sz 0) - (set_local $fd ($lib_open $path (get_global $O_RDONLY) 0)) (if (i32.lt_s $fd 0) (then ($printf_1 "ERROR: slurp failed to open '%s'\n" $path) @@ -83,8 +83,10 @@ (func $get_time_ms (result i32) - (local $tv i32 $secs i32 $usecs i32 $msecs i32) - (set_local $tv (STATIC_ARRAY 10)) ;; at least TIMEVAL_SIZE + (LET $tv (STATIC_ARRAY 10) ;; at least TIMEVAL_SIZE + $secs 0 + $usecs 0 + $msecs 0) (drop ($lib_gettimeofday $tv 0)) (set_local $secs (i32.load (i32.add $tv (get_global $TV_SEC_OFFSET)))) ;; subtract 30 years to make sure secs is positive and can be diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index f7e0ec029a..4c67a44b8b 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -25,10 +25,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $readline (param $prompt i32 $buf i32) (result i32) - (local $res i32) - ;; TODO: don't hardcode count to 200 - (set_local $res ($lib_readline $prompt $buf 200)) + (LET $res ($lib_readline $prompt $buf 200)) (if $res ($lib_add_history $buf)) $res @@ -37,8 +35,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $read_file (param $path i32 $buf i32) (result i32) - (local $size i32) - (set_local $size ($lib_read_file $path $buf)) + (LET $size ($lib_read_file $path $buf)) ;; Add null to string (i32.store8_u (i32.add $buf $size) 0) (i32.add $size 1) diff --git a/wasm/printer.wam b/wasm/printer.wam index 34cba901e5..ebcddfd924 100644 --- a/wasm/printer.wam +++ b/wasm/printer.wam @@ -3,9 +3,9 @@ (global $printer_buf (mut i32) 0) (func $pr_str_val (param $res i32 $mv i32 $print_readably i32) (result i32) - (local $type i32 $val0 i32 $sval i32) - (set_local $type ($TYPE $mv)) - (set_local $val0 ($VAL0 $mv)) + (LET $type ($TYPE $mv) + $val0 ($VAL0 $mv) + $sval 0) ;;; switch(type) (block $done @@ -70,8 +70,7 @@ ;;; while (VAL0(mv) != 0) (block $done_seq (loop $seq_loop - (if (i32.eq ($VAL0 $mv) 0) - (br $done_seq)) + (br_if $done_seq (i32.eq ($VAL0 $mv) 0)) ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) @@ -147,9 +146,8 @@ (func $pr_str_internal (param $seq i32) (param $mv i32) (param $print_readably i32) (param $sep i32) (result i32) - (local $res i32 $res_str i32) - (set_local $res ($STRING_INIT (get_global $STRING_T))) - (set_local $res_str ($to_String $res)) + (LET $res ($STRING_INIT (get_global $STRING_T)) + $res_str ($to_String $res)) (if $seq (then diff --git a/wasm/printf.wam b/wasm/printf.wam index 68ca24ca43..ea6a64a057 100644 --- a/wasm/printf.wam +++ b/wasm/printf.wam @@ -49,18 +49,16 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) - (local $n i32 $ch i32) - (set_local $n (i32.rem_u $num $base)) - (set_local $ch (if (result i32) (i32.lt_u $n 10) 48 55)) + (LET $n (i32.rem_u $num $base) + $ch (if (result i32) (i32.lt_u $n 10) 48 55)) (i32.store8_u $str (i32.add $n $ch)) ) ;; TODO: add max buf length (i.e. snprintnum) (func $_sprintnum (param $buf i32) (param $val i32) (param $radix i32) (param $pad_cnt i32) (param $pad_char i32) (result i32) - (local $pbuf i32 $i i32 $j i32 $k i32 $len i32 $neg i32 $digit i32) - (set_local $pbuf $buf) - (set_local $neg 0) + (LET $pbuf $buf + $neg 0 $i 0 $j 0 $k 0 $len 0 $digit 0) (if (AND (i32.lt_s $val 0) (i32.eq $radix 10)) (then @@ -75,13 +73,13 @@ (i32.sub_u (i32.add (CHR "A") $digit) 10))) (set_local $pbuf (i32.add $pbuf 1)) (set_local $val (i32.div_u $val $radix)) - (if (i32.gt_u $val 0) (br $loop)) + (br_if $loop (i32.gt_u $val 0)) ) (set_local $i (i32.sub_u $pbuf $buf)) (block $done (loop $loop - (if (i32.ge_u $i $pad_cnt) (br $done)) + (br_if $done (i32.ge_u $i $pad_cnt)) (i32.store8_u $pbuf $pad_char) (set_local $pbuf (i32.add $pbuf 1)) (set_local $i (i32.add $i 1)) @@ -101,8 +99,7 @@ (set_local $i 0) (block $done (loop $loop - (if (i32.ge_u $i (i32.div_u $len 2)) - (br $done)) + (br_if $done (i32.ge_u $i (i32.div_u $len 2))) (set_local $j (i32.load8_u (i32.add $buf $i))) (set_local $k (i32.add $buf (i32.sub_u (i32.sub_u $len $i) 1))) @@ -126,10 +123,8 @@ (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) (param $v5 i32) (result i32) - (local $ch i32 $pstr i32 $v i32 $vidx i32 $len i32) - (local $pad_cnt i32 $pad_char i32) - (set_local $pstr $str) - (set_local $vidx 0) + (LET $pstr $str + $vidx 0 $ch 0 $v 0 $len 0 $pad_cnt 0 $pad_char 0) (block $done (loop $loop @@ -148,7 +143,7 @@ ;;; while ((ch=*(fmt++))) (set_local $ch (i32.load8_u $fmt)) (set_local $fmt (i32.add 1 $fmt)) - (if (i32.eqz $ch) (br $done)) + (br_if $done (i32.eqz $ch)) ;; TODO: check buffer length (if (i32.ne $ch (CHR "%")) @@ -161,7 +156,7 @@ ;;; ch=*(fmt++) (set_local $ch (i32.load8_u $fmt)) (set_local $fmt (i32.add 1 $fmt)) - (if (i32.eqz $ch) (br $done)) + (br_if $done (i32.eqz $ch)) (set_local $pad_cnt 0) (set_local $pad_char (CHR " ")) @@ -175,15 +170,15 @@ ;;; ch=*(fmt++) (set_local $ch (i32.load8_u $fmt)) (set_local $fmt (i32.add 1 $fmt)) - (if (i32.eqz $ch) (br $done)))) + (br_if $done (i32.eqz $ch)))) (loop $loop (set_local $pad_cnt (i32.mul_s $pad_cnt 10)) (set_local $pad_cnt (i32.add $pad_cnt (i32.sub_s $ch (CHR "0")))) (set_local $ch (i32.load8_u $fmt)) (set_local $fmt (i32.add 1 $fmt)) - (if (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9"))) - (br $loop)) + (br_if $loop (AND (i32.ge_s $ch (CHR "0")) + (i32.le_s $ch (CHR "9")))) ))) (if (i32.eq (CHR "d") $ch) @@ -197,8 +192,7 @@ (set_local $len ($strlen $v)) (block $done (loop $loop - (if (i32.le_s $pad_cnt $len) - (br $done)) + (br_if $done (i32.le_s $pad_cnt $len)) (i32.store8_u $pstr (CHR " ")) (set_local $pstr (i32.add $pstr 1)) (set_local $pad_cnt (i32.sub_s $pad_cnt 1)) diff --git a/wasm/reader.wam b/wasm/reader.wam index 05890c7051..0894928b50 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -5,16 +5,14 @@ (global $read_index (mut i32) 0) (func $skip_spaces (param $str i32) (result i32) - (local $found i32 $c i32) - (set_local $found 0) - (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (LET $found 0 + $c (i32.load8_u (i32.add $str (get_global $read_index)))) (block $done (loop $loop ;;; while (c == ' ' || c == ',' || c == '\n') - (if (AND (i32.ne $c (CHR " ")) - (i32.ne $c (CHR ",")) - (i32.ne $c (CHR "\n"))) - (br $done)) + (br_if $done (AND (i32.ne $c (CHR " ")) + (i32.ne $c (CHR ",")) + (i32.ne $c (CHR "\n")))) (set_local $found 1) ;;; c=str[++(*index)] (set_global $read_index (i32.add (get_global $read_index) 1)) @@ -27,9 +25,8 @@ ) (func $skip_to_eol (param $str i32) (result i32) - (local $found i32 $c i32) - (set_local $found 0) - (set_local $c (i32.load8_c (i32.add $str (get_global $read_index)))) + (LET $found 0 + $c (i32.load8_c (i32.add $str (get_global $read_index)))) (if (i32.eq $c (CHR ";")) (then (set_local $found 1) @@ -40,9 +37,8 @@ (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) ;;; while (c != '\0' && c != '\n') - (if (AND (i32.ne $c (CHR "\x00")) - (i32.ne $c (CHR "\n"))) - (br $loop)) + (br_if $loop (AND (i32.ne $c (CHR "\x00")) + (i32.ne $c (CHR "\n")))) ) ))) ;; ($debug ">>> skip_to_eol:" $found) @@ -52,17 +48,17 @@ (func $skip_spaces_comments (param $str i32) (loop $loop ;; skip spaces - (if ($skip_spaces $str) (br $loop)) + (br_if $loop ($skip_spaces $str)) ;; skip comments - (if ($skip_to_eol $str) (br $loop)) + (br_if $loop ($skip_to_eol $str)) ) ) (func $read_token (param $str i32) (result i32) - (local $token_index i32 $instring i32 $escaped i32 $c i32) - (set_local $token_index 0) - (set_local $instring 0) - (set_local $escaped 0) + (LET $token_index 0 + $instring 0 + $escaped 0 + $c 0) ($skip_spaces_comments $str) @@ -101,21 +97,20 @@ (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) ;;; if (c == '\0') break - (if (i32.eq $c 0) (br $done)) + (br_if $done (i32.eq $c 0)) ;;; if (!instring) (if (i32.eqz $instring) (then ;; next character is token delimiter - (if (OR (i32.eq $c (CHR "(")) - (i32.eq $c (CHR ")")) - (i32.eq $c (CHR "[")) - (i32.eq $c (CHR "]")) - (i32.eq $c (CHR "{")) - (i32.eq $c (CHR "}")) - (i32.eq $c (CHR " ")) - (i32.eq $c (CHR ",")) - (i32.eq $c (CHR "\n"))) - (br $done)))) + (br_if $done (OR (i32.eq $c (CHR "(")) + (i32.eq $c (CHR ")")) + (i32.eq $c (CHR "[")) + (i32.eq $c (CHR "]")) + (i32.eq $c (CHR "{")) + (i32.eq $c (CHR "}")) + (i32.eq $c (CHR " ")) + (i32.eq $c (CHR ",")) + (i32.eq $c (CHR "\n")))))) ;; read next character ;;; token[token_index++] = str[(*index)++] (i32.store8_u (i32.add (get_global $token_buf) $token_index) @@ -124,11 +119,12 @@ (set_local $token_index (i32.add $token_index 1)) (set_global $read_index (i32.add (get_global $read_index) 1)) ;;; if (token[0] == '~' && token[1] == '@') break - (if (AND (i32.eq (i32.load8_u (i32.add (get_global $token_buf) 0)) - (CHR "~")) - (i32.eq (i32.load8_u (i32.add (get_global $token_buf) 1)) - (CHR "@"))) - (br $done)) + (br_if $done (AND (i32.eq (i32.load8_u + (i32.add (get_global $token_buf) 0)) + (CHR "~")) + (i32.eq (i32.load8_u + (i32.add (get_global $token_buf) 1)) + (CHR "@")))) ;;; if ((!instring) || escaped) (if (OR (i32.eqz $instring) $escaped) @@ -137,8 +133,7 @@ (br $loop))) (if (i32.eq $c (CHR "\\")) (set_local $escaped 1)) - (if (i32.eq $c (CHR "\"")) - (br $done)) + (br_if $done (i32.eq $c (CHR "\""))) (br $loop) ) ))) @@ -149,18 +144,14 @@ ) (func $read_seq (param $str i32 $type i32 $end i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $c i32) - - ;; MAP_LOOP stack - (local $ret i32 $empty i32 $current i32) - - ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (LET $res ($MAP_LOOP_START $type) + $val2 0 + $val3 0 + $c 0 + ;; MAP_LOOP stack + $ret $res + $empty $res + $current $res) ;; READ_SEQ_LOOP (block $done @@ -213,10 +204,10 @@ ) (func $read_macro (param $str i32 $sym i32 $with_meta i32) (result i32) - (local $first i32 $second i32 $third i32 $res i32) - (set_local $first ($STRING (get_global $SYMBOL_T) $sym)) - (set_local $second ($read_form $str)) - (set_local $res $second) + (LET $first ($STRING (get_global $SYMBOL_T) $sym) + $second ($read_form $str) + $third 0 + $res $second) (if (get_global $error_type) (return $res)) (if (i32.eqz $with_meta) (then @@ -233,7 +224,7 @@ ) (func $read_form (param $str i32) (result i32) - (local $tok i32 $c0 i32 $c1 i32 $res i32 $slen i32) + (LET $tok 0 $c0 0 $c1 0 $res 0 $slen 0) (if (get_global $error_type) (return 0)) diff --git a/wasm/step0_repl.wam b/wasm/step0_repl.wam index 167c773335..dd7658495b 100644 --- a/wasm/step0_repl.wam +++ b/wasm/step0_repl.wam @@ -21,8 +21,7 @@ (func $main (result i32) ;; Constant location/value definitions - (local $line i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201)) ;; DEBUG ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) @@ -32,7 +31,6 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - ;;($printf_1 "here1 %d\n", 7); ($printf_1 "%s\n" ($rep $line)) (br $repl_loop) ) diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam index d9ef2b85ef..8b5e5d60b1 100644 --- a/wasm/step1_read_print.wam +++ b/wasm/step1_read_print.wam @@ -17,17 +17,16 @@ ;; REPL (func $REP (param $line i32 $env i32) (result i32) - (local $mv1 i32 $mv2 i32 $ms i32) - (block $rep_done + (LET $mv1 0 $mv2 0 $ms 0) + (block $done (set_local $mv1 ($READ $line)) - (br_if $rep_done (get_global $error_type)) + (br_if $done (get_global $error_type)) (set_local $mv2 ($EVAL $mv1 $env)) - (br_if $rep_done (get_global $error_type)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) - ) ;; release memory from MAL_READ @@ -36,21 +35,25 @@ ) (func $main (result i32) - (local $line i32 $res i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0) ;; DEBUG - ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) - ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) - ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) - ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) ;; ($PR_MEMORY_RAW ;; (get_global $mem) (i32.add (get_global $mem) ;; (i32.mul_u (get_global $mem_unused_start) 4))) - ($PR_MEMORY -1 -1) + (drop ($STRING (get_global $STRING_T) "uvw")) + (drop ($STRING (get_global $STRING_T) "xyz")) + + ;;($PR_MEMORY -1 -1) ;; Start REPL (block $repl_done diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam index 656dca3bf7..82f772ef5d 100644 --- a/wasm/step2_eval.wam +++ b/wasm/step2_eval.wam @@ -9,9 +9,9 @@ ;; EVAL (func $EVAL_AST (param $ast i32 $env i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) (local $res2 i64) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -46,7 +46,7 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -101,42 +101,41 @@ $add $subtract $multiply $divide)) (func $EVAL (param $ast i32 $env i32) (result i32) - (local $res i32) - (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) + (LET $res 0 + $ftype 0 $f_args 0 $f 0 $args 0) - (set_local $res 0) (set_local $f_args 0) (set_local $f 0) (set_local $args 0) - (set_local $type ($TYPE $ast)) (if (get_global $error_type) (return 0)) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne $type (get_global $LIST_T)) (return ($EVAL_AST $ast $env))) + (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (return ($EVAL_AST $ast $env))) ;; APPLY_LIST - (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) + (if ($EMPTY_Q $ast) + (return ($INC_REF $ast))) ;; EVAL_INVOKE (set_local $res ($EVAL_AST $ast $env)) (set_local $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) (return $f_args)) + (if (get_global $error_type) + (return $f_args)) - ;; rest - (set_local $args ($MEM_VAL0_ptr $f_args)) - ;; value - (set_local $f ($MEM_VAL1_ptr $f_args)) + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value (set_local $ftype ($TYPE $f)) (if (i32.eq $ftype (get_global $FUNCTION_T)) (then (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))) (else - ($THROW_STR_1 "apply of non-function type: %d\n" $type) + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) (set_local $res 0))) ($RELEASE $f_args) @@ -151,13 +150,13 @@ ;; REPL (func $REP (param $line i32 $env i32) (result i32) - (local $mv1 i32 $mv2 i32 $ms i32) - (block $rep_done + (LET $mv1 0 $mv2 0 $ms 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $mv2 ($EVAL $mv1 $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -187,14 +186,15 @@ ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $main (result i32) - (local $line i32 $res i32 $repl_env i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0) ;; DEBUG - ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) - ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) - ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) - ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) (set_global $repl_env ($HASHMAP)) diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam index f089c98c9d..6095459579 100644 --- a/wasm/step3_env.wam +++ b/wasm/step3_env.wam @@ -9,8 +9,8 @@ ;; EVAL (func $EVAL_AST (param $ast i32 $env i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -37,7 +37,7 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -99,12 +99,11 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $ast i32 $env i32) (result i32) - (local $res i32) - (local $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - (local $let_env i32) + (LET $res 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 + $let_env 0) - (set_local $res 0) (set_local $f_args 0) (set_local $f 0) (set_local $args 0) @@ -117,7 +116,8 @@ (return ($EVAL_AST $ast $env))) ;; APPLY_LIST - (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) + (if ($EMPTY_Q $ast) + (return ($INC_REF $ast))) (set_local $a0 ($MEM_VAL1_ptr $ast)) (set_local $a0sym "") @@ -143,13 +143,12 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $let_env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) @@ -170,12 +169,11 @@ (set_local $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) (return $f_args)) + (if (get_global $error_type) + (return $f_args)) - ;; rest - (set_local $args ($MEM_VAL0_ptr $f_args)) - ;; value - (set_local $f ($MEM_VAL1_ptr $f_args)) + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value (set_local $ftype ($TYPE $f)) (if (i32.eq $ftype (get_global $FUNCTION_T)) @@ -197,13 +195,13 @@ ;; REPL (func $REP (param $line i32 $env i32) (result i32) - (local $mv1 i32 $mv2 i32 $ms i32) - (block $rep_done + (LET $mv1 0 $mv2 0 $ms 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $mv2 ($EVAL $mv1 $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -236,14 +234,15 @@ ($INC_REF (get_global $NIL))) (func $main (result i32) - (local $line i32 $res i32 $repl_env i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0) ;; DEBUG - ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) - ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) - ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) - ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) (set_global $repl_env ($ENV_NEW (get_global $NIL))) diff --git a/wasm/step4_if_fn_do.wam b/wasm/step4_if_fn_do.wam index 273ccf7b76..d52da0e6ee 100644 --- a/wasm/step4_if_fn_do.wam +++ b/wasm/step4_if_fn_do.wam @@ -9,8 +9,8 @@ ;; EVAL (func $EVAL_AST (param $ast i32 $env i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -37,7 +37,7 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -93,12 +93,11 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $ast i32 $env i32) (result i32) - (local $res i32 $el i32) - (local $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32 $a3 i32) - (local $let_env i32 $fn_env i32 $a i32) + (LET $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 $a3 0 + $let_env 0 $fn_env 0 $a 0) - (set_local $res 0) (set_local $f_args 0) (set_local $f 0) (set_local $args 0) @@ -138,13 +137,12 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $let_env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) @@ -197,12 +195,11 @@ (set_local $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) (return $f_args)) + (if (get_global $error_type) + (return $f_args)) - ;; rest - (set_local $args ($MEM_VAL0_ptr $f_args)) - ;; value - (set_local $f ($MEM_VAL1_ptr $f_args)) + (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest + (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value (set_local $ftype ($TYPE $f)) (if (i32.eq $ftype (get_global $FUNCTION_T)) @@ -242,10 +239,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -256,10 +253,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -271,14 +268,15 @@ ) (func $main (result i32) - (local $line i32 $res i32 $repl_env i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0) ;; DEBUG - ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) - ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) - ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) - ($printf_1 "mem: 0x%x\n" (get_global $mem)) +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) ;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) (set_global $repl_env ($ENV_NEW (get_global $NIL))) @@ -287,6 +285,8 @@ ;; core.EXT: defined in wasm ($add_core_ns $repl_env) + ($checkpoint_user_memory) + ;; core.mal: defined using the language itself ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam index 2aca251315..161a6c5d78 100644 --- a/wasm/step5_tco.wam +++ b/wasm/step5_tco.wam @@ -9,8 +9,8 @@ ;; EVAL (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -37,10 +37,10 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -96,15 +96,11 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) - (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - - (set_local $ast $orig_ast) - (set_local $env $orig_env) - (set_local $prev_ast 0) - (set_local $prev_env 0) - (set_local $res 0) + (LET $ast $orig_ast + $env $orig_env + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) (block $EVAL_return (loop $TCO_loop @@ -141,7 +137,7 @@ (set_local $a1 ($MAL_GET_A1 $ast)) (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -157,12 +153,11 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) @@ -293,10 +288,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -307,10 +302,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -322,8 +317,8 @@ ) (func $main (result i32) - (local $line i32 $res i32 $repl_env i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam index 33da6cfdff..b41bf4ff16 100644 --- a/wasm/step6_file.wam +++ b/wasm/step6_file.wam @@ -9,8 +9,8 @@ ;; EVAL (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -37,10 +37,10 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -96,15 +96,11 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) - (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - - (set_local $ast $orig_ast) - (set_local $env $orig_env) - (set_local $prev_ast 0) - (set_local $prev_env 0) - (set_local $res 0) + (LET $ast $orig_ast + $env $orig_env + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) (block $EVAL_return (loop $TCO_loop @@ -141,7 +137,7 @@ (set_local $a1 ($MAL_GET_A1 $ast)) (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -157,12 +153,11 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) @@ -298,10 +293,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -312,10 +307,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -327,10 +322,10 @@ ) (func $main (param $argc i32 $argv i32) (result i32) - (local $line i32 $res i32 $repl_env i32) - ;; argument processing - (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -365,7 +360,7 @@ (set_local $i 2) (block $done (loop $loop - (if (i32.ge_u $i $argc) (br $done)) + (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) (i32.load (i32.add $argv (i32.mul_u $i 4))))) diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam index 9a718cc1a9..49859ecfa1 100644 --- a/wasm/step7_quote.wam +++ b/wasm/step7_quote.wam @@ -9,16 +9,14 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) - (local $type i32) - (set_local $type ($TYPE $ast)) + (LET $type ($TYPE $ast)) (AND (OR (i32.eq $type (get_global $LIST_T)) (i32.eq $type (get_global $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) (func $QUASIQUOTE (param $ast i32) (result i32) - (local $sym i32 $res i32 $second i32 $third i32) - (set_local $res 0) + (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) @@ -61,8 +59,8 @@ ) (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -89,10 +87,10 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -148,15 +146,11 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) - (local $type i32 $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - - (set_local $ast $orig_ast) - (set_local $env $orig_env) - (set_local $prev_ast 0) - (set_local $prev_env 0) - (set_local $res 0) + (LET $ast $orig_ast + $env $orig_env + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) (block $EVAL_return (loop $TCO_loop @@ -193,7 +187,7 @@ (set_local $a1 ($MAL_GET_A1 $ast)) (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -209,12 +203,11 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) @@ -362,10 +355,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -376,10 +369,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -391,10 +384,10 @@ ) (func $main (param $argc i32 $argv i32) (result i32) - (local $line i32 $res i32 $repl_env i32) - ;; argument processing - (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -429,7 +422,7 @@ (set_local $i 2) (block $done (loop $loop - (if (i32.ge_u $i $argc) (br $done)) + (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) (i32.load (i32.add $argv (i32.mul_u $i 4))))) diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam index 389977b532..c7ad71fa86 100644 --- a/wasm/step8_macros.wam +++ b/wasm/step8_macros.wam @@ -9,16 +9,14 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) - (local $type i32) - (set_local $type ($TYPE $ast)) + (LET $type ($TYPE $ast)) (AND (OR (i32.eq $type (get_global $LIST_T)) (i32.eq $type (get_global $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) (func $QUASIQUOTE (param $ast i32) (result i32) - (local $sym i32 $res i32 $second i32 $third i32) - (set_local $res 0) + (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) @@ -64,24 +62,22 @@ (global $mac_stack_top (mut i32) (i32.const -1)) (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) - (local $ast i32 $mac i32 $mac_env i64) - (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4 - (set_local $ast $orig_ast) - (set_local $mac 0) + (local $mac_env i64) + (LET $ast $orig_ast + $mac 0) + (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init (block $done (loop $loop - (if (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list - (i32.eqz ($VAL0 $ast)) ;; non-empty - (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (get_global $SYMBOL_T))) - (br $done)) + (br_if $done + (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (get_global $SYMBOL_T)))) (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) - (if (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env - (i32.ne ($TYPE $mac) ;; a macro - (get_global $MACRO_T))) - (then - (br $done))) + (br_if $done (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (get_global $MACRO_T)))) (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) ;; PEND_A_LV @@ -97,8 +93,7 @@ (get_global $mac_stack) (i32.mul_s (get_global $mac_stack_top) 4)) $ast))) - (if (get_global $error_type) - (br $done)) + (br_if $done (get_global $error_type)) (br $loop) ) @@ -107,8 +102,8 @@ ) (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -135,10 +130,10 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -194,17 +189,12 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) - (local $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - (local $orig_mac_stack_top i32) - - (set_local $ast $orig_ast) - (set_local $env $orig_env) - (set_local $prev_ast 0) - (set_local $prev_env 0) - (set_local $res 0) - (set_local $orig_mac_stack_top (get_global $mac_stack_top)) + (LET $ast $orig_ast + $env $orig_env + $orig_mac_stack_top (get_global $mac_stack_top) + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) (block $EVAL_return (loop $TCO_loop @@ -249,7 +239,7 @@ (set_local $a1 ($MAL_GET_A1 $ast)) (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -265,12 +255,11 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) @@ -317,8 +306,7 @@ (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) ($SET_TYPE $res (get_global $MACRO_T)) - (if (get_global $error_type) - (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -430,10 +418,7 @@ ;; TODO: needs to happen here so self-hosting doesn't leak (block $done (loop $loop - (if (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top) - (br $done)) -;;($printf_1 "free orig_mac_stack_top: %d\n" $orig_mac_stack_top) -;;($printf_1 "free mac_stack_top: %d\n" (get_global $mac_stack_top)) + (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add (get_global $mac_stack) (i32.mul_s (get_global $mac_stack_top) 4)))) @@ -453,10 +438,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -467,10 +452,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -482,10 +467,10 @@ ) (func $main (param $argc i32 $argv i32) (result i32) - (local $line i32 $res i32 $repl_env i32) - ;; argument processing - (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -522,7 +507,7 @@ (set_local $i 2) (block $done (loop $loop - (if (i32.ge_u $i $argc) (br $done)) + (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) (i32.load (i32.add $argv (i32.mul_u $i 4))))) diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam index 67fd7fda36..8021724207 100644 --- a/wasm/step9_try.wam +++ b/wasm/step9_try.wam @@ -9,16 +9,14 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) - (local $type i32) - (set_local $type ($TYPE $ast)) + (LET $type ($TYPE $ast)) (AND (OR (i32.eq $type (get_global $LIST_T)) (i32.eq $type (get_global $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) (func $QUASIQUOTE (param $ast i32) (result i32) - (local $sym i32 $res i32 $second i32 $third i32) - (set_local $res 0) + (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) @@ -64,24 +62,22 @@ (global $mac_stack_top (mut i32) (i32.const -1)) (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) - (local $ast i32 $mac i32 $mac_env i64) - (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4 - (set_local $ast $orig_ast) - (set_local $mac 0) + (local $mac_env i64) + (LET $ast $orig_ast + $mac 0) + (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init (block $done (loop $loop - (if (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list - (i32.eqz ($VAL0 $ast)) ;; non-empty - (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (get_global $SYMBOL_T))) - (br $done)) + (br_if $done + (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (get_global $SYMBOL_T)))) (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) - (if (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env - (i32.ne ($TYPE $mac) ;; a macro - (get_global $MACRO_T))) - (then - (br $done))) + (br_if $done (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (get_global $MACRO_T)))) (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) ;; PEND_A_LV @@ -97,8 +93,7 @@ (get_global $mac_stack) (i32.mul_s (get_global $mac_stack_top) 4)) $ast))) - (if (get_global $error_type) - (br $done)) + (br_if $done (get_global $error_type)) (br $loop) ) @@ -107,8 +102,8 @@ ) (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -135,10 +130,10 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -194,18 +189,13 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) - (local $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - (local $err i32) - (local $orig_mac_stack_top i32) - - (set_local $ast $orig_ast) - (set_local $env $orig_env) - (set_local $prev_ast 0) - (set_local $prev_env 0) - (set_local $res 0) - (set_local $orig_mac_stack_top (get_global $mac_stack_top)) + (LET $ast $orig_ast + $env $orig_env + $orig_mac_stack_top (get_global $mac_stack_top) + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 + $err 0) (block $EVAL_return (loop $TCO_loop @@ -250,7 +240,7 @@ (set_local $a1 ($MAL_GET_A1 $ast)) (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -266,12 +256,11 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) @@ -318,8 +307,7 @@ (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) ($SET_TYPE $res (get_global $MACRO_T)) - (if (get_global $error_type) - (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -336,13 +324,12 @@ (set_local $res ($EVAL $a1 $env)) ;; if there is no error, return - (if (i32.eqz (get_global $error_type)) - (br $EVAL_return)) + (br_if $EVAL_return (i32.eqz (get_global $error_type))) ;; if there is an error and res is set, we need to free it ($RELEASE $res) ;; if there is no catch block then return - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) + (br_if $EVAL_return + (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) ;; save the current environment for release (set_local $prev_env $env) @@ -478,10 +465,7 @@ ;; TODO: needs to happen here so self-hosting doesn't leak (block $done (loop $loop - (if (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top) - (br $done)) -;;($printf_1 "free orig_mac_stack_top: %d\n" $orig_mac_stack_top) -;;($printf_1 "free mac_stack_top: %d\n" (get_global $mac_stack_top)) + (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add (get_global $mac_stack) (i32.mul_s (get_global $mac_stack_top) 4)))) @@ -501,10 +485,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -515,10 +499,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -530,10 +514,10 @@ ) (func $main (param $argc i32 $argv i32) (result i32) - (local $line i32 $res i32 $repl_env i32) - ;; argument processing - (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -570,7 +554,7 @@ (set_local $i 2) (block $done (loop $loop - (if (i32.ge_u $i $argc) (br $done)) + (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) (i32.load (i32.add $argv (i32.mul_u $i 4))))) diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index f196fabc98..3ce28c063f 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -9,16 +9,14 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) - (local $type i32) - (set_local $type ($TYPE $ast)) + (LET $type ($TYPE $ast)) (AND (OR (i32.eq $type (get_global $LIST_T)) (i32.eq $type (get_global $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) (func $QUASIQUOTE (param $ast i32) (result i32) - (local $sym i32 $res i32 $second i32 $third i32) - (set_local $res 0) + (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) @@ -64,24 +62,22 @@ (global $mac_stack_top (mut i32) (i32.const -1)) (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) - (local $ast i32 $mac i32 $mac_env i64) - (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4 - (set_local $ast $orig_ast) - (set_local $mac 0) + (local $mac_env i64) + (LET $ast $orig_ast + $mac 0) + (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init (block $done (loop $loop - (if (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list - (i32.eqz ($VAL0 $ast)) ;; non-empty - (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (get_global $SYMBOL_T))) - (br $done)) + (br_if $done + (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (get_global $SYMBOL_T)))) (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) - (if (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env - (i32.ne ($TYPE $mac) ;; a macro - (get_global $MACRO_T))) - (then - (br $done))) + (br_if $done (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (get_global $MACRO_T)))) (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) ;; PEND_A_LV @@ -97,8 +93,7 @@ (get_global $mac_stack) (i32.mul_s (get_global $mac_stack_top) 4)) $ast))) - (if (get_global $error_type) - (br $done)) + (br_if $done (get_global $error_type)) (br $loop) ) @@ -107,8 +102,8 @@ ) (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (local $res i32 $val2 i32 $val3 i32 $type i32 $found i32) - (local $ret i32 $empty i32 $current i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) (if (get_global $error_type) (return 0)) (set_local $type ($TYPE $ast)) @@ -135,10 +130,10 @@ (block $done (loop $loop ;; check if we are done evaluating the source sequence - (if (i32.eq ($VAL0 $ast) 0) (br $done)) + (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0) (br $done))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) (if (i32.eq $type (get_global $HASHMAP_T)) (then @@ -194,18 +189,13 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (local $ast i32 $env i32 $prev_ast i32 $prev_env i32 $res i32 $el i32) - (local $ftype i32 $f_args i32 $f i32 $args i32) - (local $a0 i32 $a0sym i32 $a1 i32 $a2 i32) - (local $err i32) - (local $orig_mac_stack_top i32) - - (set_local $ast $orig_ast) - (set_local $env $orig_env) - (set_local $prev_ast 0) - (set_local $prev_env 0) - (set_local $res 0) - (set_local $orig_mac_stack_top (get_global $mac_stack_top)) + (LET $ast $orig_ast + $env $orig_env + $orig_mac_stack_top (get_global $mac_stack_top) + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 + $err 0) (block $EVAL_return (loop $TCO_loop @@ -250,7 +240,7 @@ (set_local $a1 ($MAL_GET_A1 $ast)) (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -266,12 +256,11 @@ (block $done (loop $loop - (if (i32.eqz ($VAL0 $a1)) - (br $done)) + (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (if (get_global $error_type) (br $done)) + (br_if $done (get_global $error_type)) ;; set key/value in the let environment (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) @@ -318,8 +307,7 @@ (set_local $a2 ($MAL_GET_A2 $ast)) (set_local $res ($EVAL $a2 $env)) ($SET_TYPE $res (get_global $MACRO_T)) - (if (get_global $error_type) - (br $EVAL_return)) + (br_if $EVAL_return (get_global $error_type)) ;; set a1 in env to a2 (set_local $res ($ENV_SET $env $a1 $res)) @@ -336,13 +324,12 @@ (set_local $res ($EVAL $a1 $env)) ;; if there is no error, return - (if (i32.eqz (get_global $error_type)) - (br $EVAL_return)) + (br_if $EVAL_return (i32.eqz (get_global $error_type))) ;; if there is an error and res is set, we need to free it ($RELEASE $res) ;; if there is no catch block then return - (if (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) + (br_if $EVAL_return + (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) ;; save the current environment for release (set_local $prev_env $env) @@ -478,10 +465,7 @@ ;; TODO: needs to happen here so self-hosting doesn't leak (block $done (loop $loop - (if (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top) - (br $done)) -;;($printf_1 "free orig_mac_stack_top: %d\n" $orig_mac_stack_top) -;;($printf_1 "free mac_stack_top: %d\n" (get_global $mac_stack_top)) + (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add (get_global $mac_stack) (i32.mul_s (get_global $mac_stack_top) 4)))) @@ -501,10 +485,10 @@ ;; REPL (func $RE (param $line i32 $env i32) (result i32) - (local $mv1 i32 $res i32) - (block $rep_done + (LET $mv1 0 $res 0) + (block $done (set_local $mv1 ($READ $line)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) (set_local $res ($EVAL $mv1 $env)) ) @@ -515,10 +499,10 @@ ) (func $REP (param $line i32 $env i32) (result i32) - (local $mv2 i32 $ms i32) - (block $rep_done + (LET $mv2 0 $ms 0) + (block $done (set_local $mv2 ($RE $line $env)) - (if (get_global $error_type) (br $rep_done)) + (br_if $done (get_global $error_type)) ;; ($PR_MEMORY -1 -1) (set_local $ms ($PRINT $mv2)) @@ -530,10 +514,10 @@ ) (func $main (param $argc i32 $argv i32) (result i32) - (local $line i32 $res i32 $repl_env i32) - ;; argument processing - (local $i i32 $ret i32 $empty i32 $current i32 $tmp i32 $val2 i32) - (set_local $line (STATIC_ARRAY 201)) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -572,7 +556,7 @@ (set_local $i 2) (block $done (loop $loop - (if (i32.ge_u $i $argc) (br $done)) + (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) (i32.load (i32.add $argv (i32.mul_u $i 4))))) diff --git a/wasm/string.wam b/wasm/string.wam index dd2ff3cd04..0ad81c42dd 100644 --- a/wasm/string.wam +++ b/wasm/string.wam @@ -5,8 +5,7 @@ ;; Copy len bytes from src to dst ;; Returns len (func $memmove (param $dst i32 $src i32 $len i32) - (local $idx i32) - (set_local $idx 0) + (LET $idx 0) (loop $copy (i32.store8_u (i32.add $idx $dst) (i32.load8_u (i32.add $idx $src))) @@ -16,8 +15,7 @@ ) (func $strlen (param $str i32) (result i32) - (local $cur i32) - (set_local $cur $str) + (LET $cur $str) (loop $count (if (i32.ne 0 (i32.load8_u $cur)) (then @@ -30,10 +28,9 @@ ;; Based on https://stackoverflow.com/a/25705264/471795 ;; This could be made much more efficient (func $strstr (param $haystack i32 $needle i32) (result i32) - (local $i i32 $needle_len i32 $len i32) - - (set_local $needle_len ($strlen $needle)) - (set_local $len ($strlen $haystack)) + (LET $i 0 + $needle_len ($strlen $needle) + $len ($strlen $haystack)) (if (i32.eq $needle_len 0) (return $haystack)) @@ -55,13 +52,10 @@ ) (func $atoi (param $str i32) (result i32) - (local $acc i32) - (local $i i32) - (local $neg i32) - (local $ch i32) - (set_local $acc 0) - (set_local $i 0) - (set_local $neg 0) + (LET $acc 0 + $i 0 + $neg 0 + $ch 0) (block $done (loop $loop (set_local $ch (i32.load8_u (i32.add $str $i))) @@ -105,8 +99,7 @@ ) (func $strncmp (param $s1 i32 $s2 i32 $len i32) (result i32) - (local $i i32) - (set_local $i 0) + (LET $i 0) (if (i32.eq $len 0) (return 0)) (block $done (loop $loop @@ -136,14 +129,12 @@ $needle0 i32 $replace0 i32 $needle1 i32 $replace1 i32 $needle2 i32 $replace2 i32) (result i32) - (local $needle i32 $replace i32) - (local $haystack_len i32 $needle_len i32 $replace_len i32) - (local $src_str i32 $dst_str i32 $s i32 $found_tmp i32 $found i32) - (local $replace_s i32 $replace_len_s i32 $needle_len_s i32) - - (set_local $haystack_len ($strlen $haystack)) - (set_local $src_str $haystack) - (set_local $dst_str $grass) + (LET $haystack_len ($strlen $haystack) + $src_str $haystack + $dst_str $grass + $s 0 $found_tmp 0 $found 0 + $needle 0 $replace 0 $needle_len 0 $replace_len 0 + $replace_s 0 $replace_len_s 0 $needle_len_s 0) ;; in-place (if (i32.eqz $grass) diff --git a/wasm/types.wam b/wasm/types.wam index 5574c3d3be..c8e33718c0 100644 --- a/wasm/types.wam +++ b/wasm/types.wam @@ -73,9 +73,8 @@ ) (func $EQUAL_Q (param $a i32 $b i32) (result i32) - (local $ta i32 $tb i32) - (set_local $ta ($TYPE $a)) - (set_local $tb ($TYPE $b)) + (LET $ta ($TYPE $a) + $tb ($TYPE $b)) (if (AND (OR (i32.eq $ta (get_global $LIST_T)) (i32.eq $ta (get_global $VECTOR_T))) @@ -138,9 +137,7 @@ ;; Duplicate regular character array string into a Mal string and ;; return the MalVal pointer (func $STRING (param $type i32 $str i32) (result i32) - (local $ms i32) - ;; TODO: assert mv is a string/keyword/symbol - (set_local $ms ($ALLOC_STRING $str ($strlen $str) 1)) + (LET $ms ($ALLOC_STRING $str ($strlen $str) 1)) ($ALLOC_SCALAR $type (i32.sub_u $ms (get_global $string_mem))) ) @@ -148,10 +145,10 @@ ;; mv and return the interned version. If no duplicate is found, ;; return NULL. (func $INTERN_STRING (param $mv i32) (result i32) - (local $res i32 $ms i32 $existing_ms i32 $tmp i32) - (set_local $res 0) - (set_local $ms ($to_MalString $mv)) - (set_local $existing_ms ($FIND_STRING (i32.add $ms 4))) + (LET $res 0 + $ms ($to_MalString $mv) + $existing_ms ($FIND_STRING (i32.add $ms 4)) + $tmp 0) (if (AND $existing_ms (i32.lt_s $existing_ms $ms)) (then (set_local $tmp $mv) @@ -164,16 +161,14 @@ ) (func $STRING_INIT (param $type i32) (result i32) - (local $ms i32) - (set_local $ms ($ALLOC_STRING "" 0 0)) + (LET $ms ($ALLOC_STRING "" 0 0)) ($ALLOC_SCALAR $type (i32.sub_s $ms (get_global $string_mem))) ) (func $STRING_FINALIZE (param $mv i32 $size i32) (result i32) - (local $tmp i32 $ms i32) ;; Check if the new string can be interned. - (set_local $tmp ($INTERN_STRING $mv)) - (set_local $ms ($to_MalString $mv)) + (LET $tmp ($INTERN_STRING $mv) + $ms ($to_MalString $mv)) (if $tmp (then (set_local $mv $tmp)) @@ -198,16 +193,15 @@ ;; sequence functions (func $MAP_LOOP_START (param $type i32) (result i32) - (local $res i32) - (set_local $res (if i32 (i32.eq $type (get_global $LIST_T)) - (get_global $EMPTY_LIST) - (else (if i32 (i32.eq $type (get_global $VECTOR_T)) - (get_global $EMPTY_VECTOR) - (else (if i32 (i32.eq $type (get_global $HASHMAP_T)) - (get_global $EMPTY_HASHMAP) - (else - ($THROW_STR_1 "read_seq invalid type %d" $type) - 0))))))) + (LET $res (if i32 (i32.eq $type (get_global $LIST_T)) + (get_global $EMPTY_LIST) + (else (if i32 (i32.eq $type (get_global $VECTOR_T)) + (get_global $EMPTY_VECTOR) + (else (if i32 (i32.eq $type (get_global $HASHMAP_T)) + (get_global $EMPTY_HASHMAP) + (else + ($THROW_STR_1 "read_seq invalid type %d" $type) + 0))))))) ($INC_REF $res) ) @@ -215,9 +209,8 @@ (func $MAP_LOOP_UPDATE (param $type i32) (param $empty i32) (param $current i32) (param $val2 i32) (param $val3 i32) (result i32) - (local $res i32) + (LET $res ($ALLOC $type $empty $val2 $val3)) - (set_local $res ($ALLOC $type $empty $val2 $val3)) ;; sequence took ownership ($RELEASE $empty) ($RELEASE $val2) @@ -231,7 +224,7 @@ ) (func $FORCE_SEQ_TYPE (param $type i32) (param $mv i32) (result i32) - (local $res i32) + (LET $res 0) ;; if it's already the right type, inc ref cnt and return it (if (i32.eq $type ($TYPE $mv)) (return ($INC_REF $mv))) ;; if it's empty, return the sequence match @@ -247,17 +240,15 @@ (func $LIST2 (param $first i32 $second i32) (result i32) ;; last element is empty list - (local $tmp i32 $res i32) - (set_local $tmp ($LIST (get_global $EMPTY_LIST) $second)) - (set_local $res ($LIST $tmp $first)) + (LET $tmp ($LIST (get_global $EMPTY_LIST) $second) + $res ($LIST $tmp $first)) ($RELEASE $tmp) ;; new list takes ownership of previous $res ) (func $LIST3 (param $first i32 $second i32 $third i32) (result i32) - (local $tmp i32 $res i32) - (set_local $tmp ($LIST2 $second $third)) - (set_local $res ($LIST $tmp $first)) + (LET $tmp ($LIST2 $second $third) + $res ($LIST $tmp $first)) ($RELEASE $tmp) ;; new list takes ownership of previous $res ) @@ -271,8 +262,7 @@ ) (func $COUNT (param $mv i32) (result i32) - (local $cnt i32) - (set_local $cnt 0) + (LET $cnt 0) (block $done (loop $loop (if (i32.eq ($VAL0 $mv) 0) (br $done)) @@ -285,7 +275,7 @@ ) (func $LAST (param $mv i32) (result i32) - (local $cur i32) + (LET $cur 0) ;; TODO: check that actually a list/vector (if (i32.eq ($VAL0 $mv) 0) ;; empty seq, return nil @@ -309,11 +299,10 @@ ;; set after to element following slice (or original) (func $SLICE (param $seq i32) (param $start i32) (param $end i32) (result i64) - (local $idx i32 $res i32 $tmp i32 $last i32) - (set_local $idx 0) - (set_local $res ($INC_REF (get_global $EMPTY_LIST))) - (set_local $last 0) - (set_local $tmp $res) + (LET $idx 0 + $res ($INC_REF (get_global $EMPTY_LIST)) + $last 0 + $tmp $res) ;; advance seq to start (block $done (loop $loop @@ -367,28 +356,25 @@ ) (func $ASSOC1 (param $hm i32 $k i32 $v i32) (result i32) - (local $res i32) - (set_local $res ($ALLOC (get_global $HASHMAP_T) $hm $k $v)) + (LET $res ($ALLOC (get_global $HASHMAP_T) $hm $k $v)) ;; we took ownership of previous release ($RELEASE $hm) $res ) (func $ASSOC1_S (param $hm i32 $k i32 $v i32) (result i32) - (local $kmv i32 $res i32) - (set_local $kmv ($STRING (get_global $STRING_T) $k)) - (set_local $res ($ASSOC1 $hm $kmv $v)) + (LET $kmv ($STRING (get_global $STRING_T) $k) + $res ($ASSOC1 $hm $kmv $v)) ;; map took ownership of key ($RELEASE $kmv) $res ) (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) - (local $res i32 $found i32 $key i32 $test_key_mv i32) - - (set_local $key ($to_String $key_mv)) - (set_local $found 0) - + (LET $key ($to_String $key_mv) + $found 0 + $res 0 + $test_key_mv 0) (block $done (loop $loop From f2858819cce56f6e2e3ea1852a46ee5d3ebc1254 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 7 Dec 2018 01:11:05 -0600 Subject: [PATCH 0408/1998] wasm: add line count rules. --- wasm/Makefile | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/wasm/Makefile b/wasm/Makefile index c4bb8544fc..6b978bbcbf 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -25,3 +25,13 @@ step7_quote.wasm step8_macros.wasm step9_try.wasm stepA_mal.wasm: $(STEP4_DEPS) clean: rm -f *.wast *.wasm + +.PHONY: stats tests + +stats: $(STEP4_DEPS) stepA_mal.wam + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(filter-out $(STEP1_DEPS),$(STEP4_DEPS)) stepA_mal.wam + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" + From 0c62f14e6adb12f0d31d77429c0971eb9b6d623f Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 15:35:49 -0600 Subject: [PATCH 0409/1998] wasm: drop unnecessary signed suffixes. Apparently some of the assemblers ignored these sign indicators and so this worked in the past. --- wasm/core.wam | 6 +++--- wasm/debug.wam | 26 ++++++++++++------------- wasm/env.wam | 2 +- wasm/mem.wam | 34 ++++++++++++++++----------------- wasm/platform_libc.wam | 8 ++++---- wasm/platform_os.wam | 2 +- wasm/printer.wam | 2 +- wasm/printf.wam | 40 +++++++++++++++++++-------------------- wasm/reader.wam | 12 ++++++------ wasm/step1_read_print.wam | 2 +- wasm/step2_eval.wam | 4 ++-- wasm/step3_env.wam | 4 ++-- wasm/step6_file.wam | 2 +- wasm/step7_quote.wam | 2 +- wasm/step8_macros.wam | 10 +++++----- wasm/step9_try.wam | 10 +++++----- wasm/stepA_mal.wam | 10 +++++----- wasm/string.wam | 22 ++++++++++----------- wasm/types.wam | 14 +++++++------- 19 files changed, 106 insertions(+), 106 deletions(-) diff --git a/wasm/core.wam b/wasm/core.wam index 12d2090849..ef2da7f281 100644 --- a/wasm/core.wam +++ b/wasm/core.wam @@ -170,11 +170,11 @@ ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $subtract (param $args i32) (result i32) ($INTEGER - (i32.sub_s ($VAL0 ($MEM_VAL1_ptr $args)) + (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $multiply (param $args i32) (result i32) ($INTEGER - (i32.mul_s ($VAL0 ($MEM_VAL1_ptr $args)) + (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $divide (param $args i32) (result i32) ($INTEGER @@ -443,7 +443,7 @@ (set_local $f_args ($INC_REF ($MEM_VAL1_ptr $rest_args)))))) (else ;; 1 or more intermediate args - (set_local $last_sl ($SLICE $rest_args 0 (i32.sub_s $rest_count 1))) + (set_local $last_sl ($SLICE $rest_args 0 (i32.sub $rest_count 1))) (set_local $f_args (i32.wrap/i64 $last_sl)) (set_local $last (i32.wrap/i64 (i64.shr_u $last_sl (i64.const 32)))) ;; release the terminator of the new list (we skip over it) diff --git a/wasm/debug.wam b/wasm/debug.wam index 6afbd5bedb..19e5c10f6f 100644 --- a/wasm/debug.wam +++ b/wasm/debug.wam @@ -8,7 +8,7 @@ (func $CHECK_FREE_LIST (result i32) (LET $first (i32.add (get_global $mem) - (i32.mul_u (get_global $mem_free_list) 4)) + (i32.mul (get_global $mem_free_list) 4)) $count 0) (block $done @@ -16,10 +16,10 @@ (br_if $done (i32.ge_s $first (i32.add (get_global $mem) - (i32.mul_u (get_global $mem_unused_start) + (i32.mul (get_global $mem_unused_start) 4)))) (set_local $count (i32.add $count ($MalVal_size $first))) - (set_local $first (i32.add (get_global $mem) (i32.mul_u 4 ($VAL0 $first)))) + (set_local $first (i32.add (get_global $mem) (i32.mul 4 ($VAL0 $first)))) (br $loop) ) ) @@ -27,8 +27,8 @@ ) (func $PR_MEMORY_SUMMARY_SMALL - (LET $free (i32.sub_s (get_global $MEM_SIZE) - (i32.mul_u (get_global $mem_unused_start) 4)) + (LET $free (i32.sub (get_global $MEM_SIZE) + (i32.mul (get_global $mem_unused_start) 4)) $free_list_count ($CHECK_FREE_LIST) $mv (get_global $NIL) $mem_ref_count 0) @@ -37,22 +37,22 @@ (loop $loop (br_if $done (i32.ge_s $mv (i32.add (get_global $mem) - (i32.mul_u (get_global $mem_unused_start) + (i32.mul (get_global $mem_unused_start) 4)))) (if (i32.ne ($TYPE $mv) (get_global $FREE_T)) (set_local $mem_ref_count (i32.add $mem_ref_count (i32.shr_u (i32.load $mv) 5)))) - (set_local $mv (i32.add $mv (i32.mul_u 4 ($MalVal_size $mv)))) + (set_local $mv (i32.add $mv (i32.mul 4 ($MalVal_size $mv)))) (br $loop) ) ) ($printf_3 "Free: %d, Values: %d (refs: %d), Emptys: " $free - (i32.sub_s - (i32.sub_s (get_global $mem_unused_start) 1) + (i32.sub + (i32.sub (get_global $mem_unused_start) 1) $free_list_count) $mem_ref_count) (set_local $mv (get_global $NIL)) @@ -210,9 +210,9 @@ (LET $ms 0 $idx 0) ($printf_2 "String - showing %d -> %d:\n" - $start (i32.sub_s (get_global $string_mem_next) + $start (i32.sub (get_global $string_mem_next) (get_global $string_mem))) - (if (i32.le_s (i32.sub_s (get_global $string_mem_next) + (if (i32.le_s (i32.sub (get_global $string_mem_next) (get_global $string_mem)) $start) (then ($print " ---\n")) @@ -221,7 +221,7 @@ (block $done (loop $loop (br_if $done (i32.ge_u $ms (get_global $string_mem_next))) - (set_local $idx (i32.sub_u $ms (get_global $string_mem))) + (set_local $idx (i32.sub $ms (get_global $string_mem))) (if (i32.ge_s $idx $start) ($printf_4 "%4d: refs %2d, size %2d >> '%s'\n" $idx @@ -241,7 +241,7 @@ (if (i32.lt_s $start 0) (then (set_local $start (get_global $mem_user_start)) - (set_local $string_start (i32.sub_s (get_global $string_mem_user_start) + (set_local $string_start (i32.sub (get_global $string_mem_user_start) (get_global $string_mem))))) (if (i32.lt_s $end 0) (set_local $end (get_global $mem_unused_start))) diff --git a/wasm/env.wam b/wasm/env.wam index 6515375dca..37ff695446 100644 --- a/wasm/env.wam +++ b/wasm/env.wam @@ -85,7 +85,7 @@ ;; combine res/env as hi 32/low 32 of i64 (i64.or - (i64.shl_u (i64.extend_u/i32 $res) (i64.const 32)) + (i64.shl (i64.extend_u/i32 $res) (i64.const 32)) (i64.extend_u/i32 $env)) ) diff --git a/wasm/mem.wam b/wasm/mem.wam index 67d0dc3325..9524f934bb 100644 --- a/wasm/mem.wam +++ b/wasm/mem.wam @@ -30,19 +30,19 @@ (func $MEM_VAL0_ptr (param $mv i32) (result i32) (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add $mv 4)) 4))) + (i32.mul (i32.load (i32.add $mv 4)) 4))) (func $MEM_VAL1_ptr (param $mv i32) (result i32) (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add $mv 8)) 4))) + (i32.mul (i32.load (i32.add $mv 8)) 4))) (func $MEM_VAL2_ptr (param $mv i32) (result i32) (i32.add (get_global $mem) - (i32.mul_u (i32.load (i32.add $mv 12)) 4))) + (i32.mul (i32.load (i32.add $mv 12)) 4))) ;; Returns the memory index mem of mv ;; Will usually be used with a load or store by the caller (func $IDX (param $mv i32) (result i32) ;; MalVal memory 64 bit (2 * i32) aligned - (i32.div_u (i32.sub_u $mv (get_global $mem)) 4)) + (i32.div_u (i32.sub $mv (get_global $mem)) 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -50,7 +50,7 @@ (func $MalVal_ptr (param $mv_idx i32) (result i32) ;; MalVal memory 64 bit (2 * i32) aligned ;;; mem[mv_idx].refcnt_type - (i32.add (get_global $mem) (i32.mul_u $mv_idx 4))) + (i32.add (get_global $mem) (i32.mul $mv_idx 4))) ;; Returns the address of 'mem[mv_idx].refcnt_type' (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) @@ -77,7 +77,7 @@ ;; Will usually be used with a load or store by the caller (func $MalVal_val_ptr (param $mv_idx i32 $val i32) (result i32) (i32.add (i32.add ($MalVal_ptr $mv_idx) 4) - (i32.mul_u $val 4))) + (i32.mul $val 4))) ;; Returns the value of 'mem[mv_idx].val[val]' (func $MalVal_val (param $mv_idx i32 $val i32) (result i32) @@ -294,7 +294,7 @@ ;; decrease reference count by one (i32.store ($MalVal_ptr $idx) - (i32.sub_u ($MalVal_refcnt_type $idx) 32)) + (i32.sub ($MalVal_refcnt_type $idx) 32)) ;; nil, false, true, empty sequences (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) @@ -362,7 +362,7 @@ ;; set type(FREE/15) and size ;;; mv->refcnt_type = size*32 + FREE_T - (i32.store $mv (i32.add (i32.mul_u $size 32) (get_global $FREE_T))) + (i32.store $mv (i32.add (i32.mul $size 32) (get_global $FREE_T))) (i32.store ($MalVal_val_ptr $idx 0) (get_global $mem_free_list)) (set_global $mem_free_list $idx) (if (i32.ge_u $size 3) (i32.store ($MalVal_val_ptr $idx 1) 0)) @@ -398,14 +398,14 @@ (if $ms (then ;;; ms->refcnt += 1 - (i32.store16_u $ms (i32.add (i32.load16_u $ms) 1)) + (i32.store16 $ms (i32.add (i32.load16_u $ms) 1)) (return $ms))))) ;; no existing matching string so create a new one (set_local $ms (get_global $string_mem_next)) - (i32.store16_u $ms 1) + (i32.store16 $ms 1) ;;; ms->size = sizeof(MalString)+size+1 - (i32.store16_u offset=2 $ms (i32.add (i32.add 4 $size) 1)) + (i32.store16 offset=2 $ms (i32.add (i32.add 4 $size) 1)) ($memmove (i32.add $ms 4) $str (i32.add $size 1)) ;;; string_mem_next = (void *)ms + ms->size (set_global $string_mem_next @@ -422,7 +422,7 @@ (if (i32.le_s (i32.load16_u $ms) 0) (then ($printf_2 "Release of already free string: %d (0x%x)\n" - (i32.sub_s $ms (get_global $string_mem)) $ms) + (i32.sub $ms (get_global $string_mem)) $ms) ($fatal 1 ""))) ;;; size = ms->size @@ -431,7 +431,7 @@ (set_local $next (i32.add $ms $size)) ;;; ms->refcnt -= 1 - (i32.store16_u $ms (i32.sub_u (i32.load16_u $ms) 1)) + (i32.store16 $ms (i32.sub (i32.load16_u $ms) 1)) (if (i32.eqz (i32.load16_u $ms)) (then @@ -440,12 +440,12 @@ ;; If no more references to this string then free it up by ;; shifting up every string afterwards to fill the gap ;; (splice). - ($memmove $ms $next (i32.sub_s (get_global $string_mem_next) + ($memmove $ms $next (i32.sub (get_global $string_mem_next) $next)) ;; Scan the mem values for string types after the freed ;; string and shift their indexes by size - (set_local $ms_idx (i32.sub_s $ms (get_global $string_mem))) + (set_local $ms_idx (i32.sub $ms (get_global $string_mem))) (set_local $idx ($IDX (get_global $EMPTY_HASHMAP))) (loop $loop (set_local $mv ($MalVal_ptr $idx)) @@ -453,13 +453,13 @@ (if (AND (i32.gt_s ($VAL0 $mv) $ms_idx) (OR (i32.eq $type (get_global $STRING_T)) (i32.eq $type (get_global $SYMBOL_T)))) - (i32.store ($VAL0_ptr $mv) (i32.sub_s ($VAL0 $mv) $size))) + (i32.store ($VAL0_ptr $mv) (i32.sub ($VAL0 $mv) $size))) (set_local $idx (i32.add $idx ($MalVal_size $mv))) (br_if $loop (i32.lt_s $idx (get_global $mem_unused_start))) ))) (set_global $string_mem_next - (i32.sub_s (get_global $string_mem_next) $size)))) + (i32.sub (get_global $string_mem_next) $size)))) ) ) diff --git a/wasm/platform_libc.wam b/wasm/platform_libc.wam index 7965b6ca58..0327f52c7f 100644 --- a/wasm/platform_libc.wam +++ b/wasm/platform_libc.wam @@ -46,7 +46,7 @@ (set_local $len ($strlen $line)) ($memmove $buf $line $len) ($lib_free $line))) - (i32.store8_u (i32.add $buf $len) (CHR "\x00")) + (i32.store8 (i32.add $buf $len) (CHR "\x00")) (return (if i32 $line 1 0)) ) @@ -75,7 +75,7 @@ ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) (return 0))) ;; Add null to string - (i32.store8_u (i32.add $buf $st_size) 0) + (i32.store8 (i32.add $buf $st_size) 0) (i32.add 1 $st_size) ) @@ -91,9 +91,9 @@ (set_local $secs (i32.load (i32.add $tv (get_global $TV_SEC_OFFSET)))) ;; subtract 30 years to make sure secs is positive and can be ;; multiplied by 1000 - (set_local $secs (i32.sub_s $secs 0x38640900)) + (set_local $secs (i32.sub $secs 0x38640900)) (set_local $usecs (i32.load (i32.add $tv (get_global $TV_USEC_OFFSET)))) - (set_local $msecs (i32.add (i32.mul_u $secs 1000) + (set_local $msecs (i32.add (i32.mul $secs 1000) (i32.div_u $usecs 1000))) $msecs ) diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index 4c67a44b8b..6615ce7551 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -37,7 +37,7 @@ (func $read_file (param $path i32 $buf i32) (result i32) (LET $size ($lib_read_file $path $buf)) ;; Add null to string - (i32.store8_u (i32.add $buf $size) 0) + (i32.store8 (i32.add $buf $size) 0) (i32.add $size 1) ) diff --git a/wasm/printer.wam b/wasm/printer.wam index ebcddfd924..7aea5b412b 100644 --- a/wasm/printer.wam +++ b/wasm/printer.wam @@ -164,7 +164,7 @@ (else (set_local $res_str ($pr_str_val $res_str $mv $print_readably)))) - (set_local $res ($STRING_FINALIZE $res (i32.sub_s $res_str ($to_String $res)))) + (set_local $res ($STRING_FINALIZE $res (i32.sub $res_str ($to_String $res)))) $res ) diff --git a/wasm/printf.wam b/wasm/printf.wam index ea6a64a057..d1bd8d8443 100644 --- a/wasm/printf.wam +++ b/wasm/printf.wam @@ -51,7 +51,7 @@ (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) (LET $n (i32.rem_u $num $base) $ch (if (result i32) (i32.lt_u $n 10) 48 55)) - (i32.store8_u $str (i32.add $n $ch)) + (i32.store8 $str (i32.add $n $ch)) ) ;; TODO: add max buf length (i.e. snprintnum) @@ -63,24 +63,24 @@ (if (AND (i32.lt_s $val 0) (i32.eq $radix 10)) (then (set_local $neg 1) - (set_local $val (i32.sub_s 0 $val)))) + (set_local $val (i32.sub 0 $val)))) ;; Calculate smallest to most significant digit (loop $loop (set_local $digit (i32.rem_u $val $radix)) - (i32.store8_u $pbuf (if i32 (i32.lt_u $digit 10) + (i32.store8 $pbuf (if i32 (i32.lt_u $digit 10) (i32.add (CHR "0") $digit) - (i32.sub_u (i32.add (CHR "A") $digit) 10))) + (i32.sub (i32.add (CHR "A") $digit) 10))) (set_local $pbuf (i32.add $pbuf 1)) (set_local $val (i32.div_u $val $radix)) (br_if $loop (i32.gt_u $val 0)) ) - (set_local $i (i32.sub_u $pbuf $buf)) + (set_local $i (i32.sub $pbuf $buf)) (block $done (loop $loop (br_if $done (i32.ge_u $i $pad_cnt)) - (i32.store8_u $pbuf $pad_char) + (i32.store8 $pbuf $pad_char) (set_local $pbuf (i32.add $pbuf 1)) (set_local $i (i32.add $i 1)) (br $loop) @@ -89,22 +89,22 @@ (if $neg (then - (i32.store8_u $pbuf (CHR "-")) + (i32.store8 $pbuf (CHR "-")) (set_local $pbuf (i32.add $pbuf 1)))) - (i32.store8_u $pbuf (CHR "\x00")) + (i32.store8 $pbuf (CHR "\x00")) ;; now reverse it - (set_local $len (i32.sub_u $pbuf $buf)) + (set_local $len (i32.sub $pbuf $buf)) (set_local $i 0) (block $done (loop $loop (br_if $done (i32.ge_u $i (i32.div_u $len 2))) (set_local $j (i32.load8_u (i32.add $buf $i))) - (set_local $k (i32.add $buf (i32.sub_u (i32.sub_u $len $i) 1))) - (i32.store8_u (i32.add $buf $i) (i32.load8_u $k)) - (i32.store8_u $k $j) + (set_local $k (i32.add $buf (i32.sub (i32.sub $len $i) 1))) + (i32.store8 (i32.add $buf $i) (i32.load8_u $k)) + (i32.store8 $k $j) (set_local $i (i32.add $i 1)) (br $loop) ) @@ -149,7 +149,7 @@ (if (i32.ne $ch (CHR "%")) (then ;; TODO: check buffer length - (i32.store8_u $pstr $ch) + (i32.store8 $pstr $ch) (set_local $pstr (i32.add 1 $pstr)) (br $loop))) @@ -172,9 +172,9 @@ (set_local $fmt (i32.add 1 $fmt)) (br_if $done (i32.eqz $ch)))) (loop $loop - (set_local $pad_cnt (i32.mul_s $pad_cnt 10)) + (set_local $pad_cnt (i32.mul $pad_cnt 10)) (set_local $pad_cnt (i32.add $pad_cnt - (i32.sub_s $ch (CHR "0")))) + (i32.sub $ch (CHR "0")))) (set_local $ch (i32.load8_u $fmt)) (set_local $fmt (i32.add 1 $fmt)) (br_if $loop (AND (i32.ge_s $ch (CHR "0")) @@ -193,9 +193,9 @@ (block $done (loop $loop (br_if $done (i32.le_s $pad_cnt $len)) - (i32.store8_u $pstr (CHR " ")) + (i32.store8 $pstr (CHR " ")) (set_local $pstr (i32.add $pstr 1)) - (set_local $pad_cnt (i32.sub_s $pad_cnt 1)) + (set_local $pad_cnt (i32.sub $pad_cnt 1)) (br $loop) ) ) @@ -203,11 +203,11 @@ (set_local $pstr (i32.add $pstr $len))) (else (if (i32.eq (CHR "c") $ch) (then - (i32.store8_u $pstr $v) + (i32.store8 $pstr $v) (set_local $pstr (i32.add $pstr 1))) (else (if (i32.eq (CHR "%") $ch) (then - (i32.store8_u $pstr (CHR "%")) + (i32.store8 $pstr (CHR "%")) (set_local $pstr (i32.add $pstr 1)) (br $loop)) ;; don't increase vidx (else @@ -219,7 +219,7 @@ ) ) - (i32.store8_u $pstr (CHR "\x00")) + (i32.store8 $pstr (CHR "\x00")) $pstr ) diff --git a/wasm/reader.wam b/wasm/reader.wam index 0894928b50..45715caf2c 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -26,7 +26,7 @@ (func $skip_to_eol (param $str i32) (result i32) (LET $found 0 - $c (i32.load8_c (i32.add $str (get_global $read_index)))) + $c (i32.load8_u (i32.add $str (get_global $read_index)))) (if (i32.eq $c (CHR ";")) (then (set_local $found 1) @@ -68,7 +68,7 @@ (set_global $read_index (i32.add (get_global $read_index) 1)) ;; read first character ;;; token[token_index++] = c - (i32.store8_u (i32.add (get_global $token_buf) $token_index) $c) + (i32.store8 (i32.add (get_global $token_buf) $token_index) $c) (set_local $token_index (i32.add $token_index 1)) ;; single/double character token (if (OR (i32.eq $c (CHR "(")) @@ -113,7 +113,7 @@ (i32.eq $c (CHR "\n")))))) ;; read next character ;;; token[token_index++] = str[(*index)++] - (i32.store8_u (i32.add (get_global $token_buf) $token_index) + (i32.store8 (i32.add (get_global $token_buf) $token_index) (i32.load8_u (i32.add $str (get_global $read_index)))) (set_local $token_index (i32.add $token_index 1)) @@ -139,7 +139,7 @@ ))) ;;; token[token_index] = '\0' - (i32.store8_u (i32.add (get_global $token_buf) $token_index) 0) + (i32.store8 (i32.add (get_global $token_buf) $token_index) 0) (get_global $token_buf) ) @@ -246,7 +246,7 @@ (return ($INTEGER ($atoi $tok)))) (else (if (i32.eq $c0 (CHR ":")) (then - (i32.store8_u $tok (CHR "\x7f")) + (i32.store8 $tok (CHR "\x7f")) (return ($STRING (get_global $STRING_T) $tok))) (else (if (i32.eq $c0 (CHR "\"")) (then @@ -258,7 +258,7 @@ (else ;; unescape backslashes, quotes, and newlines ;; remove the trailing quote - (i32.store8_u (i32.add $tok $slen) (CHR "\x00")) + (i32.store8 (i32.add $tok $slen) (CHR "\x00")) (set_local $tok (i32.add $tok 1)) (drop ($REPLACE3 0 $tok "\\\"" "\"" diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam index 8b5e5d60b1..ad9c272cc6 100644 --- a/wasm/step1_read_print.wam +++ b/wasm/step1_read_print.wam @@ -48,7 +48,7 @@ ;; ($PR_MEMORY_RAW ;; (get_global $mem) (i32.add (get_global $mem) -;; (i32.mul_u (get_global $mem_unused_start) 4))) +;; (i32.mul (get_global $mem_unused_start) 4))) (drop ($STRING (get_global $STRING_T) "uvw")) (drop ($STRING (get_global $STRING_T) "xyz")) diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam index 82f772ef5d..ee169e6e51 100644 --- a/wasm/step2_eval.wam +++ b/wasm/step2_eval.wam @@ -174,11 +174,11 @@ ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $subtract (param $args i32) (result i32) ($INTEGER - (i32.sub_s ($VAL0 ($MEM_VAL1_ptr $args)) + (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $multiply (param $args i32) (result i32) ($INTEGER - (i32.mul_s ($VAL0 ($MEM_VAL1_ptr $args)) + (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $divide (param $args i32) (result i32) ($INTEGER diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam index 6095459579..5d87b08a90 100644 --- a/wasm/step3_env.wam +++ b/wasm/step3_env.wam @@ -219,11 +219,11 @@ ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $subtract (param $args i32) (result i32) ($INTEGER - (i32.sub_s ($VAL0 ($MEM_VAL1_ptr $args)) + (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $multiply (param $args i32) (result i32) ($INTEGER - (i32.mul_s ($VAL0 ($MEM_VAL1_ptr $args)) + (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $divide (param $args i32) (result i32) ($INTEGER diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam index b41bf4ff16..902626c96b 100644 --- a/wasm/step6_file.wam +++ b/wasm/step6_file.wam @@ -363,7 +363,7 @@ (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) - (i32.load (i32.add $argv (i32.mul_u $i 4))))) + (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam index 49859ecfa1..5a699b08e8 100644 --- a/wasm/step7_quote.wam +++ b/wasm/step7_quote.wam @@ -425,7 +425,7 @@ (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) - (i32.load (i32.add $argv (i32.mul_u $i 4))))) + (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam index c7ad71fa86..c45f2f3a8e 100644 --- a/wasm/step8_macros.wam +++ b/wasm/step8_macros.wam @@ -87,11 +87,11 @@ (then (set_global $mac_stack_top (i32.add (get_global $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul_s (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + (if (i32.ge_s (i32.mul (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add (get_global $mac_stack) - (i32.mul_s (get_global $mac_stack_top) 4)) + (i32.mul (get_global $mac_stack_top) 4)) $ast))) (br_if $done (get_global $error_type)) @@ -421,9 +421,9 @@ (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add (get_global $mac_stack) - (i32.mul_s (get_global $mac_stack_top) 4)))) + (i32.mul (get_global $mac_stack_top) 4)))) (set_global $mac_stack_top - (i32.sub_s (get_global $mac_stack_top) 1)) + (i32.sub (get_global $mac_stack_top) 1)) (br $loop) ) ) @@ -510,7 +510,7 @@ (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) - (i32.load (i32.add $argv (i32.mul_u $i 4))))) + (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam index 8021724207..d7636b6b39 100644 --- a/wasm/step9_try.wam +++ b/wasm/step9_try.wam @@ -87,11 +87,11 @@ (then (set_global $mac_stack_top (i32.add (get_global $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul_s (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + (if (i32.ge_s (i32.mul (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add (get_global $mac_stack) - (i32.mul_s (get_global $mac_stack_top) 4)) + (i32.mul (get_global $mac_stack_top) 4)) $ast))) (br_if $done (get_global $error_type)) @@ -468,9 +468,9 @@ (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add (get_global $mac_stack) - (i32.mul_s (get_global $mac_stack_top) 4)))) + (i32.mul (get_global $mac_stack_top) 4)))) (set_global $mac_stack_top - (i32.sub_s (get_global $mac_stack_top) 1)) + (i32.sub (get_global $mac_stack_top) 1)) (br $loop) ) ) @@ -557,7 +557,7 @@ (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) - (i32.load (i32.add $argv (i32.mul_u $i 4))))) + (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index 3ce28c063f..6aa05c94da 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -87,11 +87,11 @@ (then (set_global $mac_stack_top (i32.add (get_global $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul_s (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + (if (i32.ge_s (i32.mul (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add (get_global $mac_stack) - (i32.mul_s (get_global $mac_stack_top) 4)) + (i32.mul (get_global $mac_stack_top) 4)) $ast))) (br_if $done (get_global $error_type)) @@ -468,9 +468,9 @@ (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add (get_global $mac_stack) - (i32.mul_s (get_global $mac_stack_top) 4)))) + (i32.mul (get_global $mac_stack_top) 4)))) (set_global $mac_stack_top - (i32.sub_s (get_global $mac_stack_top) 1)) + (i32.sub (get_global $mac_stack_top) 1)) (br $loop) ) ) @@ -559,7 +559,7 @@ (br_if $done (i32.ge_u $i $argc)) (set_local $val2 ($STRING (get_global $STRING_T) - (i32.load (i32.add $argv (i32.mul_u $i 4))))) + (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE (set_local $res ($MAP_LOOP_UPDATE diff --git a/wasm/string.wam b/wasm/string.wam index 0ad81c42dd..28190a858e 100644 --- a/wasm/string.wam +++ b/wasm/string.wam @@ -7,7 +7,7 @@ (func $memmove (param $dst i32 $src i32 $len i32) (LET $idx 0) (loop $copy - (i32.store8_u (i32.add $idx $dst) + (i32.store8 (i32.add $idx $dst) (i32.load8_u (i32.add $idx $src))) (set_local $idx (i32.add 1 $idx)) (br_if $copy (i32.lt_u $idx $len)) @@ -22,7 +22,7 @@ (set_local $cur (i32.add $cur 1)) (br $count))) ) - (i32.sub_u $cur $str) + (i32.sub $cur $str) ) ;; Based on https://stackoverflow.com/a/25705264/471795 @@ -37,7 +37,7 @@ (set_local $i 0) (block $done (loop $loop - (if (i32.gt_s $i (i32.sub_s $len $needle_len)) (br $done)) + (if (i32.gt_s $i (i32.sub $len $needle_len)) (br $done)) (if (AND (i32.eq (i32.load8_u $haystack 0) (i32.load8_u $needle 0)) @@ -68,13 +68,13 @@ (then (set_local $neg 1)) (else - (set_local $acc (i32.add (i32.mul_u $acc 10) - (i32.sub_u $ch (CHR "0")))))) + (set_local $acc (i32.add (i32.mul $acc 10) + (i32.sub $ch (CHR "0")))))) (br $loop) ) ) (if i32 $neg - (then (i32.sub_s 0 $acc)) + (then (i32.sub 0 $acc)) (else $acc)) ) @@ -163,7 +163,7 @@ (block $done1 (loop $loop1 - (if (i32.ge_s (i32.sub_s $src_str $haystack) $haystack_len) + (if (i32.ge_s (i32.sub $src_str $haystack) $haystack_len) (br $done1)) ;; Find the earliest match @@ -192,8 +192,8 @@ ) (if (i32.eqz $found) (br $done1)) ;; copy before the match - ($memmove $dst_str $src_str (i32.add (i32.sub_s $found $src_str) 1)) - (set_local $dst_str (i32.add $dst_str (i32.sub_s $found $src_str))) + ($memmove $dst_str $src_str (i32.add (i32.sub $found $src_str) 1)) + (set_local $dst_str (i32.add $dst_str (i32.sub $found $src_str))) ;; add the replace string ($memmove $dst_str $replace_s (i32.add $replace_len_s 1)) (set_local $dst_str (i32.add $dst_str $replace_len_s)) @@ -206,9 +206,9 @@ ;; Copy the left-over ($memmove $dst_str $src_str ($strlen $src_str)) (set_local $dst_str (i32.add $dst_str ($strlen $src_str))) - (i32.store8_u $dst_str (CHR "\x00")) + (i32.store8 $dst_str (CHR "\x00")) - (i32.sub_s $dst_str $grass) + (i32.sub $dst_str $grass) ) ) diff --git a/wasm/types.wam b/wasm/types.wam index c8e33718c0..b432efde42 100644 --- a/wasm/types.wam +++ b/wasm/types.wam @@ -138,7 +138,7 @@ ;; return the MalVal pointer (func $STRING (param $type i32 $str i32) (result i32) (LET $ms ($ALLOC_STRING $str ($strlen $str) 1)) - ($ALLOC_SCALAR $type (i32.sub_u $ms (get_global $string_mem))) + ($ALLOC_SCALAR $type (i32.sub $ms (get_global $string_mem))) ) ;; Find first duplicate (internet) of mv. If one is found, free up @@ -153,16 +153,16 @@ (then (set_local $tmp $mv) (set_local $res ($ALLOC_SCALAR (get_global $STRING_T) - (i32.sub_s $existing_ms + (i32.sub $existing_ms (get_global $string_mem)))) - (i32.store16_u $existing_ms (i32.add (i32.load16_u $existing_ms) 1)) + (i32.store16 $existing_ms (i32.add (i32.load16_u $existing_ms) 1)) ($RELEASE $tmp))) $res ) (func $STRING_INIT (param $type i32) (result i32) (LET $ms ($ALLOC_STRING "" 0 0)) - ($ALLOC_SCALAR $type (i32.sub_s $ms (get_global $string_mem))) + ($ALLOC_SCALAR $type (i32.sub $ms (get_global $string_mem))) ) (func $STRING_FINALIZE (param $mv i32 $size i32) (result i32) @@ -174,7 +174,7 @@ (set_local $mv $tmp)) (else ;;; ms->size = sizeof(MalString) + size + 1 - (i32.store16_u (i32.add $ms 2) + (i32.store16 (i32.add $ms 2) (i32.add (i32.add 4 $size) 1)) ;;; string_mem_next = (void *)ms + ms->size (set_global $string_mem_next @@ -346,7 +346,7 @@ ;; combine last/res as hi 32/low 32 of i64 (i64.or - (i64.shl_u (i64.extend_u/i32 $last) (i64.const 32)) + (i64.shl (i64.extend_u/i32 $last) (i64.const 32)) (i64.extend_u/i32 $res)) ) @@ -398,7 +398,7 @@ ) ;; combine found/res as hi 32/low 32 of i64 - (i64.or (i64.shl_u (i64.extend_u/i32 $found) (i64.const 32)) + (i64.or (i64.shl (i64.extend_u/i32 $found) (i64.const 32)) (i64.extend_u/i32 $res)) ) From 77bf4e612d0dc281332909162b9da1a829e8b3ea Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 16:51:16 -0600 Subject: [PATCH 0410/1998] wasm: fix to work with wabt's wat2wasm. --- wasm/core.wam | 9 ++++----- wasm/env.wam | 2 -- wasm/mem.wam | 6 +++--- wasm/platform_libc.wam | 2 +- wasm/printer.wam | 16 ++++++++-------- wasm/printf.wam | 2 +- wasm/reader.wam | 1 + wasm/step5_tco.wam | 2 +- wasm/step6_file.wam | 2 +- wasm/step7_quote.wam | 2 +- wasm/step8_macros.wam | 2 +- wasm/step9_try.wam | 2 +- wasm/stepA_mal.wam | 2 +- wasm/string.wam | 28 ++++++++++++++-------------- wasm/types.wam | 21 +++++++++++---------- 15 files changed, 49 insertions(+), 50 deletions(-) diff --git a/wasm/core.wam b/wasm/core.wam index ef2da7f281..59e906782e 100644 --- a/wasm/core.wam +++ b/wasm/core.wam @@ -79,7 +79,7 @@ (func $keyword (param $args i32) (result i32) (LET $str ($to_String ($MEM_VAL1_ptr $args))) - (if i32 (i32.eq (i32.load8_u $str) (CHR "\x7f")) + (if (result i32) (i32.eq (i32.load8_u $str) (CHR "\x7f")) (then ($INC_REF ($MEM_VAL1_ptr $args))) (else (drop ($sprintf_1 (get_global $printf_buf) "\x7f%s" $str)) @@ -267,7 +267,7 @@ (func $get (param $args i32) (result i32) (LET $hm ($MEM_VAL1_ptr $args) $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - (if i32 (i32.eq $hm (get_global $NIL)) + (if (result i32) (i32.eq $hm (get_global $NIL)) (then ($INC_REF (get_global $NIL))) (else ($INC_REF (i32.wrap/i64 ($HASHMAP_GET $hm $key))))) ) @@ -276,7 +276,7 @@ (LET $hm ($MEM_VAL1_ptr $args) $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ($TRUE_FALSE - (if i32 (i32.eq $hm (get_global $NIL)) + (if (result i32) (i32.eq $hm (get_global $NIL)) (then 0) (else (i32.wrap/i64 (i64.shr_u ($HASHMAP_GET $hm $key) (i64.const 32)))))) @@ -521,7 +521,7 @@ ) (func $meta (param $args i32) (result i32) - (if i32 (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $METADATA_T)) + (if (result i32) (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $METADATA_T)) (then ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL1_ptr $args)))) (else ($INC_REF (get_global $NIL))))) @@ -545,7 +545,6 @@ ) (func $reset_BANG (param $args i32) (result i32) - (local $atom i32 $val i32) (LET $atom ($MEM_VAL1_ptr $args) $val ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ($_reset_BANG $atom $val) diff --git a/wasm/env.wam b/wasm/env.wam index 37ff695446..3132b4a9bb 100644 --- a/wasm/env.wam +++ b/wasm/env.wam @@ -1,8 +1,6 @@ (module $env (func $ENV_NEW (param $outer i32) (result i32) - (local $data i32 $env i32) - (LET $data ($HASHMAP) ;; allocate the data hashmap $env ($ALLOC (get_global $ENVIRONMENT_T) $data $outer 0)) ;; environment takes ownership diff --git a/wasm/mem.wam b/wasm/mem.wam index 9524f934bb..7a6e634c1f 100644 --- a/wasm/mem.wam +++ b/wasm/mem.wam @@ -85,13 +85,13 @@ (func $MalType_size (param $type i32) (result i32) ;;; if (type <= 5 || type == 9 || type == 12) - (if i32 (OR (i32.le_u $type 5) + (if (result i32) (OR (i32.le_u $type 5) (i32.eq $type 9) (i32.eq $type 12)) (then 2) (else ;;; else if (type == 8 || type == 10 || type == 11) - (if i32 (OR (i32.eq $type 8) + (if (result i32) (OR (i32.eq $type 8) (i32.eq $type 10) (i32.eq $type 11)) (then 4) @@ -100,7 +100,7 @@ (func $MalVal_size (param $mv i32) (result i32) (LET $type ($TYPE $mv)) ;; if (type == FREE_T) - (if i32 (i32.eq $type (get_global $FREE_T)) + (if (result i32) (i32.eq $type (get_global $FREE_T)) (then ;;; return (mv->refcnt_type & 0xffe0)>>5 (i32.shr_u (i32.and (i32.load $mv) 0xffe0) 5)) ;;; / 32 diff --git a/wasm/platform_libc.wam b/wasm/platform_libc.wam index 0327f52c7f..1c769af00a 100644 --- a/wasm/platform_libc.wam +++ b/wasm/platform_libc.wam @@ -47,7 +47,7 @@ ($memmove $buf $line $len) ($lib_free $line))) (i32.store8 (i32.add $buf $len) (CHR "\x00")) - (return (if i32 $line 1 0)) + (return (if (result i32) $line 1 0)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/wasm/printer.wam b/wasm/printer.wam index 7aea5b412b..0bd08236c7 100644 --- a/wasm/printer.wam +++ b/wasm/printer.wam @@ -61,10 +61,10 @@ ;; 8: hashmap (set_local $res ($sprintf_1 $res "%c" - (if i32 (i32.eq $type (get_global $LIST_T)) - (CHR "(") - (else (if i32 (i32.eq $type (get_global $VECTOR_T)) - (CHR "[") + (if (result i32) (i32.eq $type (get_global $LIST_T)) + (then (CHR "(")) + (else (if (result i32) (i32.eq $type (get_global $VECTOR_T)) + (then (CHR "[")) (else (CHR "{"))))))) ;; PR_SEQ_LOOP ;;; while (VAL0(mv) != 0) @@ -93,10 +93,10 @@ (set_local $res ($sprintf_1 $res "%c" - (if i32 (i32.eq $type (get_global $LIST_T)) - (CHR ")") - (else (if i32 (i32.eq $type (get_global $VECTOR_T)) - (CHR "]") + (if (result i32) (i32.eq $type (get_global $LIST_T)) + (then (CHR ")")) + (else (if (result i32) (i32.eq $type (get_global $VECTOR_T)) + (then (CHR "]")) (else (CHR "}"))))))) (br $done)) ;; 9: function diff --git a/wasm/printf.wam b/wasm/printf.wam index d1bd8d8443..b06a23864e 100644 --- a/wasm/printf.wam +++ b/wasm/printf.wam @@ -68,7 +68,7 @@ ;; Calculate smallest to most significant digit (loop $loop (set_local $digit (i32.rem_u $val $radix)) - (i32.store8 $pbuf (if i32 (i32.lt_u $digit 10) + (i32.store8 $pbuf (if (result i32) (i32.lt_u $digit 10) (i32.add (CHR "0") $digit) (i32.sub (i32.add (CHR "A") $digit) 10))) (set_local $pbuf (i32.add $pbuf 1)) diff --git a/wasm/reader.wam b/wasm/reader.wam index 45715caf2c..e87c01eb5f 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -298,6 +298,7 @@ (else (return ($STRING (get_global $SYMBOL_T) $tok)))) )))))))))))))))))))))))))))))))) + 0 ;; not reachable ) (func $read_str (param $str i32) (result i32) diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam index 161a6c5d78..c7a0984438 100644 --- a/wasm/step5_tco.wam +++ b/wasm/step5_tco.wam @@ -40,7 +40,7 @@ (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) (if (i32.eq $type (get_global $HASHMAP_T)) (then diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam index 902626c96b..4898f21a18 100644 --- a/wasm/step6_file.wam +++ b/wasm/step6_file.wam @@ -40,7 +40,7 @@ (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) (if (i32.eq $type (get_global $HASHMAP_T)) (then diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam index 5a699b08e8..bfbfed10f7 100644 --- a/wasm/step7_quote.wam +++ b/wasm/step7_quote.wam @@ -90,7 +90,7 @@ (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) (if (i32.eq $type (get_global $HASHMAP_T)) (then diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam index c45f2f3a8e..445d0fea11 100644 --- a/wasm/step8_macros.wam +++ b/wasm/step8_macros.wam @@ -133,7 +133,7 @@ (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) (if (i32.eq $type (get_global $HASHMAP_T)) (then diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam index d7636b6b39..61d91003cd 100644 --- a/wasm/step9_try.wam +++ b/wasm/step9_try.wam @@ -133,7 +133,7 @@ (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) (if (i32.eq $type (get_global $HASHMAP_T)) (then diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index 6aa05c94da..495e3e6807 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -133,7 +133,7 @@ (br_if $done (i32.eq ($VAL0 $ast) 0)) (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)) 0))) + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) (if (i32.eq $type (get_global $HASHMAP_T)) (then diff --git a/wasm/string.wam b/wasm/string.wam index 28190a858e..593ea1c1e0 100644 --- a/wasm/string.wam +++ b/wasm/string.wam @@ -39,8 +39,8 @@ (loop $loop (if (i32.gt_s $i (i32.sub $len $needle_len)) (br $done)) - (if (AND (i32.eq (i32.load8_u $haystack 0) - (i32.load8_u $needle 0)) + (if (AND (i32.eq (i32.load8_u $haystack) + (i32.load8_u $needle)) (i32.eqz ($strncmp $haystack $needle $needle_len))) (return $haystack)) (set_local $haystack (i32.add $haystack 1)) @@ -73,7 +73,7 @@ (br $loop) ) ) - (if i32 $neg + (if (result i32) $neg (then (i32.sub 0 $acc)) (else $acc)) ) @@ -90,10 +90,10 @@ (br $loop) ) ) - (if i32 (i32.eq (i32.load8_u $s1) (i32.load8_u $s2)) + (if (result i32) (i32.eq (i32.load8_u $s1) (i32.load8_u $s2)) (then 0) (else - (if i32 (i32.lt_u (i32.load8_u $s1) (i32.load8_u $s2)) + (if (result i32) (i32.lt_u (i32.load8_u $s1) (i32.load8_u $s2)) (then -1) (else 1)))) ) @@ -115,7 +115,7 @@ (i32.eq (i32.load8_u (i32.add $i $s1)) (i32.load8_u (i32.add $i $s2)))) (return 0)) - (if i32 (i32.lt_u (i32.load8_u (i32.add $i $s1)) + (if (result i32) (i32.lt_u (i32.load8_u (i32.add $i $s1)) (i32.load8_u (i32.add $i $s2))) (then -1) (else 1)) @@ -144,11 +144,11 @@ (block $done (loop $loop (if (i32.ge_u $s 3) (br $done)) - (set_local $needle (if i32 (i32.eq $s 0) $needle0 - (if i32 (i32.eq $s 1) $needle1 + (set_local $needle (if (result i32) (i32.eq $s 0) $needle0 + (if (result i32) (i32.eq $s 1) $needle1 $needle2))) - (set_local $replace (if i32 (i32.eq $s 0) $replace0 - (if i32 (i32.eq $s 1) $replace1 + (set_local $replace (if (result i32) (i32.eq $s 0) $replace0 + (if (result i32) (i32.eq $s 1) $replace1 $replace2))) (set_local $needle_len ($strlen $needle)) (set_local $replace_len ($strlen $replace)) @@ -172,11 +172,11 @@ (block $done2 (loop $loop2 (if (i32.ge_u $s 3) (br $done2)) - (set_local $needle (if i32 (i32.eq $s 0) $needle0 - (if i32 (i32.eq $s 1) $needle1 + (set_local $needle (if (result i32) (i32.eq $s 0) $needle0 + (if (result i32) (i32.eq $s 1) $needle1 $needle2))) - (set_local $replace (if i32 (i32.eq $s 0) $replace0 - (if i32 (i32.eq $s 1) $replace1 + (set_local $replace (if (result i32) (i32.eq $s 0) $replace0 + (if (result i32) (i32.eq $s 1) $replace1 $replace2))) (set_local $s (i32.add $s 1)) (set_local $found_tmp ($strstr $src_str $needle)) diff --git a/wasm/types.wam b/wasm/types.wam index b432efde42..a2d0cd36e3 100644 --- a/wasm/types.wam +++ b/wasm/types.wam @@ -59,7 +59,7 @@ ) (func $TRUE_FALSE (param $val i32) (result i32) - ($INC_REF (if i32 $val (get_global $TRUE) (get_global $FALSE))) + ($INC_REF (if (result i32) $val (get_global $TRUE) (get_global $FALSE))) ) (func $THROW_STR_0 (param $fmt i32) @@ -99,16 +99,17 @@ (else (if (AND (i32.eq $ta (get_global $HASHMAP_T)) (i32.eq $tb (get_global $HASHMAP_T))) ;; EQUAL_Q_HM - (return 1)) + (then (return 1)) ;; TODO: remove this once strings are interned (else (if (OR (AND (i32.eq $ta (get_global $STRING_T)) (i32.eq $tb (get_global $STRING_T))) (AND (i32.eq $ta (get_global $SYMBOL_T)) (i32.eq $tb (get_global $SYMBOL_T)))) - (return (i32.eqz ($strcmp ($to_String $a) ($to_String $b)))) + (then (return (i32.eqz ($strcmp ($to_String $a) ($to_String $b))))) (else (return (AND (i32.eq $ta $tb) - (i32.eq ($VAL0 $a) ($VAL0 $b))))))))) + (i32.eq ($VAL0 $a) ($VAL0 $b)))))))))) + 0 ;; not reachable ) (func $DEREF_META (param $mv i32) (result i32) @@ -193,12 +194,12 @@ ;; sequence functions (func $MAP_LOOP_START (param $type i32) (result i32) - (LET $res (if i32 (i32.eq $type (get_global $LIST_T)) - (get_global $EMPTY_LIST) - (else (if i32 (i32.eq $type (get_global $VECTOR_T)) - (get_global $EMPTY_VECTOR) - (else (if i32 (i32.eq $type (get_global $HASHMAP_T)) - (get_global $EMPTY_HASHMAP) + (LET $res (if (result i32) (i32.eq $type (get_global $LIST_T)) + (then (get_global $EMPTY_LIST)) + (else (if (result i32) (i32.eq $type (get_global $VECTOR_T)) + (then (get_global $EMPTY_VECTOR)) + (else (if (result i32) (i32.eq $type (get_global $HASHMAP_T)) + (then (get_global $EMPTY_HASHMAP)) (else ($THROW_STR_1 "read_seq invalid type %d" $type) 0))))))) From df43e71977c77183da56c9d02fa12230146b59f9 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 16:52:48 -0600 Subject: [PATCH 0411/1998] wasm: Update Dockerfile. WAMP and WASM_AS params. --- wasm/Dockerfile | 51 ++++++++++++++++++++++++++++++++++++++++++++++--- wasm/Makefile | 19 +++++++++++++----- 2 files changed, 62 insertions(+), 8 deletions(-) diff --git a/wasm/Dockerfile b/wasm/Dockerfile index a40c6fe035..2a342839be 100644 --- a/wasm/Dockerfile +++ b/wasm/Dockerfile @@ -1,5 +1,45 @@ FROM ubuntu:18.04 +MAINTAINER Joel Martin +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# +# node +# + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + +# +# binaryen +# RUN dpkg --add-architecture i386 && \ apt-get -y update && \ apt-get -y install \ @@ -7,9 +47,6 @@ RUN dpkg --add-architecture i386 && \ libsdl2-dev:i386 libsdl2-image-dev:i386 \ libedit-dev:i386 -# TODO: merge up -RUN apt-get -y install python - RUN git clone https://github.com/WebAssembly/binaryen/ && \ cd binaryen && \ cmake . && make && \ @@ -17,3 +54,11 @@ RUN git clone https://github.com/WebAssembly/binaryen/ && \ # TODO: merge up RUN apt-get -y install freeglut3-dev:i386 lib32gcc-7-dev libreadline-dev:i386 + +# +# wac/wace +# +RUN git clone https://github.com/kanaka/wac/ && \ + cd wac && \ + make USE_SDL= wac wace && \ + cp wac wace /usr/bin diff --git a/wasm/Makefile b/wasm/Makefile index 6b978bbcbf..7a949adc90 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,6 +1,9 @@ MODE ?= libc -STEP0_DEPS = platform_$(MODE).wam string.wam printf.wam +WASM_AS ?= wasm-as +WAMP ?= node_modules/.bin/wamp + +STEP0_DEPS = $(WAMP) platform_$(MODE).wam string.wam printf.wam STEP1_DEPS = $(STEP0_DEPS) types.wam mem.wam debug.wam reader.wam printer.wam STEP3_DEPS = $(STEP1_DEPS) env.wam STEP4_DEPS = $(STEP3_DEPS) core.wam @@ -11,9 +14,12 @@ STEPS = step0_repl step1_read_print step2_eval step3_env \ all: $(foreach s,$(STEPS),$(s).wasm) +node_modules/.bin/wamp: + npm install + %.wasm: %.wam - wamp $^ > $*.wast - wasm-as $*.wast -o $@ + $(WAMP) $(filter %.wam,$^) > $*.wast + $(WASM_AS) $*.wast -o $@ step0_repl.wasm: $(STEP0_DEPS) step1_read_print.wasm step2_eval.wasm: $(STEP1_DEPS) @@ -28,10 +34,13 @@ clean: .PHONY: stats tests -stats: $(STEP4_DEPS) stepA_mal.wam +SOURCES_ALL = $(filter %.wam,$(STEP4_DEPS)) stepA_mal.wam +SOURCES_LISP = $(filter-out $(STEP1_DEPS),$(SOURCES_ALL)) + +stats: $(SOURCES_ALL) @wc $^ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(filter-out $(STEP1_DEPS),$(STEP4_DEPS)) stepA_mal.wam +stats-lisp: $(SOURCES_LISP) @wc $^ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" From d72395aa8b0926c6b2981d61ff46579de371ffa5 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 16:56:59 -0600 Subject: [PATCH 0412/1998] wasm: update README. Activate in travis. --- .travis.yml | 1 + README.md | 16 +++++++++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ab99fe9077..9d3bb470b8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -91,6 +91,7 @@ matrix: - {env: IMPL=vb, services: [docker]} - {env: IMPL=vhdl, services: [docker]} - {env: IMPL=vimscript, services: [docker]} + - {env: IMPL=wasm, services: [docker]} - {env: IMPL=yorick, services: [docker]} script: diff --git a/README.md b/README.md index 9e6585e6a7..da71ca2a5f 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Mal is a Clojure inspired Lisp interpreter. -Mal is implemented in 73 languages: +Mal is implemented in 74 languages: * Ada * GNU awk @@ -80,6 +80,7 @@ Mal is implemented in 73 languages: * VHDL * Vimscript * Visual Basic.NET +* WebAssembly (wasm) * Yorick @@ -1039,6 +1040,19 @@ make mono ./stepX_YYY.exe ``` +### WebAssembly (wasm) ### + +The WebAssembly implementation has been written in +[Wam](https://github.com/kanaka/wam) (WebAssembly Macro language) and +runs under the [wac/wace](https://github.com/kanaka/wac) WebAssembly +runtime. + +``` +cd wasm +make +wace ./stepX_YYY.wasm +``` + ### Yorick *The Yorick implementation was created by [Dov Murik](https://github.com/dubek)* From 8faa94c66a803db4acc77c6972ef8334cc7d1e57 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 18:11:19 -0600 Subject: [PATCH 0413/1998] wasm: add package.json to pull in wamp. --- wasm/package.json | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 wasm/package.json diff --git a/wasm/package.json b/wasm/package.json new file mode 100644 index 0000000000..854d48984d --- /dev/null +++ b/wasm/package.json @@ -0,0 +1,8 @@ +{ + "name": "mal", + "version": "0.0.1", + "description": "Make a Lisp (mal) language implemented in Javascript", + "dependencies": { + "@kanaka/wamp": "1.0.4" + } +} From 27359631a6423d8b4a47dcb8e1cdc1fd8a2cc9af Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 18:26:13 -0600 Subject: [PATCH 0414/1998] README: add missing talk youtube links. --- README.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index da71ca2a5f..8adf552ef2 100644 --- a/README.md +++ b/README.md @@ -116,7 +116,10 @@ Unlocked: A Better Path to Language Learning". Joel gave a presentation on "Make Your Own Lisp Interpreter in 10 Incremental Steps" at LambdaConf 2016: [Part 1](https://www.youtube.com/watch?v=jVhupfthTEk), [Part -2](https://www.youtube.com/watch?v=X5OQBMGpaTU), +2](https://www.youtube.com/watch?v=X5OQBMGpaTU), [Part +3](https://www.youtube.com/watch?v=6mARZzGgX4U), [Part +4](https://www.youtube.com/watch?v=dCO1SYR5kDU), + [Slides](http://kanaka.github.io/lambdaconf/). If you are interesting in creating a mal implementation (or just @@ -1042,7 +1045,7 @@ mono ./stepX_YYY.exe ### WebAssembly (wasm) ### -The WebAssembly implementation has been written in +The WebAssembly implementation is written in [Wam](https://github.com/kanaka/wam) (WebAssembly Macro language) and runs under the [wac/wace](https://github.com/kanaka/wac) WebAssembly runtime. From 86633b336574865cba8ac2b013c79a19d52aac67 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 8 Dec 2018 18:29:28 -0600 Subject: [PATCH 0415/1998] README: fix formatting. --- README.md | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 8adf552ef2..1b68bbfeb9 100644 --- a/README.md +++ b/README.md @@ -114,12 +114,11 @@ Unlocked: A Better Path to Language Learning". [Video](https://www.youtube.com/watch?v=lgyOAiRtZGw), [Slides](http://kanaka.github.io/midwest.io.mal/). More recently Joel gave a presentation on "Make Your Own Lisp Interpreter in -10 Incremental Steps" at LambdaConf 2016: [Part -1](https://www.youtube.com/watch?v=jVhupfthTEk), [Part -2](https://www.youtube.com/watch?v=X5OQBMGpaTU), [Part -3](https://www.youtube.com/watch?v=6mARZzGgX4U), [Part -4](https://www.youtube.com/watch?v=dCO1SYR5kDU), - +10 Incremental Steps" at LambdaConf 2016: +[Part 1](https://www.youtube.com/watch?v=jVhupfthTEk), +[Part 2](https://www.youtube.com/watch?v=X5OQBMGpaTU), +[Part 3](https://www.youtube.com/watch?v=6mARZzGgX4U), +[Part 4](https://www.youtube.com/watch?v=dCO1SYR5kDU), [Slides](http://kanaka.github.io/lambdaconf/). If you are interesting in creating a mal implementation (or just From 89149437904c1c8877eb6a9526ec5b1c89b17ce3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sun, 9 Dec 2018 22:55:49 -0600 Subject: [PATCH 0416/1998] wasm: enable execution with Node Add node mode to travis alongside wace_libc. --- .travis.yml | 3 +- Makefile | 2 + wasm/Makefile | 2 +- wasm/node_readline.js | 46 +++++++++++++ wasm/package.json | 4 +- wasm/run | 10 ++- wasm/run.js | 149 ++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 212 insertions(+), 4 deletions(-) create mode 100644 wasm/node_readline.js create mode 100755 wasm/run.js diff --git a/.travis.yml b/.travis.yml index 9d3bb470b8..2cb06e3125 100644 --- a/.travis.yml +++ b/.travis.yml @@ -91,7 +91,8 @@ matrix: - {env: IMPL=vb, services: [docker]} - {env: IMPL=vhdl, services: [docker]} - {env: IMPL=vimscript, services: [docker]} - - {env: IMPL=wasm, services: [docker]} + - {env: IMPL=wasm wasm_MODE=wace_libc, services: [docker]} + - {env: IMPL=wasm wasm_MODE=node, services: [docker]} - {env: IMPL=yorick, services: [docker]} script: diff --git a/Makefile b/Makefile index c7febc3eed..e00d6444c0 100644 --- a/Makefile +++ b/Makefile @@ -58,6 +58,8 @@ matlab_MODE = octave python_MODE = python # scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment) scheme_MODE = chibi +# node wace_libc wace_fooboot +wasm_MODE = wace_libc # Extra options to pass to runtest.py TEST_OPTS = diff --git a/wasm/Makefile b/wasm/Makefile index 7a949adc90..b69cca47fe 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,4 +1,4 @@ -MODE ?= libc +MODE ?= $(if $(filter wace_fooboot node js,$(wasm_MODE)),os,libc) WASM_AS ?= wasm-as WAMP ?= node_modules/.bin/wamp diff --git a/wasm/node_readline.js b/wasm/node_readline.js new file mode 100644 index 0000000000..6042eaa0af --- /dev/null +++ b/wasm/node_readline.js @@ -0,0 +1,46 @@ +// IMPORTANT: choose one +var RL_LIB = "libreadline"; // NOTE: libreadline is GPL +//var RL_LIB = "libedit"; + +var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); + +var rlwrap = {}; // namespace for this module in web context + +var ffi = require('ffi-napi'), + fs = require('fs'); + +var rllib = ffi.Library(RL_LIB, { + 'readline': [ 'string', [ 'string' ] ], + 'add_history': [ 'int', [ 'string' ] ]}); + +var rl_history_loaded = false; + +exports.readline = rlwrap.readline = function(prompt) { + prompt = typeof prompt !== 'undefined' ? prompt : "user> "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i&2 "wace_fooboot mode not yet supported" ;; +wace_libc|*) + exec wace $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +esac diff --git a/wasm/run.js b/wasm/run.js new file mode 100755 index 0000000000..b9e21a796e --- /dev/null +++ b/wasm/run.js @@ -0,0 +1,149 @@ +#!/usr/bin/env node + +// Copyright Joel Martin +// License MIT + +const { promisify } = require('util') +const fs = require('fs') +const readFile = promisify(fs.readFile) +const assert = require('assert') +const { TextDecoder, TextEncoder } = require('text-encoding') +const node_readline = require('./node_readline.js') + +assert('WebAssembly' in global, 'WebAssembly not detected') + +// +// Memory interaction utilities +// + +// Convert node Buffer to Uint8Array +function toUint8Array(buf) { + let u = new Uint8Array(buf.length) + for (let i = 0; i < buf.length; ++i) { + u[i] = buf[i] + } + return u +} + +// Read null terminated string out of webassembly memory +function get_string(memory, addr) { + //console.warn("get_string:", addr) + let u8 = new Uint8Array(memory.buffer, addr) + let length = u8.findIndex(e => e == 0) + let bytes = new Uint8Array(memory.buffer, addr, length) + let str = new TextDecoder('utf8').decode(bytes) + return str +} + +// Write null terminated string into webassembly memory +function put_string(memory, addr, str, max_length) { + let buf8 = new Uint8Array(memory.buffer, addr) + + let bytes = new TextEncoder('utf8').encode(str) + if (max_length && bytes.length > max_length) { + bytes = bytes.slice(0, max_length) + } + + buf8.set(bytes, 0) + buf8[bytes.length] = 0 // null terminator + return bytes.length+1 +} + +// Put argv structure at beginning of memory +function marshal_argv(memory, offset, args) { + let view = new DataView(memory.buffer, offset) + let buf8 = new Uint8Array(memory.buffer, offset) + + let stringStart = (args.length + 1) * 4 + for (let i = 0; i < args.length; i++) { + let len = put_string(memory, stringStart, args[i]) + view.setUint32(i*4, stringStart, true) + stringStart = stringStart + len + } + view.setUint32(args.length*4, 0, true) + return offset + stringStart // start of free memory +} + +// Based on: +// https://gist.github.com/kripken/59c67556dc03bb6d57052fedef1e61ab + +// Loads a WebAssembly dynamic library, returns a promise. +async function loadWebAssembly(filename, args) { + // Fetch the file and compile it + const wasm_str = await readFile(filename) + const wasm_bin = toUint8Array(wasm_str) + const module = await WebAssembly.compile(wasm_bin) + let memory = new WebAssembly.Memory({ initial: 256 }) + // Core imports + function fputs(addr, stream) { + console.log(get_string(memory, addr).replace(/\n$/, '')) + } + + // Returns addr on success and -1 on failure + // Truncates to max_length + function readline(prompt, addr, max_length) { + let line = node_readline.readline(get_string(memory, prompt)) + if (line === null) { return 0 } + put_string(memory, addr, line, max_length) + return 1 + } + + function read_file(path_addr, buf) { + let path = get_string(memory, path_addr) + let contents = fs.readFileSync(path, 'utf8') + return put_string(memory, buf, contents) + } + + // Marshal arguments + const memoryStart = 0 + let memoryBase = marshal_argv(memory, memoryStart, args) + memoryBase = memoryBase + (8 - (memoryBase % 8)) + + // Create the imports for the module, including the + // standard dynamic library imports + imports = {} + imports.env = {} + imports.env.exit = process.exit + imports.env.stdout = 1 + imports.env.fputs = fputs; + imports.env.readline = readline + // ignore add_history, node_readline.readline already calls it + imports.env.add_history = (buf) => { } + imports.env.read_file = read_file + + imports.env.memory = memory + imports.env.memoryBase = memoryBase + imports.env.table = new WebAssembly.Table({ initial: 0, element: 'anyfunc' }) + imports.env.tableBase = imports.env.tableBase || 0 + // Create the instance. + return [new WebAssembly.Instance(module, imports), args.length, 0] +} + +async function main() { + assert(process.argv.length >= 3, + 'Usage: ./run.js prog.wasm [ARGS...]') + + const wasm = process.argv[2] + const args = process.argv.slice(2) + const [instance, argc, argv] = await loadWebAssembly(wasm, args) + + let exports = instance.exports + assert(exports, 'no exports found') + assert('_main' in exports, '_main not found in wasm module exports') + if ('__post_instantiate' in exports) { + //console.warn('calling exports.__post_instantiate()') + exports['__post_instantiate']() + } + //console.warn(`calling exports._main(${argc}, ${argv})`) + let start = new Date() + let res = exports['_main'](argc, argv) + let end = new Date() + //console.warn('runtime: ' + (end-start) + 'ms') + process.exit(res) +} + +if (module.parent) { + module.exports.loadWebAssembly = loadWebAssembly +} else { + main() +} From 76adfab958e24e75df358ee0c9013476dc03e95a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 10 Dec 2018 00:30:59 -0600 Subject: [PATCH 0417/1998] wasm: split js mode platform code out. Simplify the interface to remove imports that aren't used (stdout and add_history) and simplify (rename fputs to printline). --- Makefile | 2 +- wasm/Makefile | 2 +- wasm/platform_js.wam | 44 ++++++++++++++++++++++++++++++++++++++++++++ wasm/platform_os.wam | 11 +++++------ wasm/run.js | 12 +++++++----- 5 files changed, 58 insertions(+), 13 deletions(-) create mode 100644 wasm/platform_js.wam diff --git a/Makefile b/Makefile index e00d6444c0..52cf142ec6 100644 --- a/Makefile +++ b/Makefile @@ -58,7 +58,7 @@ matlab_MODE = octave python_MODE = python # scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment) scheme_MODE = chibi -# node wace_libc wace_fooboot +# js wace_libc wace_fooboot wasm_MODE = wace_libc # Extra options to pass to runtest.py diff --git a/wasm/Makefile b/wasm/Makefile index b69cca47fe..c86f2ff167 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,4 +1,4 @@ -MODE ?= $(if $(filter wace_fooboot node js,$(wasm_MODE)),os,libc) +MODE ?= $(if $(filter node js,$(wasm_MODE)),js,$(if $(filter wace_fooboot,$(wasm_MODE)),os,libc)) WASM_AS ?= wasm-as WAMP ?= node_modules/.bin/wamp diff --git a/wasm/platform_js.wam b/wasm/platform_js.wam new file mode 100644 index 0000000000..3993e16330 --- /dev/null +++ b/wasm/platform_js.wam @@ -0,0 +1,44 @@ +(module $platform_js + + (import "env" "exit" (func $lib_exit (param i32))) + (import "env" "printline" (func $lib_printline (param i32) (result i32))) + (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) + (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) + (import "env" "time_ms" (func $lib_time_ms (result i32))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $fatal (param $code i32 $msg i32) + ($print $msg) + ($lib_exit $code) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $print (param $addr i32) + (drop ($lib_printline $addr))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $readline (param $prompt i32 $buf i32) (result i32) + ;; TODO: don't hardcode count to 200 + (LET $res ($lib_readline $prompt $buf 200)) + $res + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $read_file (param $path i32 $buf i32) (result i32) + (LET $size ($lib_read_file $path $buf)) + ;; Add null to string + (i32.store8 (i32.add $buf $size) 0) + (i32.add $size 1) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $get_time_ms (result i32) + ($lib_time_ms) + ) + +) diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index 6615ce7551..c0ae33c147 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -1,14 +1,14 @@ (module $platform_os - (import "env" "exit" (func $lib_exit (param i32))) + (import "env" "exit" (func $lib_exit (param i32))) - (import "env" "stdout" (global $lib_stdout i32)) - (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) + (import "env" "stdout" (global $lib_stdout i32)) + (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) - (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) + (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) (import "env" "add_history" (func $lib_add_history (param i32))) - (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) + (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -43,7 +43,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (func $get_time_ms (result i32) 0 ) diff --git a/wasm/run.js b/wasm/run.js index b9e21a796e..da01761ae8 100755 --- a/wasm/run.js +++ b/wasm/run.js @@ -75,7 +75,7 @@ async function loadWebAssembly(filename, args) { const module = await WebAssembly.compile(wasm_bin) let memory = new WebAssembly.Memory({ initial: 256 }) // Core imports - function fputs(addr, stream) { + function printline(addr, stream) { console.log(get_string(memory, addr).replace(/\n$/, '')) } @@ -94,6 +94,10 @@ async function loadWebAssembly(filename, args) { return put_string(memory, buf, contents) } + function time_ms() { + return (new Date()).getTime() + } + // Marshal arguments const memoryStart = 0 let memoryBase = marshal_argv(memory, memoryStart, args) @@ -104,12 +108,10 @@ async function loadWebAssembly(filename, args) { imports = {} imports.env = {} imports.env.exit = process.exit - imports.env.stdout = 1 - imports.env.fputs = fputs; + imports.env.printline = printline imports.env.readline = readline - // ignore add_history, node_readline.readline already calls it - imports.env.add_history = (buf) => { } imports.env.read_file = read_file + imports.env.time_ms = time_ms imports.env.memory = memory imports.env.memoryBase = memoryBase From 18616b105e6872705ab290eec22fcec3661db700 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 10 Dec 2018 12:30:58 -0600 Subject: [PATCH 0418/1998] runtest: support carriage returns in tests. This allows carriage returns to be specified in tests which allows multiline tests to be written i.e. by using Ctrl-V Enter to put a literal carriage return (^M) into the test definition. The effect of this is to send a single string to the REPL that contains newlines which normally can't be done because readline behavior will split it into two separate lines. --- runtest.py | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/runtest.py b/runtest.py index 6e2a495e76..8953a10756 100755 --- a/runtest.py +++ b/runtest.py @@ -68,7 +68,7 @@ def log(data, end='\n'): help="Disable optional tests that follow a ';>>> optional=True'") parser.set_defaults(optional=True) -parser.add_argument('test_file', type=argparse.FileType('r'), +parser.add_argument('test_file', type=str, help="a test file formatted as with mal test data") parser.add_argument('mal_cmd', nargs="*", help="Mal implementation command line. Use '--' to " @@ -148,14 +148,14 @@ def read_to_prompt(self, prompts, timeout): buf = self.buf[0:match.start()] self.buf = self.buf[end:] self.last_prompt = prompt - return buf + return buf.replace("^M", "\r") return None def writeline(self, str): def _to_bytes(s): return bytes(s, "utf-8") if IS_PY_3 else s - self.stdin.write(_to_bytes(str + "\n")) + self.stdin.write(_to_bytes(str.replace('\r', '\x16\r') + "\n")) def cleanup(self): #print "cleaning up" @@ -169,7 +169,8 @@ def cleanup(self): class TestReader: def __init__(self, test_file): self.line_num = 0 - self.data = test_file.read().split('\n') + f = open(test_file, newline='') if IS_PY_3 else open(test_file) + self.data = f.read().split('\n') self.soft = False self.deferrable = False self.optional = False @@ -292,7 +293,7 @@ def assert_prompt(runner, prompts, timeout): if t.form == None: continue - log("TEST: %s -> [%s,%s]" % (t.form, repr(t.out), t.ret), end='') + log("TEST: %s -> [%s,%s]" % (repr(t.form), repr(t.out), t.ret), end='') # The repeated form is to get around an occasional OS X issue # where the form is repeated. @@ -349,7 +350,7 @@ def assert_prompt(runner, prompts, timeout): %3d: failing tests %3d: passing tests %3d: total tests -""" % (args.test_file.name, soft_fail_cnt, fail_cnt, +""" % (args.test_file, soft_fail_cnt, fail_cnt, pass_cnt, test_cnt) log(results) From dd7a4f55f3bf8b172b3ddaab2f40fbc39e4cea31 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 3 Dec 2018 13:20:44 -0600 Subject: [PATCH 0419/1998] Test uncaught throw, catchless try* . Fix 46 impls. Fixes made to: ada, c, chuck, clojure, coffee, common-lisp, cpp, crystal, d, dart, elm, erlang, es6, factor, fsharp, gnu-smalltalk, groovy, guile, haxe, hy, js, livescript, matlab, miniMAL, nasm, nim, objc, objpascal, ocaml, perl, perl6, php, plsql, ps, python, r, rpython, ruby, scheme, swift3, tcl, ts, vb, vimscript, wasm, yorick. Catchless try* test is an optional test. Not all implementations support catchless try* but a number were fixed so they at least don't crash on catchless try*. --- ada/core.adb | 14 ++-- ada/step4_if_fn_do.adb | 9 ++- ada/step5_tco.adb | 27 ++++--- ada/step6_file.adb | 20 +++-- ada/step7_quote.adb | 19 +++-- ada/step8_macros.adb | 18 +++-- ada/step9_try.adb | 17 +++- ada/stepa_mal.adb | 36 +++++---- ada/types-vector.adb | 2 +- ada/types.adb | 4 +- ada/types.ads | 2 + c/step0_repl.c | 4 +- c/step1_read_print.c | 11 +-- c/step2_eval.c | 11 +-- c/step3_env.c | 11 +-- c/step4_if_fn_do.c | 11 +-- c/step5_tco.c | 11 +-- c/step6_file.c | 11 +-- c/step7_quote.c | 11 +-- c/step8_macros.c | 13 ++-- c/step9_try.c | 18 +++-- c/stepA_mal.c | 19 +++-- chuck/step1_read_print.ck | 10 +-- chuck/step2_eval.ck | 10 +-- chuck/step3_env.ck | 10 +-- chuck/step4_if_fn_do.ck | 10 +-- chuck/step5_tco.ck | 10 +-- chuck/step6_file.ck | 10 +-- chuck/step7_quote.ck | 10 +-- chuck/step8_macros.ck | 10 +-- chuck/step9_try.ck | 12 +-- chuck/stepA_mal.ck | 12 +-- clojure/src/mal/step9_try.cljc | 6 +- clojure/src/mal/stepA_mal.cljc | 6 +- coffee/core.coffee | 2 +- coffee/step1_read_print.coffee | 4 +- coffee/step2_eval.coffee | 4 +- coffee/step3_env.coffee | 4 +- coffee/step4_if_fn_do.coffee | 4 +- coffee/step5_tco.coffee | 4 +- coffee/step6_file.coffee | 4 +- coffee/step7_quote.coffee | 4 +- coffee/step8_macros.coffee | 4 +- coffee/step9_try.coffee | 11 ++- coffee/stepA_mal.coffee | 11 ++- common-lisp/src/step9_try.lisp | 9 ++- common-lisp/src/stepA_mal.lisp | 9 ++- cpp/Reader.cpp | 10 +-- cpp/step9_try.cpp | 5 +- cpp/stepA_mal.cpp | 5 +- crystal/step1_read_print.cr | 4 +- crystal/step2_eval.cr | 4 +- crystal/step3_env.cr | 4 +- crystal/step4_if_fn_do.cr | 4 +- crystal/step5_tco.cr | 4 +- crystal/step6_file.cr | 4 +- crystal/step7_quote.cr | 4 +- crystal/step8_macros.cr | 4 +- crystal/step9_try.cr | 4 +- crystal/stepA_mal.cr | 4 +- d/step9_try.d | 4 + d/stepA_mal.d | 4 + dart/core.dart | 2 +- dart/step1_read_print.dart | 11 +-- dart/step2_eval.dart | 21 ++--- dart/step3_env.dart | 21 ++--- dart/step4_if_fn_do.dart | 24 +++--- dart/step5_tco.dart | 24 +++--- dart/step6_file.dart | 24 +++--- dart/step7_quote.dart | 24 +++--- dart/step8_macros.dart | 26 +++---- dart/step9_try.dart | 30 ++++--- dart/stepA_mal.dart | 30 ++++--- dart/types.dart | 8 -- elm/step2_eval.elm | 2 +- elm/step3_env.elm | 2 +- elm/step4_if_fn_do.elm | 2 +- elm/step5_tco.elm | 2 +- elm/step6_file.elm | 2 +- elm/step7_quote.elm | 2 +- elm/step8_macros.elm | 2 +- elm/step9_try.elm | 2 +- elm/stepA_mal.elm | 2 +- erlang/src/step9_try.erl | 3 +- erlang/src/stepA_mal.erl | 3 +- es6/step1_read_print.mjs | 4 +- es6/step2_eval.mjs | 4 +- es6/step3_env.mjs | 4 +- es6/step4_if_fn_do.mjs | 4 +- es6/step5_tco.mjs | 4 +- es6/step6_file.mjs | 4 +- es6/step7_quote.mjs | 4 +- es6/step8_macros.mjs | 4 +- es6/step9_try.mjs | 4 +- es6/stepA_mal.mjs | 4 +- factor/lib/reader/reader.factor | 2 +- .../step1_read_print/step1_read_print.factor | 6 +- factor/step2_eval/step2_eval.factor | 6 +- factor/step3_env/step3_env.factor | 6 +- factor/step4_if_fn_do/step4_if_fn_do.factor | 6 +- factor/step5_tco/step5_tco.factor | 6 +- factor/step6_file/step6_file.factor | 6 +- factor/step7_quote/step7_quote.factor | 6 +- factor/step8_macros/step8_macros.factor | 6 +- factor/step9_try/step9_try.factor | 14 +++- fsharp/step1_read_print.fs | 14 ++-- fsharp/step2_eval.fs | 42 ++++------ fsharp/step3_env.fs | 30 +++---- fsharp/step4_if_fn_do.fs | 30 +++---- fsharp/step5_tco.fs | 30 +++---- fsharp/step6_file.fs | 30 +++---- fsharp/step7_quote.fs | 30 +++---- fsharp/step8_macros.fs | 30 +++---- fsharp/step9_try.fs | 35 ++++----- fsharp/stepA_mal.fs | 35 ++++----- gnu-smalltalk/step9_try.st | 3 + gnu-smalltalk/stepA_mal.st | 3 + groovy/step1_read_print.groovy | 2 +- groovy/step2_eval.groovy | 2 +- groovy/step3_env.groovy | 2 +- groovy/step4_if_fn_do.groovy | 2 +- groovy/step5_tco.groovy | 2 +- groovy/step6_file.groovy | 2 +- groovy/step7_quote.groovy | 2 +- groovy/step8_macros.groovy | 2 +- groovy/step9_try.groovy | 2 +- groovy/stepA_mal.groovy | 2 +- guile/step0_repl.scm | 14 +++- guile/step1_read_print.scm | 19 +++-- guile/step2_eval.scm | 30 ++++--- guile/step3_env.scm | 38 ++++----- guile/step4_if_fn_do.scm | 49 ++++++------ guile/step5_tco.scm | 73 +++++++++--------- guile/step6_file.scm | 52 ++++++------- guile/step7_quote.scm | 61 +++++++-------- guile/step8_macros.scm | 51 ++++++------ guile/step9_try.scm | 64 ++++++++------- guile/stepA_mal.scm | 53 +++++-------- haxe/Step0_repl.hx | 2 +- haxe/Step1_read_print.hx | 2 +- haxe/Step2_eval.hx | 2 +- haxe/Step3_env.hx | 2 +- haxe/Step4_if_fn_do.hx | 7 +- haxe/Step5_tco.hx | 7 +- haxe/Step6_file.hx | 7 +- haxe/Step7_quote.hx | 7 +- haxe/Step8_macros.hx | 7 +- haxe/Step9_try.hx | 6 +- haxe/StepA_mal.hx | 6 +- hy/step1_read_print.hy | 2 +- hy/step2_eval.hy | 2 +- hy/step3_env.hy | 2 +- hy/step4_if_fn_do.hy | 10 ++- hy/step5_tco.hy | 10 ++- hy/step6_file.hy | 10 ++- hy/step7_quote.hy | 10 ++- hy/step8_macros.hy | 10 ++- hy/step9_try.hy | 11 ++- hy/stepA_mal.hy | 11 ++- io/step4_if_fn_do.io | 5 +- io/step5_tco.io | 5 +- io/step6_file.io | 5 +- io/step7_quote.io | 5 +- io/step8_macros.io | 5 +- io/step9_try.io | 6 +- io/stepA_mal.io | 6 +- js/step0_repl.js | 8 +- js/step1_read_print.js | 6 +- js/step2_eval.js | 6 +- js/step3_env.js | 6 +- js/step4_if_fn_do.js | 6 +- js/step5_tco.js | 6 +- js/step6_file.js | 6 +- js/step7_quote.js | 6 +- js/step8_macros.js | 6 +- js/step9_try.js | 6 +- js/stepA_mal.js | 6 +- livescript/step3_env.ls | 6 +- livescript/step4_if_fn_do.ls | 8 +- livescript/step5_tco.ls | 8 +- livescript/step6_file.ls | 8 +- livescript/step7_quote.ls | 8 +- livescript/step8_macros.ls | 8 +- livescript/step9_try.ls | 16 ++-- livescript/stepA_mal.ls | 14 ++-- matlab/core.m | 18 ++++- matlab/step9_try.m | 2 +- matlab/stepA_mal.m | 2 +- miniMAL/step4_if_fn_do.json | 5 +- miniMAL/step5_tco.json | 5 +- miniMAL/step6_file.json | 5 +- miniMAL/step7_quote.json | 5 +- miniMAL/step8_macros.json | 5 +- miniMAL/step9_try.json | 11 ++- miniMAL/stepA_mal.json | 11 ++- nasm/step9_try.asm | 5 ++ nasm/stepA_mal.asm | 5 ++ nim/step9_try.nim | 15 ++-- nim/stepA_mal.nim | 6 ++ objc/step4_if_fn_do.m | 3 + objc/step5_tco.m | 3 + objc/step6_file.m | 3 + objc/step7_quote.m | 3 + objc/step8_macros.m | 3 + objc/step9_try.m | 3 + objc/stepA_mal.m | 3 + objpascal/step9_try.pas | 5 +- objpascal/stepA_mal.pas | 5 +- ocaml/core.ml | 3 +- ocaml/step9_try.ml | 8 +- ocaml/stepA_mal.ml | 8 +- perl/step9_try.pl | 8 +- perl/stepA_mal.pl | 8 +- perl6/step9_try.pl | 4 +- perl6/stepA_mal.pl | 4 +- php/step9_try.php | 2 + php/stepA_mal.php | 2 + plsql/step9_try.sql | 6 +- plsql/stepA_mal.sql | 6 +- ps/core.ps | Bin 8534 -> 8751 bytes ps/step9_try.ps | Bin 8862 -> 9144 bytes ps/stepA_mal.ps | Bin 9490 -> 9772 bytes python/core.py | 4 +- python/mal_types.py | 13 +++- python/step9_try.py | 15 +++- python/stepA_mal.py | 15 +++- r/step9_try.r | 2 +- r/stepA_mal.r | 2 +- rpython/step9_try.py | 2 + rpython/stepA_mal.py | 2 + ruby/step9_try.rb | 6 +- ruby/stepA_mal.rb | 6 +- scheme/step4_if_fn_do.scm | 6 +- scheme/step5_tco.scm | 6 +- scheme/step6_file.scm | 6 +- scheme/step7_quote.scm | 6 +- scheme/step8_macros.scm | 6 +- scheme/step9_try.scm | 28 ++++--- scheme/stepA_mal.scm | 28 ++++--- swift3/Sources/step4_if_fn_do/main.swift | 2 + swift3/Sources/step5_tco/main.swift | 2 + swift3/Sources/step6_file/main.swift | 2 + swift3/Sources/step7_quote/main.swift | 2 + swift3/Sources/step8_macros/main.swift | 2 + swift3/Sources/step9_try/main.swift | 2 + swift3/Sources/stepA_mal/main.swift | 2 + tcl/step9_try.tcl | 7 +- tcl/stepA_mal.tcl | 7 +- tests/step9_try.mal | 18 +++++ ts/Makefile | 2 +- ts/step4_if_fn_do.ts | 10 ++- ts/step5_tco.ts | 10 ++- ts/step6_file.ts | 10 ++- ts/step7_quote.ts | 10 ++- ts/step8_macros.ts | 10 ++- ts/step9_try.ts | 11 ++- ts/stepA_mal.ts | 11 ++- vb/step9_try.vb | 2 +- vb/stepA_mal.vb | 2 +- vimscript/step9_try.vim | 6 +- vimscript/stepA_mal.vim | 6 +- wasm/step4_if_fn_do.wam | 11 ++- wasm/step5_tco.wam | 11 ++- wasm/step6_file.wam | 13 +++- wasm/step7_quote.wam | 13 +++- wasm/step8_macros.wam | 13 +++- wasm/step9_try.wam | 13 +++- wasm/stepA_mal.wam | 13 +++- yorick/step9_try.i | 11 ++- yorick/stepA_mal.i | 14 +++- 270 files changed, 1527 insertions(+), 1144 deletions(-) diff --git a/ada/core.adb b/ada/core.adb index 3f9e590ca1..69fd5ae317 100644 --- a/ada/core.adb +++ b/ada/core.adb @@ -193,7 +193,7 @@ package body Core is New_Val := Deref_Lambda (Func_Param).Apply (Param_List); when Func => New_Val := Deref_Func (Func_Param).Call_Func (Param_List); - when others => raise Mal_Exception with "Swap with bad func"; + when others => raise Runtime_Exception with "Swap with bad func"; end case; Deref_Atom (Atom_Param).Set_Atom (New_Val); return New_Val; @@ -272,7 +272,7 @@ package body Core is when Nil => return Null_List (List_List); when others => null; end case; - raise Evaluation_Error with "Expecting a List"; + raise Runtime_Exception with "Expecting a List"; return Null_List (List_List); end Eval_As_List; @@ -449,14 +449,14 @@ package body Core is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; end; else -- neither a Lambda or a Func - raise Mal_Exception; + raise Runtime_Exception with "Deref called on non-Func/Lambda"; end if; end Apply; @@ -938,7 +938,7 @@ package body Core is Rest_List := Deref_List (Cdr (Rest_List)).all; end loop; return Res; - when Hashed_List => raise Mal_Exception with "Conj on Hashed_Map"; + when Hashed_List => raise Runtime_Exception with "Conj on Hashed_Map"; end case; end Conj; @@ -964,7 +964,7 @@ package body Core is else return Vector.Duplicate (Vector.Deref_Vector (First_Param).all); end if; - when others => raise Mal_Exception; + when others => raise Runtime_Exception; end case; when Str => declare @@ -984,7 +984,7 @@ package body Core is return Res; end if; end; - when others => raise Mal_Exception; + when others => raise Runtime_Exception; end case; end Seq; diff --git a/ada/step4_if_fn_do.adb b/ada/step4_if_fn_do.adb index 3fafd98b30..d41e9bc084 100644 --- a/ada/step4_if_fn_do.adb +++ b/ada/step4_if_fn_do.adb @@ -248,7 +248,6 @@ procedure Step4_If_Fn_Do is return Printer.Pr_Str (Param); end Print; - function Rep (Param : String; Env : Envs.Env_Handle) return String is AST, Evaluated_AST : Types.Mal_Handle; begin @@ -312,7 +311,13 @@ begin when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end Step4_If_Fn_Do; diff --git a/ada/step5_tco.adb b/ada/step5_tco.adb index a0f76098f4..2234b21309 100644 --- a/ada/step5_tco.adb +++ b/ada/step5_tco.adb @@ -278,7 +278,7 @@ procedure Step5_TCO is end if; - else + else -- Not a List_List return Eval_Ast (Param, Env); @@ -293,20 +293,21 @@ procedure Step5_TCO is end Print; function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; + AST, Evaluated_AST : Types.Mal_Handle; begin - AST := Read (Param); + AST := Read (Param); - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; end Rep; + Repl_Env : Envs.Env_Handle; @@ -364,7 +365,13 @@ begin when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end Step5_TCO; diff --git a/ada/step6_file.adb b/ada/step6_file.adb index 40ba474415..dbf65347ef 100644 --- a/ada/step6_file.adb +++ b/ada/step6_file.adb @@ -9,10 +9,8 @@ with Reader; with Smart_Pointers; with Types; - procedure Step6_File is - use Types; @@ -269,21 +267,21 @@ procedure Step6_File is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; end; else -- neither a Lambda or a Func - raise Mal_Exception; + raise Runtime_Exception with "Deref called on non-Func/Lambda"; end if; end; end if; - else + else -- not a List_List return Eval_Ast (Param, Env); @@ -297,7 +295,6 @@ procedure Step6_File is return Printer.Pr_Str (Param); end Print; - function Rep (Param : String; Env : Envs.Env_Handle) return String is AST, Evaluated_AST : Types.Mal_Handle; begin @@ -352,6 +349,8 @@ begin Repl_Env := Envs.New_Env; + -- Core init also creates the first environment. + -- This is needed for the def!'s below. Core.Init (Repl_Env); -- Register the eval command. This needs to be done here rather than Core.Init @@ -359,7 +358,6 @@ begin Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))"); -- Command line processing. @@ -399,7 +397,13 @@ begin when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end if; diff --git a/ada/step7_quote.adb b/ada/step7_quote.adb index 70b2544633..848142ae7d 100644 --- a/ada/step7_quote.adb +++ b/ada/step7_quote.adb @@ -101,8 +101,6 @@ procedure Step7_Quote is end Eval_Ast; - - function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is Res, First_Elem, FE_0 : Mal_Handle; L : List_Ptr; @@ -360,21 +358,21 @@ procedure Step7_Quote is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; end; else -- neither a Lambda or a Func - raise Mal_Exception; + raise Runtime_Exception with "Deref called on non-Func/Lambda"; end if; end; end if; - else + else -- not a List_List return Eval_Ast (Param, Env); @@ -451,9 +449,10 @@ begin Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))"); + -- Command line processing. + Cmd_Args := 0; Command_Args := Types.New_List_Mal_Type (Types.List_List); Command_List := Types.Deref_List (Command_Args); @@ -489,7 +488,13 @@ begin when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end if; diff --git a/ada/step8_macros.adb b/ada/step8_macros.adb index 2c68e57a73..25cc8f42b7 100644 --- a/ada/step8_macros.adb +++ b/ada/step8_macros.adb @@ -434,21 +434,21 @@ procedure Step8_Macros is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; end; else -- neither a Lambda or a Func - raise Mal_Exception; + raise Runtime_Exception with "Deref called on non-Func/Lambda"; end if; end; end if; - else + else -- not a List_List return Eval_Ast (Param, Env); @@ -529,6 +529,8 @@ begin RE ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons 'cond (rest (rest xs)))))))"); RE ("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"); + -- Command line processing. + Cmd_Args := 0; Command_Args := Types.New_List_Mal_Type (Types.List_List); Command_List := Types.Deref_List (Command_Args); @@ -558,13 +560,19 @@ begin loop begin Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_Line; + exit when Ada.Text_IO.End_Of_File; Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); exception when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end if; diff --git a/ada/step9_try.adb b/ada/step9_try.adb index 4ea09c386a..bd7fcd5c12 100644 --- a/ada/step9_try.adb +++ b/ada/step9_try.adb @@ -423,6 +423,9 @@ procedure Step9_Try is elsif Deref (First_Param).Sym_Type = Sym and then Deref_Sym (First_Param).Get_Sym = "try*" then + if Length (Rest_List) = 1 then + return Eval (Car (Rest_List), Env); + end if; declare Res : Mal_Handle; begin @@ -484,14 +487,14 @@ procedure Step9_Try is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; end; else -- neither a Lambda or a Func - raise Mal_Exception; + raise Runtime_Exception with "Deref called on non-Func/Lambda"; end if; end; @@ -579,6 +582,8 @@ begin RE ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons 'cond (rest (rest xs)))))))"); RE ("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"); + -- Command line processing. + Cmd_Args := 0; Command_Args := Types.New_List_Mal_Type (Types.List_List); Command_List := Types.Deref_List (Command_Args); @@ -614,7 +619,13 @@ begin when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end if; diff --git a/ada/stepa_mal.adb b/ada/stepa_mal.adb index 0b015b28d9..e49dae65ae 100644 --- a/ada/stepa_mal.adb +++ b/ada/stepa_mal.adb @@ -423,6 +423,9 @@ procedure StepA_Mal is elsif Deref (First_Param).Sym_Type = Sym and then Deref_Sym (First_Param).Get_Sym = "try*" then + if Length (Rest_List) = 1 then + return Eval (Car (Rest_List), Env); + end if; declare Res : Mal_Handle; begin @@ -484,14 +487,14 @@ procedure StepA_Mal is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; end; else -- neither a Lambda or a Func - raise Mal_Exception; + raise Runtime_Exception with "Deref called on non-Func/Lambda"; end if; end; @@ -512,19 +515,18 @@ procedure StepA_Mal is return Printer.Pr_Str (Param); end Print; - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; + AST, Evaluated_AST : Types.Mal_Handle; begin - AST := Read (Param); + AST := Read (Param); - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; end Rep; @@ -558,10 +560,8 @@ procedure StepA_Mal is Command_List : Types.List_Ptr; File_Processed : Boolean := False; - begin - -- Save a function pointer back to the Eval function. -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK -- as we know Eval will be in scope for the lifetime of the program. @@ -584,6 +584,8 @@ begin RE ("(def! gensym (fn* [] (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"); RE ("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"); + -- Command line processing. + Cmd_Args := 0; Command_Args := Types.New_List_Mal_Type (Types.List_List); Command_List := Types.Deref_List (Command_Args); @@ -620,7 +622,13 @@ begin when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; end; end loop; end if; diff --git a/ada/types-vector.adb b/ada/types-vector.adb index 3d1ae0403a..b4dc70f56e 100644 --- a/ada/types-vector.adb +++ b/ada/types-vector.adb @@ -91,7 +91,7 @@ package body Types.Vector is overriding function Nth (L : Vector_Mal_Type; N : Natural) return Mal_Handle is begin if N >= L.Length then - raise Mal_Exception with "Nth (vector): Index out of range"; + raise Runtime_Exception with "Nth (vector): Index out of range"; else return Mal_Vectors.Element (L.Vec, Vec_Index (N)); end if; diff --git a/ada/types.adb b/ada/types.adb index 56eba7476f..29b8d2b181 100644 --- a/ada/types.adb +++ b/ada/types.adb @@ -841,7 +841,7 @@ package body Types is end loop; - raise Mal_Exception with "Nth (list): Index out of range"; + raise Runtime_Exception with "Nth (list): Index out of range"; end Nth; @@ -1064,7 +1064,7 @@ package body Types is else - raise Mal_Exception with "Bind failed in Apply"; + raise Runtime_Exception with "Bind failed in Apply"; end if; diff --git a/ada/types.ads b/ada/types.ads index d2a52fd7a8..8329453bca 100644 --- a/ada/types.ads +++ b/ada/types.ads @@ -311,6 +311,8 @@ package Types is with function Float_Rel_Op (A, B : Mal_Float) return Boolean; function Rel_Op (A, B : Mal_Handle) return Mal_Handle; + Runtime_Exception : exception; + Mal_Exception : exception; -- So tempting to call this Mal_Function but... Mal_Exception_Value : Mal_Handle; -- Used by mal's throw command diff --git a/c/step0_repl.c b/c/step0_repl.c index af69bd6ea9..ddb7f6e2b7 100644 --- a/c/step0_repl.c +++ b/c/step0_repl.c @@ -32,13 +32,13 @@ int main() // Set the initial prompt snprintf(prompt, sizeof(prompt), "user> "); - + for(;;) { ast = READ(prompt); if (!ast) return 0; exp = EVAL(ast, NULL); puts(PRINT(exp)); - + free(ast); // Free input string } } diff --git a/c/step1_read_print.c b/c/step1_read_print.c index 215624e422..cdc45cd441 100644 --- a/c/step1_read_print.c +++ b/c/step1_read_print.c @@ -34,9 +34,6 @@ MalVal *EVAL(MalVal *ast, GHashTable *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -66,7 +63,7 @@ int main() // Set the initial prompt snprintf(prompt, sizeof(prompt), "user> "); - + // repl loop for(;;) { exp = RE(NULL, prompt, NULL); @@ -75,7 +72,11 @@ int main() } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step2_eval.c b/c/step2_eval.c index d075842455..8c54184c05 100644 --- a/c/step2_eval.c +++ b/c/step2_eval.c @@ -87,9 +87,6 @@ MalVal *EVAL(MalVal *ast, GHashTable *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -137,7 +134,7 @@ int main() // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(); - + // repl loop for(;;) { exp = RE(repl_env, prompt, NULL); @@ -146,7 +143,11 @@ int main() } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step3_env.c b/c/step3_env.c index ba932792ea..d51704e053 100644 --- a/c/step3_env.c +++ b/c/step3_env.c @@ -112,9 +112,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -162,7 +159,7 @@ int main() // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(); - + // repl loop for(;;) { exp = RE(repl_env, prompt, NULL); @@ -171,7 +168,11 @@ int main() } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step4_if_fn_do.c b/c/step4_if_fn_do.c index efe45e2c82..c6628c16c2 100644 --- a/c/step4_if_fn_do.c +++ b/c/step4_if_fn_do.c @@ -149,9 +149,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -200,7 +197,7 @@ int main() // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(); - + // repl loop for(;;) { exp = RE(repl_env, prompt, NULL); @@ -209,7 +206,11 @@ int main() } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step5_tco.c b/c/step5_tco.c index 094e87e976..917e3e3807 100644 --- a/c/step5_tco.c +++ b/c/step5_tco.c @@ -162,9 +162,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -213,7 +210,7 @@ int main() // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(); - + // repl loop for(;;) { exp = RE(repl_env, prompt, NULL); @@ -222,7 +219,11 @@ int main() } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step6_file.c b/c/step6_file.c index 588e2c932c..2feb873ca9 100644 --- a/c/step6_file.c +++ b/c/step6_file.c @@ -162,9 +162,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -227,7 +224,7 @@ int main(int argc, char *argv[]) // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(argc, argv); - + if (argc > 1) { char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); RE(repl_env, "", cmd); @@ -242,7 +239,11 @@ int main(int argc, char *argv[]) } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step7_quote.c b/c/step7_quote.c index ac8d825621..2a601b99aa 100644 --- a/c/step7_quote.c +++ b/c/step7_quote.c @@ -199,9 +199,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -264,7 +261,7 @@ int main(int argc, char *argv[]) // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(argc, argv); - + if (argc > 1) { char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); RE(repl_env, "", cmd); @@ -279,7 +276,11 @@ int main(int argc, char *argv[]) } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step8_macros.c b/c/step8_macros.c index 01aac07447..335642ba85 100644 --- a/c/step8_macros.c +++ b/c/step8_macros.c @@ -65,7 +65,7 @@ int is_macro_call(MalVal *ast, Env *env) { env_find(env, a0) && env_get(env, a0)->ismacro; } - + MalVal *macroexpand(MalVal *ast, Env *env) { if (!ast || mal_error) return NULL; while (is_macro_call(ast, env)) { @@ -241,9 +241,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -308,7 +305,7 @@ int main(int argc, char *argv[]) // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(argc, argv); - + if (argc > 1) { char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); RE(repl_env, "", cmd); @@ -323,7 +320,11 @@ int main(int argc, char *argv[]) } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/step9_try.c b/c/step9_try.c index 4f40fa50a3..9c555aca1f 100644 --- a/c/step9_try.c +++ b/c/step9_try.c @@ -66,7 +66,7 @@ int is_macro_call(MalVal *ast, Env *env) { env_find(env, a0) && env_get(env, a0)->ismacro; } - + MalVal *macroexpand(MalVal *ast, Env *env) { if (!ast || mal_error) return NULL; while (is_macro_call(ast, env)) { @@ -189,8 +189,11 @@ MalVal *EVAL(MalVal *ast, Env *env) { strcmp("try*", a0->val.string) == 0) { //g_print("eval apply try*\n"); MalVal *a1 = _nth(ast, 1); - MalVal *a2 = _nth(ast, 2); MalVal *res = EVAL(a1, env); + if (ast->val.array->len < 3) { + return &mal_nil; + } + MalVal *a2 = _nth(ast, 2); if (!mal_error) { return res; } MalVal *a20 = _nth(a2, 0); if (strcmp("catch*", a20->val.string) == 0) { @@ -263,9 +266,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -330,7 +330,7 @@ int main(int argc, char *argv[]) // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(argc, argv); - + if (argc > 1) { char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); RE(repl_env, "", cmd); @@ -345,7 +345,11 @@ int main(int argc, char *argv[]) } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/c/stepA_mal.c b/c/stepA_mal.c index c9237f3895..736eb0964d 100644 --- a/c/stepA_mal.c +++ b/c/stepA_mal.c @@ -66,7 +66,7 @@ int is_macro_call(MalVal *ast, Env *env) { env_find(env, a0) && env_get(env, a0)->ismacro; } - + MalVal *macroexpand(MalVal *ast, Env *env) { if (!ast || mal_error) return NULL; while (is_macro_call(ast, env)) { @@ -194,8 +194,11 @@ MalVal *EVAL(MalVal *ast, Env *env) { strcmp("try*", a0->val.string) == 0) { //g_print("eval apply try*\n"); MalVal *a1 = _nth(ast, 1); - MalVal *a2 = _nth(ast, 2); MalVal *res = EVAL(a1, env); + if (ast->val.array->len < 3) { + return &mal_nil; + } + MalVal *a2 = _nth(ast, 2); if (!mal_error) { return res; } MalVal *a20 = _nth(a2, 0); if (strcmp("catch*", a20->val.string) == 0) { @@ -268,9 +271,6 @@ MalVal *EVAL(MalVal *ast, Env *env) { // print char *PRINT(MalVal *exp) { if (mal_error) { - fprintf(stderr, "Error: %s\n", mal_error->val.string); - malval_free(mal_error); - mal_error = NULL; return NULL; } return _pr_str(exp,1); @@ -292,6 +292,7 @@ MalVal *RE(Env *env, char *prompt, char *str) { // Setup the initial REPL environment Env *repl_env; + MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } void init_repl_env(int argc, char *argv[]) { @@ -337,7 +338,7 @@ int main(int argc, char *argv[]) // Set the initial prompt and environment snprintf(prompt, sizeof(prompt), "user> "); init_repl_env(argc, argv); - + if (argc > 1) { char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); RE(repl_env, "", cmd); @@ -353,7 +354,11 @@ int main(int argc, char *argv[]) } output = PRINT(exp); - if (output) { + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { puts(output); MAL_GC_FREE(output); // Free output string } diff --git a/chuck/step1_read_print.ck b/chuck/step1_read_print.ck index b173cf36c4..103d03ba9b 100644 --- a/chuck/step1_read_print.ck +++ b/chuck/step1_read_print.ck @@ -35,15 +35,7 @@ fun string PRINT(MalObject m) fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step2_eval.ck b/chuck/step2_eval.ck index d3753ae8ce..2d740a7467 100644 --- a/chuck/step2_eval.ck +++ b/chuck/step2_eval.ck @@ -138,15 +138,7 @@ new MalDiv @=> repl_env["/"]; fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step3_env.ck b/chuck/step3_env.ck index 7c0bb7cd31..ad8de3c7bd 100644 --- a/chuck/step3_env.ck +++ b/chuck/step3_env.ck @@ -167,15 +167,7 @@ repl_env.set("/", new MalDiv); fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step4_if_fn_do.ck b/chuck/step4_if_fn_do.ck index 16a4cd91e5..dd6c92507e 100644 --- a/chuck/step4_if_fn_do.ck +++ b/chuck/step4_if_fn_do.ck @@ -236,15 +236,7 @@ for( 0 => int i; i < Core.names.size(); i++ ) fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step5_tco.ck b/chuck/step5_tco.ck index cc07f5f780..33be7e9c18 100644 --- a/chuck/step5_tco.ck +++ b/chuck/step5_tco.ck @@ -242,15 +242,7 @@ for( 0 => int i; i < Core.names.size(); i++ ) fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step6_file.ck b/chuck/step6_file.ck index f9c5a4b583..5d1c55f8fc 100644 --- a/chuck/step6_file.ck +++ b/chuck/step6_file.ck @@ -286,15 +286,7 @@ repl_env.set("*ARGV*", MalList.create(MalArgv(args))); fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step7_quote.ck b/chuck/step7_quote.ck index d1aef647e7..6470456a3d 100644 --- a/chuck/step7_quote.ck +++ b/chuck/step7_quote.ck @@ -341,15 +341,7 @@ repl_env.set("*ARGV*", MalList.create(MalArgv(args))); fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step8_macros.ck b/chuck/step8_macros.ck index 09b3a54ffe..f52e0de4a7 100644 --- a/chuck/step8_macros.ck +++ b/chuck/step8_macros.ck @@ -412,15 +412,7 @@ repl_env.set("*ARGV*", MalList.create(MalArgv(args))); fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/step9_try.ck b/chuck/step9_try.ck index c040462929..539d1d8fd1 100644 --- a/chuck/step9_try.ck +++ b/chuck/step9_try.ck @@ -212,7 +212,7 @@ fun MalObject EVAL(MalObject m, Env env) { EVAL(ast[1], env) @=> MalObject value; - if( value.type != "error" ) + if( (value.type != "error") || (ast.size() < 3) ) { return value; } @@ -429,15 +429,7 @@ repl_env.set("*ARGV*", MalList.create(MalArgv(args))); fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/chuck/stepA_mal.ck b/chuck/stepA_mal.ck index 59accd51b1..5c73489feb 100644 --- a/chuck/stepA_mal.ck +++ b/chuck/stepA_mal.ck @@ -212,7 +212,7 @@ fun MalObject EVAL(MalObject m, Env env) { EVAL(ast[1], env) @=> MalObject value; - if( value.type != "error" ) + if( (value.type != "error") || (ast.size() < 3) ) { return value; } @@ -431,15 +431,7 @@ repl_env.set("*host-language*", MalString.create("chuck")); fun string errorMessage(MalObject m) { (m$MalError).value() @=> MalObject value; - - if( value.type == "string" ) - { - return Printer.pr_str(value, false); - } - else - { - return "exception: " + Printer.pr_str(value, true); - } + return "exception: " + Printer.pr_str(value, true); } fun string rep(string input) diff --git a/clojure/src/mal/step9_try.cljc b/clojure/src/mal/step9_try.cljc index 529c41c2ab..2e0b91c75d 100644 --- a/clojure/src/mal/step9_try.cljc +++ b/clojure/src/mal/step9_try.cljc @@ -109,7 +109,8 @@ (catch #?(:clj Throwable :cljs :default) t (EVAL (nth a2 2) (env/env env [(nth a2 1)] - [#?(:clj (.getMessage t) + [#?(:clj (or (.getMessage t) + (.toString t)) :cljs (.-message t))])))) (EVAL a1 env)) @@ -169,6 +170,9 @@ (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment (try (println (rep line)) + #?(:cljs (catch ExceptionInfo e + (println "Error:" (or (:data (ex-data e)) + (.-stack e))))) #?(:clj (catch Throwable e (clojure.repl/pst e)) :cljs (catch js/Error e (println (.-stack e)))))) (recur)))) diff --git a/clojure/src/mal/stepA_mal.cljc b/clojure/src/mal/stepA_mal.cljc index 5dd7508fcc..efa7494684 100644 --- a/clojure/src/mal/stepA_mal.cljc +++ b/clojure/src/mal/stepA_mal.cljc @@ -117,7 +117,8 @@ (catch #?(:clj Throwable :cljs :default) t (EVAL (nth a2 2) (env/env env [(nth a2 1)] - [#?(:clj (.getMessage t) + [#?(:clj (or (.getMessage t) + (.toString t)) :cljs (.-message t))])))) (EVAL a1 env)) @@ -181,6 +182,9 @@ (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment (try (println (rep line)) + #?(:cljs (catch ExceptionInfo e + (println "Error:" (or (:data (ex-data e)) + (.-stack e))))) #?(:clj (catch Throwable e (clojure.repl/pst e)) :cljs (catch js/Error e (println (.-stack e)))))) (recur)))) diff --git a/coffee/core.coffee b/coffee/core.coffee index 518a4c8259..4339beed7a 100644 --- a/coffee/core.coffee +++ b/coffee/core.coffee @@ -38,7 +38,7 @@ with_meta = (obj,m) -> exports.ns = { '=': (a,b) -> types._equal_Q(a,b), - 'throw': (a) -> throw a, + 'throw': (a) -> throw {"object": a}, 'nil?': types._nil_Q, 'true?': types._true_Q, 'false?': types._false_Q, diff --git a/coffee/step1_read_print.coffee b/coffee/step1_read_print.coffee index d5ab6b7a1b..df5cf74855 100644 --- a/coffee/step1_read_print.coffee +++ b/coffee/step1_read_print.coffee @@ -23,7 +23,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step2_eval.coffee b/coffee/step2_eval.coffee index a6fe840a1e..8e82ba28d5 100644 --- a/coffee/step2_eval.coffee +++ b/coffee/step2_eval.coffee @@ -49,7 +49,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step3_env.coffee b/coffee/step3_env.coffee index 254c2bee95..9dac61a897 100644 --- a/coffee/step3_env.coffee +++ b/coffee/step3_env.coffee @@ -60,7 +60,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step4_if_fn_do.coffee b/coffee/step4_if_fn_do.coffee index f4e0c45662..2210aa3409 100644 --- a/coffee/step4_if_fn_do.coffee +++ b/coffee/step4_if_fn_do.coffee @@ -73,7 +73,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step5_tco.coffee b/coffee/step5_tco.coffee index 1541d468ef..9ed9ce8364 100644 --- a/coffee/step5_tco.coffee +++ b/coffee/step5_tco.coffee @@ -79,7 +79,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step6_file.coffee b/coffee/step6_file.coffee index ed6481f7f7..b1b786c1fb 100644 --- a/coffee/step6_file.coffee +++ b/coffee/step6_file.coffee @@ -87,7 +87,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step7_quote.coffee b/coffee/step7_quote.coffee index 1304c8fde4..bde2a8790c 100644 --- a/coffee/step7_quote.coffee +++ b/coffee/step7_quote.coffee @@ -103,7 +103,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step8_macros.coffee b/coffee/step8_macros.coffee index fe4d06bb7e..3b552f8d54 100644 --- a/coffee/step8_macros.coffee +++ b/coffee/step8_macros.coffee @@ -123,7 +123,7 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? then console.log exc.stack + else console.log exc # vim: ts=2:sw=2 diff --git a/coffee/step9_try.coffee b/coffee/step9_try.coffee index a73f5d40ff..d5bbe010a3 100644 --- a/coffee/step9_try.coffee +++ b/coffee/step9_try.coffee @@ -75,7 +75,8 @@ EVAL = (ast, env) -> try return EVAL(a1, env) catch exc if a2 && a2[0].name == "catch*" - if exc instanceof Error then exc = exc.message + if exc.object? then exc = exc.object + else exc = exc.message return EVAL a2[2], new Env(env, [a2[1]], [exc]) else throw exc @@ -131,7 +132,11 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? + console.log exc.stack + else if exc.object? + console.log "Error:", printer._pr_str exc.object, true + else + console.log exc # vim: ts=2:sw=2 diff --git a/coffee/stepA_mal.coffee b/coffee/stepA_mal.coffee index 3aeb455810..2780e84f70 100644 --- a/coffee/stepA_mal.coffee +++ b/coffee/stepA_mal.coffee @@ -75,7 +75,8 @@ EVAL = (ast, env) -> try return EVAL(a1, env) catch exc if a2 && a2[0].name == "catch*" - if exc instanceof Error then exc = exc.message + if exc.object? then exc = exc.object + else exc = exc.message return EVAL a2[2], new Env(env, [a2[1]], [exc]) else throw exc @@ -141,7 +142,11 @@ while (line = readline.readline("user> ")) != null continue if exc instanceof reader.BlankException if exc.stack? and exc.stack.length > 2000 console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? console.log exc.stack - else console.log exc + else if exc.stack? + console.log exc.stack + else if exc.object? + console.log "Error:", printer._pr_str exc.object, true + else + console.log exc # vim: ts=2:sw=2 diff --git a/common-lisp/src/step9_try.lisp b/common-lisp/src/step9_try.lisp index e6257a3900..87cc341f9b 100644 --- a/common-lisp/src/step9_try.lisp +++ b/common-lisp/src/step9_try.lisp @@ -195,10 +195,11 @@ (cons :is-macro nil)))))) ((mal-data-value= mal-try* (first forms)) - (handler-case - (return (mal-eval (second forms) env)) - (error (condition) - (when (third forms) + (if (not (third forms)) + (return (mal-eval (second forms) env)) + (handler-case + (return (mal-eval (second forms) env)) + (error (condition) (let ((catch-forms (mal-data-value (third forms)))) (when (mal-data-value= mal-catch* (first catch-forms)) diff --git a/common-lisp/src/stepA_mal.lisp b/common-lisp/src/stepA_mal.lisp index 73dc67cbef..3001b9d184 100644 --- a/common-lisp/src/stepA_mal.lisp +++ b/common-lisp/src/stepA_mal.lisp @@ -194,10 +194,11 @@ (cons :is-macro nil)))))) ((mal-data-value= mal-try* (first forms)) - (handler-case - (return (mal-eval (second forms) env)) - (error (condition) - (when (third forms) + (if (not (third forms)) + (return (mal-eval (second forms) env)) + (handler-case + (return (mal-eval (second forms) env)) + (error (condition) (let ((catch-forms (mal-data-value (third forms)))) (when (mal-data-value= mal-catch* (first catch-forms)) diff --git a/cpp/Reader.cpp b/cpp/Reader.cpp index cdb4e91078..dbcb6c9c83 100644 --- a/cpp/Reader.cpp +++ b/cpp/Reader.cpp @@ -98,10 +98,10 @@ void Tokeniser::nextToken() String mismatch(m_iter, m_end); if (mismatch[0] == '"') { - MAL_CHECK(false, "Expected \", got EOF"); + MAL_CHECK(false, "expected '\"', got EOF"); } else { - MAL_CHECK(false, "Unexpected \"%s\"", mismatch.c_str()); + MAL_CHECK(false, "unexpected '%s'", mismatch.c_str()); } } @@ -129,11 +129,11 @@ malValuePtr readStr(const String& input) static malValuePtr readForm(Tokeniser& tokeniser) { - MAL_CHECK(!tokeniser.eof(), "Expected form, got EOF"); + MAL_CHECK(!tokeniser.eof(), "expected form, got EOF"); String token = tokeniser.peek(); MAL_CHECK(!std::regex_match(token, closeRegex), - "Unexpected \"%s\"", token.c_str()); + "unexpected '%s'", token.c_str()); if (token == "(") { tokeniser.next(); @@ -213,7 +213,7 @@ static void readList(Tokeniser& tokeniser, malValueVec* items, const String& end) { while (1) { - MAL_CHECK(!tokeniser.eof(), "Expected \"%s\", got EOF", end.c_str()); + MAL_CHECK(!tokeniser.eof(), "expected '%s', got EOF", end.c_str()); if (tokeniser.peek() == end) { tokeniser.next(); return; diff --git a/cpp/step9_try.cpp b/cpp/step9_try.cpp index 17cf178cc0..62933bdfc5 100644 --- a/cpp/step9_try.cpp +++ b/cpp/step9_try.cpp @@ -50,8 +50,11 @@ static String safeRep(const String& input, malEnvPtr env) catch (malEmptyInputException&) { return String(); } + catch (malValuePtr& mv) { + return "Error: " + mv->print(true); + } catch (String& s) { - return s; + return "Error: " + s; }; } diff --git a/cpp/stepA_mal.cpp b/cpp/stepA_mal.cpp index 70ed6ac9a3..cda56f08cb 100644 --- a/cpp/stepA_mal.cpp +++ b/cpp/stepA_mal.cpp @@ -51,8 +51,11 @@ static String safeRep(const String& input, malEnvPtr env) catch (malEmptyInputException&) { return String(); } + catch (malValuePtr& mv) { + return "Error: " + mv->print(true); + } catch (String& s) { - return s; + return "Error: " + s; }; } diff --git a/crystal/step1_read_print.cr b/crystal/step1_read_print.cr index cdc05d57e1..4d7195895e 100755 --- a/crystal/step1_read_print.cr +++ b/crystal/step1_read_print.cr @@ -30,7 +30,9 @@ end while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step2_eval.cr b/crystal/step2_eval.cr index eeef93c360..fd441d33a6 100755 --- a/crystal/step2_eval.cr +++ b/crystal/step2_eval.cr @@ -89,7 +89,9 @@ REPL_ENV = { while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step3_env.cr b/crystal/step3_env.cr index 171dd89a2f..a740080439 100755 --- a/crystal/step3_env.cr +++ b/crystal/step3_env.cr @@ -112,7 +112,9 @@ end while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step4_if_fn_do.cr b/crystal/step4_if_fn_do.cr index c20f1300d2..f4a41da132 100755 --- a/crystal/step4_if_fn_do.cr +++ b/crystal/step4_if_fn_do.cr @@ -128,7 +128,9 @@ Mal.rep "(def! not (fn* (a) (if a false true)))" while line = Readline.readline("user> ") begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step5_tco.cr b/crystal/step5_tco.cr index e56db4a6b9..66f144bfe1 100755 --- a/crystal/step5_tco.cr +++ b/crystal/step5_tco.cr @@ -162,7 +162,9 @@ Mal.rep "(def! not (fn* (a) (if a false true)))" while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step6_file.cr b/crystal/step6_file.cr index 9997a2f7fa..12f60792ff 100755 --- a/crystal/step6_file.cr +++ b/crystal/step6_file.cr @@ -175,7 +175,9 @@ end while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step7_quote.cr b/crystal/step7_quote.cr index 92d2ab44ec..3cb80a6769 100755 --- a/crystal/step7_quote.cr +++ b/crystal/step7_quote.cr @@ -205,7 +205,9 @@ end while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step8_macros.cr b/crystal/step8_macros.cr index 061649b9af..f7b5cb39ce 100755 --- a/crystal/step8_macros.cr +++ b/crystal/step8_macros.cr @@ -250,7 +250,9 @@ end while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/step9_try.cr b/crystal/step9_try.cr index 4853cc80f3..99314c030a 100755 --- a/crystal/step9_try.cr +++ b/crystal/step9_try.cr @@ -267,7 +267,9 @@ end while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/crystal/stepA_mal.cr b/crystal/stepA_mal.cr index f71be26aa3..03727aff19 100755 --- a/crystal/stepA_mal.cr +++ b/crystal/stepA_mal.cr @@ -279,7 +279,9 @@ Mal.rep("(println (str \"Mal [\" *host-language* \"]\"))") while line = Readline.readline("user> ", true) begin puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" rescue e - STDERR.puts e + STDERR.puts "Error: #{e}" end end diff --git a/d/step9_try.d b/d/step9_try.d index 554831ffeb..9c378068e1 100644 --- a/d/step9_try.d +++ b/d/step9_try.d @@ -313,6 +313,10 @@ void main(string[] args) { writeln(rep(line, repl_env)); } + catch (MalException e) + { + writeln("Error: ", pr_str(e.data)); + } catch (Exception e) { writeln("Error: ", e.msg); diff --git a/d/stepA_mal.d b/d/stepA_mal.d index f1b42f12a4..1262d5fddd 100644 --- a/d/stepA_mal.d +++ b/d/stepA_mal.d @@ -317,6 +317,10 @@ void main(string[] args) { writeln(rep(line, repl_env)); } + catch (MalException e) + { + writeln("Error: ", pr_str(e.data)); + } catch (Exception e) { writeln("Error: ", e.msg); diff --git a/dart/core.dart b/dart/core.dart index 01462e603d..047ed82c43 100644 --- a/dart/core.dart +++ b/dart/core.dart @@ -131,7 +131,7 @@ Map ns = { try { return indexable[index.value]; } on RangeError catch (e) { - throw new MalNativeException(e); + throw new MalException(new MalString(e.toString())); } }), new MalSymbol('first'): new MalBuiltin((List args) { diff --git a/dart/step1_read_print.dart b/dart/step1_read_print.dart index 0799fa0aa3..5269bf2295 100644 --- a/dart/step1_read_print.dart +++ b/dart/step1_read_print.dart @@ -11,13 +11,7 @@ MalType EVAL(MalType x) => x; String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - return PRINT(EVAL(parsed)); + return PRINT(EVAL(READ(x))); } const prompt = 'user> '; @@ -29,6 +23,9 @@ main() { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step2_eval.dart b/dart/step2_eval.dart index cdc8870fd0..820c8d769f 100644 --- a/dart/step2_eval.dart +++ b/dart/step2_eval.dart @@ -60,20 +60,7 @@ EVAL(MalType ast, Map env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -85,6 +72,12 @@ main() { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step3_env.dart b/dart/step3_env.dart index 5df9a9d416..0c1a0af963 100644 --- a/dart/step3_env.dart +++ b/dart/step3_env.dart @@ -99,20 +99,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -125,6 +112,12 @@ main() { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step4_if_fn_do.dart b/dart/step4_if_fn_do.dart index 73bef70313..7559da64d2 100644 --- a/dart/step4_if_fn_do.dart +++ b/dart/step4_if_fn_do.dart @@ -112,20 +112,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -138,6 +125,15 @@ main() { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step5_tco.dart b/dart/step5_tco.dart index b8dd03b4a0..b2733a028e 100644 --- a/dart/step5_tco.dart +++ b/dart/step5_tco.dart @@ -127,20 +127,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -153,6 +140,15 @@ main() { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step6_file.dart b/dart/step6_file.dart index d4e5fb3a40..c33a17400d 100644 --- a/dart/step6_file.dart +++ b/dart/step6_file.dart @@ -134,20 +134,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -164,6 +151,15 @@ main(List args) { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step7_quote.dart b/dart/step7_quote.dart index a2b45f8b8e..02b07bb0b2 100644 --- a/dart/step7_quote.dart +++ b/dart/step7_quote.dart @@ -167,20 +167,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -197,6 +184,15 @@ main(List args) { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step8_macros.dart b/dart/step8_macros.dart index 558b0fd91b..de9fbbf0d7 100644 --- a/dart/step8_macros.dart +++ b/dart/step8_macros.dart @@ -217,22 +217,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } on MalNativeException catch (e) { - return "${e.error}"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -249,6 +234,15 @@ main(List args) { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/step9_try.dart b/dart/step9_try.dart index aa8fece5e6..147958e51f 100644 --- a/dart/step9_try.dart +++ b/dart/step9_try.dart @@ -198,6 +198,10 @@ MalType EVAL(MalType ast, Env env) { continue; } else if (symbol.value == 'try*') { var body = args.first; + if (args.length < 2) { + ast = EVAL(body, env); + continue; + } var catchClause = args[1] as MalList; try { ast = EVAL(body, env); @@ -237,22 +241,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } on MalNativeException catch (e) { - return "${e.error}"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -269,6 +258,15 @@ main(List args) { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/stepA_mal.dart b/dart/stepA_mal.dart index f27ec05b36..66208fb937 100644 --- a/dart/stepA_mal.dart +++ b/dart/stepA_mal.dart @@ -208,6 +208,10 @@ MalType EVAL(MalType ast, Env env) { continue; } else if (symbol.value == 'try*') { var body = args.first; + if (args.length < 2) { + ast = EVAL(body, env); + continue; + } var catchClause = args[1] as MalList; try { ast = EVAL(body, env); @@ -247,22 +251,7 @@ MalType EVAL(MalType ast, Env env) { String PRINT(MalType x) => printer.pr_str(x); String rep(String x) { - var parsed; - try { - parsed = READ(x); - } on reader.ParseException catch (e) { - return e.message; - } - - var evaledAst; - try { - evaledAst = EVAL(parsed, replEnv); - } on NotFoundException catch (e) { - return "'${e.value}' not found"; - } on MalNativeException catch (e) { - return "${e.error}"; - } - return PRINT(evaledAst); + return PRINT(EVAL(READ(x), replEnv)); } const prompt = 'user> '; @@ -280,6 +269,15 @@ main(List args) { var output; try { output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; } on reader.NoInputException { continue; } diff --git a/dart/types.dart b/dart/types.dart index 98022b9755..5d757b0acb 100644 --- a/dart/types.dart +++ b/dart/types.dart @@ -263,14 +263,6 @@ class MalClosure extends MalCallable { } } -class MalNativeException implements Exception { - final Error error; - - MalNativeException(this.error); - - String toString() => error.toString(); -} - class MalException implements Exception { final MalType value; diff --git a/elm/step2_eval.elm b/elm/step2_eval.elm index d23e1d8cea..25b6d43e83 100644 --- a/elm/step2_eval.elm +++ b/elm/step2_eval.elm @@ -100,7 +100,7 @@ makeOutput result = str Err msg -> - "ERR:" ++ msg + "Error: " ++ msg prompt : String diff --git a/elm/step3_env.elm b/elm/step3_env.elm index 59a592c874..40404ddbd0 100644 --- a/elm/step3_env.elm +++ b/elm/step3_env.elm @@ -95,7 +95,7 @@ makeOutput result = str Err msg -> - "ERR:" ++ msg + "Error: " ++ msg prompt : String diff --git a/elm/step4_if_fn_do.elm b/elm/step4_if_fn_do.elm index 113e2253c7..a988b54d59 100644 --- a/elm/step4_if_fn_do.elm +++ b/elm/step4_if_fn_do.elm @@ -477,7 +477,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm index c460102c03..d9fb3c0332 100644 --- a/elm/step5_tco.elm +++ b/elm/step5_tco.elm @@ -515,7 +515,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/elm/step6_file.elm b/elm/step6_file.elm index 670cdadaac..d19c501d52 100644 --- a/elm/step6_file.elm +++ b/elm/step6_file.elm @@ -585,7 +585,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/elm/step7_quote.elm b/elm/step7_quote.elm index 1e396dce5b..489c701c90 100644 --- a/elm/step7_quote.elm +++ b/elm/step7_quote.elm @@ -625,7 +625,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/elm/step8_macros.elm b/elm/step8_macros.elm index c089a90f08..023d1179ae 100644 --- a/elm/step8_macros.elm +++ b/elm/step8_macros.elm @@ -702,7 +702,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/elm/step9_try.elm b/elm/step9_try.elm index 356584ec5f..90e04418ad 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -724,7 +724,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm index 71bdac5613..5b28c60afd 100644 --- a/elm/stepA_mal.elm +++ b/elm/stepA_mal.elm @@ -740,7 +740,7 @@ print env = printError : Env -> MalExpr -> String printError env expr = - "ERR:" ++ (printString env False expr) + "Error: " ++ (printString env False expr) {-| Read-Eval-Print. diff --git a/erlang/src/step9_try.erl b/erlang/src/step9_try.erl index 41116205e8..9ca6303cd1 100644 --- a/erlang/src/step9_try.erl +++ b/erlang/src/step9_try.erl @@ -37,7 +37,8 @@ rep(Input, Env) -> none -> none; Result -> printer:pr_str(Result, true) catch - error:Reason -> printer:pr_str({error, Reason}, true) + error:Reason -> printer:pr_str({error, Reason}, true); + throw:Reason -> printer:pr_str({error, printer:pr_str(Reason, true)}, true) end. read(Input) -> diff --git a/erlang/src/stepA_mal.erl b/erlang/src/stepA_mal.erl index b763f2bb15..f848b91503 100644 --- a/erlang/src/stepA_mal.erl +++ b/erlang/src/stepA_mal.erl @@ -41,7 +41,8 @@ rep(Input, Env) -> none -> none; Result -> printer:pr_str(Result, true) catch - error:Reason -> printer:pr_str({error, Reason}, true) + error:Reason -> printer:pr_str({error, Reason}, true); + throw:Reason -> printer:pr_str({error, printer:pr_str(Reason, true)}, true) end. read(Input) -> diff --git a/es6/step1_read_print.mjs b/es6/step1_read_print.mjs index 8af709fade..48932cad53 100644 --- a/es6/step1_read_print.mjs +++ b/es6/step1_read_print.mjs @@ -22,7 +22,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step2_eval.mjs b/es6/step2_eval.mjs index f49b78ad6a..3274fd3b29 100644 --- a/es6/step2_eval.mjs +++ b/es6/step2_eval.mjs @@ -51,7 +51,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step3_env.mjs b/es6/step3_env.mjs index 034315a814..5ecea0d683 100644 --- a/es6/step3_env.mjs +++ b/es6/step3_env.mjs @@ -62,7 +62,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step4_if_fn_do.mjs b/es6/step4_if_fn_do.mjs index e3c7073030..3369595c75 100644 --- a/es6/step4_if_fn_do.mjs +++ b/es6/step4_if_fn_do.mjs @@ -76,7 +76,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step5_tco.mjs b/es6/step5_tco.mjs index bf83f4a69d..035f2f1df8 100644 --- a/es6/step5_tco.mjs +++ b/es6/step5_tco.mjs @@ -90,7 +90,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step6_file.mjs b/es6/step6_file.mjs index 1053976a33..e3fc7bbb55 100644 --- a/es6/step6_file.mjs +++ b/es6/step6_file.mjs @@ -100,7 +100,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step7_quote.mjs b/es6/step7_quote.mjs index 31642da170..2fea25cb09 100644 --- a/es6/step7_quote.mjs +++ b/es6/step7_quote.mjs @@ -123,7 +123,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step8_macros.mjs b/es6/step8_macros.mjs index e106975c23..5857c7e2ab 100644 --- a/es6/step8_macros.mjs +++ b/es6/step8_macros.mjs @@ -144,7 +144,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } } } diff --git a/es6/step9_try.mjs b/es6/step9_try.mjs index 389c1c8db9..73706c3da8 100644 --- a/es6/step9_try.mjs +++ b/es6/step9_try.mjs @@ -155,7 +155,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${pr_str(exc, true)}`) } } } diff --git a/es6/stepA_mal.mjs b/es6/stepA_mal.mjs index a86199385e..81eff7d0be 100644 --- a/es6/stepA_mal.mjs +++ b/es6/stepA_mal.mjs @@ -158,7 +158,7 @@ while (true) { if (line) { console.log(REP(line)) } } catch (exc) { if (exc instanceof BlankException) { continue } - if (exc.stack) { console.log(exc.stack) } - else { console.log(`Error: ${exc}`) } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${pr_str(exc, true)}`) } } } diff --git a/factor/lib/reader/reader.factor b/factor/lib/reader/reader.factor index 2c4092a04a..da72277e00 100644 --- a/factor/lib/reader/reader.factor +++ b/factor/lib/reader/reader.factor @@ -34,7 +34,7 @@ DEFER: read-form :: read-sequence ( seq closer exemplar -- seq maltype ) seq [ [ - [ "expected " closer ", got EOF" append throw ] + [ "expected '" closer "', got EOF" append append throw ] [ dup first closer = ] if-empty ] [ read-form , diff --git a/factor/step1_read_print/step1_read_print.factor b/factor/step1_read_print/step1_read_print.factor index fe42cad03d..3d23d9c31e 100755 --- a/factor/step1_read_print/step1_read_print.factor +++ b/factor/step1_read_print/step1_read_print.factor @@ -11,7 +11,11 @@ IN: step1_read_print : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ EVAL ] [ nip ] recover PRINT ; + [ + READ EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step2_eval/step2_eval.factor b/factor/step2_eval/step2_eval.factor index aa1c06ea0e..2892911b3b 100755 --- a/factor/step2_eval/step2_eval.factor +++ b/factor/step2_eval/step2_eval.factor @@ -43,7 +43,11 @@ DEFER: EVAL : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step3_env/step3_env.factor b/factor/step3_env/step3_env.factor index 3dbdc002c9..310fea19f0 100755 --- a/factor/step3_env/step3_env.factor +++ b/factor/step3_env/step3_env.factor @@ -54,7 +54,11 @@ DEFER: EVAL : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) f repl-bindings repl-env set diff --git a/factor/step4_if_fn_do/step4_if_fn_do.factor b/factor/step4_if_fn_do/step4_if_fn_do.factor index d48f2414bc..6f51449ead 100755 --- a/factor/step4_if_fn_do/step4_if_fn_do.factor +++ b/factor/step4_if_fn_do/step4_if_fn_do.factor @@ -71,7 +71,11 @@ M: callable apply call( x -- y ) ; : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step5_tco/step5_tco.factor b/factor/step5_tco/step5_tco.factor index face303a81..d14fbe9b3d 100755 --- a/factor/step5_tco/step5_tco.factor +++ b/factor/step5_tco/step5_tco.factor @@ -78,7 +78,11 @@ M: callable apply call( x -- y ) f ; : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step6_file/step6_file.factor b/factor/step6_file/step6_file.factor index 4509ccf30d..3db684087c 100755 --- a/factor/step6_file/step6_file.factor +++ b/factor/step6_file/step6_file.factor @@ -80,7 +80,11 @@ M: callable apply call( x -- y ) f ; : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step7_quote/step7_quote.factor b/factor/step7_quote/step7_quote.factor index f980509c7e..99264e8bc3 100755 --- a/factor/step7_quote/step7_quote.factor +++ b/factor/step7_quote/step7_quote.factor @@ -95,7 +95,11 @@ M: callable apply call( x -- y ) f ; : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step8_macros/step8_macros.factor b/factor/step8_macros/step8_macros.factor index 9b77f97da1..7dda02ed74 100755 --- a/factor/step8_macros/step8_macros.factor +++ b/factor/step8_macros/step8_macros.factor @@ -113,7 +113,11 @@ M: callable apply call( x -- y ) f ; : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/factor/step9_try/step9_try.factor b/factor/step9_try/step9_try.factor index 403b9e2fe1..92fae10371 100755 --- a/factor/step9_try/step9_try.factor +++ b/factor/step9_try/step9_try.factor @@ -50,8 +50,12 @@ DEFER: EVAL :: eval-try* ( params env -- maltype ) [ params first env EVAL ] [ - params second second env new-env [ env-set ] keep - params second third swap EVAL + params length 1 > [ + params second second env new-env [ env-set ] keep + params second third swap EVAL + ] [ + throw + ] if ] recover ; : args-split ( bindlist -- bindlist restbinding/f ) @@ -121,7 +125,11 @@ M: callable apply call( x -- y ) f ; : PRINT ( maltype -- str ) pr-str ; : REP ( str -- str ) - [ READ repl-env get EVAL ] [ nip ] recover PRINT ; + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; : REPL ( -- ) [ diff --git a/fsharp/step1_read_print.fs b/fsharp/step1_read_print.fs index 27751f51c2..1ce61408ff 100644 --- a/fsharp/step1_read_print.fs +++ b/fsharp/step1_read_print.fs @@ -32,10 +32,12 @@ module REPL Readline.Mode.Terminal [] - let rec main args = + let main args = let mode = getReadlineMode args - match Readline.read "user> " mode with - | null -> 0 - | input -> - REP input - main args + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + REP input + loop() + loop () diff --git a/fsharp/step2_eval.fs b/fsharp/step2_eval.fs index d14615f128..62bdc4299d 100644 --- a/fsharp/step2_eval.fs +++ b/fsharp/step2_eval.fs @@ -20,27 +20,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -61,11 +44,20 @@ module REPL Readline.Mode.Terminal [] - let rec main args = + let main args = let mode = getReadlineMode args let env = Env.makeRootEnv () - match Readline.read "user> " mode with - | null -> 0 - | input -> - REP env input - main args + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/fsharp/step3_env.fs b/fsharp/step3_env.fs index 4c7954ac37..db6408f4cd 100644 --- a/fsharp/step3_env.fs +++ b/fsharp/step3_env.fs @@ -56,27 +56,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -104,6 +87,13 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/step4_if_fn_do.fs b/fsharp/step4_if_fn_do.fs index 5ffedda78a..8b48f64b65 100644 --- a/fsharp/step4_if_fn_do.fs +++ b/fsharp/step4_if_fn_do.fs @@ -92,27 +92,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -147,6 +130,13 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/step5_tco.fs b/fsharp/step5_tco.fs index ab96f441d4..1c82c67a93 100644 --- a/fsharp/step5_tco.fs +++ b/fsharp/step5_tco.fs @@ -94,27 +94,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -149,6 +132,13 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/step6_file.fs b/fsharp/step6_file.fs index 0d1af99744..1e03c55f9e 100644 --- a/fsharp/step6_file.fs +++ b/fsharp/step6_file.fs @@ -94,27 +94,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -175,6 +158,13 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/step7_quote.fs b/fsharp/step7_quote.fs index 7fbe9d4d69..de6eb19164 100644 --- a/fsharp/step7_quote.fs +++ b/fsharp/step7_quote.fs @@ -114,27 +114,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -195,6 +178,13 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/step8_macros.fs b/fsharp/step8_macros.fs index 8a80b56d36..f893f52be7 100644 --- a/fsharp/step8_macros.fs +++ b/fsharp/step8_macros.fs @@ -142,27 +142,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -225,6 +208,13 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/step9_try.fs b/fsharp/step9_try.fs index babb2f1f4c..6bf6549edf 100644 --- a/fsharp/step9_try.fs +++ b/fsharp/step9_try.fs @@ -122,7 +122,10 @@ module REPL | List(_, [_; _; _]) -> raise <| Error.argMismatch () | _ -> raise <| Error.wrongArity () + and tryForm env = function + | [exp] -> + eval env exp | [exp; catchClause] -> try eval env exp @@ -159,27 +162,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -242,6 +228,15 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | Error.MalError(node) -> + printfn "Error: %s" (Printer.pr_str [node]) + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/fsharp/stepA_mal.fs b/fsharp/stepA_mal.fs index 8cdaa6836c..1657ad1063 100644 --- a/fsharp/stepA_mal.fs +++ b/fsharp/stepA_mal.fs @@ -122,7 +122,10 @@ module REPL | List(_, [_; _; _]) -> raise <| Error.argMismatch () | _ -> raise <| Error.wrongArity () + and tryForm env = function + | [exp] -> + eval env exp | [exp; catchClause] -> try eval env exp @@ -160,27 +163,10 @@ module REPL | node -> node |> eval_ast env let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] + Reader.read_str input let EVAL env ast = - try - Some(eval env ast) - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "%s" str - None - | Error.MalError(node) -> - printfn "%s" (Printer.pr_str [node]) - None - | ex -> - printfn "%s" (ex.Message) - None + Some(eval env ast) let PRINT v = v @@ -256,6 +242,15 @@ module REPL match Readline.read "user> " mode with | null -> 0 | input -> - REP env input + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | Error.MalError(node) -> + printfn "Error: %s" (Printer.pr_str [node]) + | ex -> + printfn "Error: %s" (ex.Message) loop () loop () diff --git a/gnu-smalltalk/step9_try.st b/gnu-smalltalk/step9_try.st index 08bb9768de..39022321b0 100644 --- a/gnu-smalltalk/step9_try.st +++ b/gnu-smalltalk/step9_try.st @@ -220,6 +220,9 @@ Object subclass: MAL [ a0_ = #'try*' ifTrue: [ | A B C | A := ast second. + ast at: 3 ifAbsent: [ + ^self EVAL: A env: env. + ]. a2_ := ast third value. B := a2_ second value. C := a2_ third. diff --git a/gnu-smalltalk/stepA_mal.st b/gnu-smalltalk/stepA_mal.st index dea76c217c..acba962242 100644 --- a/gnu-smalltalk/stepA_mal.st +++ b/gnu-smalltalk/stepA_mal.st @@ -220,6 +220,9 @@ Object subclass: MAL [ a0_ = #'try*' ifTrue: [ | A B C | A := ast second. + ast at: 3 ifAbsent: [ + ^self EVAL: A env: env. + ]. a2_ := ast third value. B := a2_ second value. C := a2_ third. diff --git a/groovy/step1_read_print.groovy b/groovy/step1_read_print.groovy index f857c054ee..c9775a6a68 100644 --- a/groovy/step1_read_print.groovy +++ b/groovy/step1_read_print.groovy @@ -30,7 +30,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(ex) { println "Error: $ex" ex.printStackTrace() diff --git a/groovy/step2_eval.groovy b/groovy/step2_eval.groovy index 3159db25bd..a2ced70ccc 100644 --- a/groovy/step2_eval.groovy +++ b/groovy/step2_eval.groovy @@ -62,7 +62,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(ex) { println "Error: $ex" ex.printStackTrace() diff --git a/groovy/step3_env.groovy b/groovy/step3_env.groovy index 5f375540c2..6d59f011e1 100644 --- a/groovy/step3_env.groovy +++ b/groovy/step3_env.groovy @@ -70,7 +70,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(ex) { println "Error: $ex" ex.printStackTrace() diff --git a/groovy/step4_if_fn_do.groovy b/groovy/step4_if_fn_do.groovy index db86b993d4..df7d984055 100644 --- a/groovy/step4_if_fn_do.groovy +++ b/groovy/step4_if_fn_do.groovy @@ -92,7 +92,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(ex) { println "Error: $ex" ex.printStackTrace() diff --git a/groovy/step5_tco.groovy b/groovy/step5_tco.groovy index 50f4673218..a487365540 100644 --- a/groovy/step5_tco.groovy +++ b/groovy/step5_tco.groovy @@ -106,7 +106,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(StackOverflowError ex) { println "Error: ${ex}" } catch(ex) { diff --git a/groovy/step6_file.groovy b/groovy/step6_file.groovy index 664a59af8c..ebdae63517 100644 --- a/groovy/step6_file.groovy +++ b/groovy/step6_file.groovy @@ -114,7 +114,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(StackOverflowError ex) { println "Error: ${ex}" } catch(ex) { diff --git a/groovy/step7_quote.groovy b/groovy/step7_quote.groovy index d50a4a19f3..ee2e33940d 100644 --- a/groovy/step7_quote.groovy +++ b/groovy/step7_quote.groovy @@ -135,7 +135,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(StackOverflowError ex) { println "Error: ${ex}" } catch(ex) { diff --git a/groovy/step8_macros.groovy b/groovy/step8_macros.groovy index 7606526b30..24b1a90af8 100644 --- a/groovy/step8_macros.groovy +++ b/groovy/step8_macros.groovy @@ -167,7 +167,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(StackOverflowError ex) { println "Error: ${ex}" } catch(ex) { diff --git a/groovy/step9_try.groovy b/groovy/step9_try.groovy index 991803488c..c921bd6d12 100644 --- a/groovy/step9_try.groovy +++ b/groovy/step9_try.groovy @@ -185,7 +185,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(StackOverflowError ex) { println "Error: ${ex}" } catch(ex) { diff --git a/groovy/stepA_mal.groovy b/groovy/stepA_mal.groovy index abf96dfd5a..bb4bf63f5a 100644 --- a/groovy/stepA_mal.groovy +++ b/groovy/stepA_mal.groovy @@ -189,7 +189,7 @@ while (true) { try { println REP(line) } catch(MalException ex) { - println "Error: ${ex.message}" + println "Error: ${printer.pr_str(ex.obj, true)}" } catch(StackOverflowError ex) { println "Error: ${ex}" } catch(ex) { diff --git a/guile/step0_repl.scm b/guile/step0_repl.scm index dd598b6d2e..9680c773a0 100644 --- a/guile/step0_repl.scm +++ b/guile/step0_repl.scm @@ -15,18 +15,24 @@ (import (readline)) -(define (READ) (_readline "user> ")) +(define (READ str) + str) (define (EVAL ast env) ast) (define (PRINT str) - (and (not (eof-object? str)) - (format #t "~a~%" str))) + (format #t "~a~%" str)) (define (LOOP continue?) (and continue? (REPL))) (define (REPL) - (LOOP (PRINT (EVAL (READ) '())))) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (PRINT (EVAL (READ line) '()))))))) (REPL) diff --git a/guile/step1_read_print.scm b/guile/step1_read_print.scm index 3517f7b791..cfb9a2ad06 100644 --- a/guile/step1_read_print.scm +++ b/guile/step1_read_print.scm @@ -15,8 +15,8 @@ (import (readline) (reader) (printer)) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (EVAL ast env) ast) @@ -29,11 +29,14 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) '()))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) '()))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) (REPL) diff --git a/guile/step2_eval.scm b/guile/step2_eval.scm index a621118874..27759d4568 100644 --- a/guile/step2_eval.scm +++ b/guile/step2_eval.scm @@ -21,8 +21,8 @@ (* . ,*) (/ . ,/))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -37,17 +37,12 @@ ht) (else ast))) -(define (eval_func ast env) - (define expr (eval_ast ast env)) - (match expr - (((? procedure? proc) args ...) - (apply proc args)) - (else (throw 'mal-error (format #f "'~a' not found" (car expr)))))) - (define (EVAL ast env) (match ast (() ast) - ((? list?) (eval_func ast env)) + ((? list?) + (let ((el (eval_ast ast env))) + (apply (car el) (cdr el)))) (else (eval_ast ast env)))) (define (PRINT exp) @@ -59,11 +54,14 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) (REPL) diff --git a/guile/step3_env.scm b/guile/step3_env.scm index 40a891b127..546335ec87 100644 --- a/guile/step3_env.scm +++ b/guile/step3_env.scm @@ -26,8 +26,8 @@ (receive (b e) (unzip2 *primitives*) (make-Env #:binds b #:exprs e))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -36,17 +36,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define expr (eval_ast ast env)) - (match expr - (((? procedure? proc) args ...) - (apply proc args)) - (else (throw 'mal-error (format #f "'~a' not found" (car expr)))))) - (define (EVAL ast env) (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) (define (%unzip2 kvs) @@ -54,7 +48,8 @@ (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) (match ast ((? (lambda (x) (not (list? x)))) (eval_ast ast env)) @@ -66,7 +61,9 @@ (receive (keys vals) (%unzip2 (->list kvs)) (for-each setter keys vals)) (EVAL body new-env))) - (else (eval_func ast env)))) + (else + (let ((el (eval_ast ast env))) + (apply (car el) (cdr el)))))) (define (PRINT exp) (and (not (eof-object? exp)) @@ -77,11 +74,14 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) (REPL) diff --git a/guile/step4_if_fn_do.scm b/guile/step4_if_fn_do.scm index ac330e84a1..7323c932d0 100644 --- a/guile/step4_if_fn_do.scm +++ b/guile/step4_if_fn_do.scm @@ -17,11 +17,11 @@ (srfi srfi-1) (ice-9 receive) (env) (core) (types)) (define *toplevel* - (receive (b e) (unzip2 core.ns) + (receive (b e) (unzip2 core.ns) (make-Env #:binds b #:exprs e))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -31,17 +31,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define expr (eval_ast ast env)) - (match expr - (((? procedure? proc) args ...) - (apply proc args)) - (else (throw 'mal-error (format #f "'~a' not found" (car expr)))))) - (define (eval_seq ast env) (cond ((null? ast) nil) @@ -51,15 +45,16 @@ (eval_seq (cdr ast) env)))) (define (EVAL ast env) - (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) (define (%unzip2 kvs) (let lp((next kvs) (k '()) (v '())) (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) (match ast + ((? non-list?) (eval_ast ast env)) (() ast) (('def! k v) ((env 'set) k (EVAL v env))) (('let* kvs body) @@ -68,19 +63,22 @@ (receive (keys vals) (%unzip2 (->list kvs)) (for-each setter keys vals)) (EVAL body new-env))) - (('do rest ...) (eval_seq rest env)) + (('do rest ...) + (eval_seq rest env)) (('if cnd thn els ...) (cond ((and (not (null? els)) (not (null? (cdr els)))) ;; Invalid `if' form - (throw 'mal-error "failed to match any pattern in form " ast)) + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) ((cond-true? (EVAL cnd env)) (EVAL thn env)) (else (if (null? els) nil (EVAL (car els) env))))) (('fn* params body ...) ; function definition (lambda args (eval_seq body (make-Env #:outer env #:binds (->list params) #:exprs args)))) - ((? list?) (eval_func ast env)) ; function calling - (else (eval_ast ast env)))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (apply (car el) (cdr el)))))) (define (PRINT exp) (and (not (eof-object? exp)) @@ -91,11 +89,14 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) (REPL) diff --git a/guile/step5_tco.scm b/guile/step5_tco.scm index 5971aa4a34..030c0dc308 100644 --- a/guile/step5_tco.scm +++ b/guile/step5_tco.scm @@ -17,11 +17,11 @@ (srfi srfi-1) (ice-9 receive) (env) (core) (types)) (define *toplevel* - (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs e))) + (receive (b e) (unzip2 core.ns) + (make-Env #:binds b #:exprs (map make-func e)))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -31,17 +31,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define expr (eval_ast ast env)) - (match expr - (((? procedure? proc) args ...) - (apply proc args)) - (else (throw 'mal-error (format #f "'~a' not found" (car expr)))))) - (define (eval_seq ast env) (cond ((null? ast) nil) @@ -51,13 +45,13 @@ (eval_seq (cdr ast) env)))) (define (EVAL ast env) - (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) (define (%unzip2 kvs) (let lp((next kvs) (k '()) (v '())) (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means ;; it'll bring some trouble in control flow. We have to use continuations to return @@ -68,6 +62,7 @@ ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. (let tco-loop((ast ast) (env env)) (match ast + ((? non-list?) (eval_ast ast env)) (() ast) (('def! k v) ((env 'set) k (EVAL v env))) (('let* kvs body) @@ -78,7 +73,8 @@ (tco-loop body new-env))) (('do rest ...) (cond - ((null? rest) (throw 'mal-error "do: Invalid form!" rest)) + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) ((= 1 (length rest)) (tco-loop (car rest) env)) (else (let ((mexpr (take rest (1- (length rest)))) @@ -89,22 +85,26 @@ (cond ((and (not (null? els)) (not (null? (cdr els)))) ;; Invalid `if' form - (throw 'mal-error "if: failed to match any pattern in form " ast)) + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) ((cond-true? (EVAL cnd env)) (tco-loop thn env)) (else (if (null? els) nil (tco-loop (car els) env))))) (('fn* params body ...) ; function definition - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast)) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv))))))) - ((? list?) (eval_func ast env)) ; function calling - (else (eval_ast ast env))))) + (make-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el))))))) (define (PRINT exp) (and (not (eof-object? exp)) @@ -115,12 +115,15 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) ;; NOTE: we have to reduce stack size to pass step5 test ((@ (system vm vm) call-with-stack-overflow-handler) diff --git a/guile/step6_file.scm b/guile/step6_file.scm index ccb4a0adb3..19bf58373c 100644 --- a/guile/step6_file.scm +++ b/guile/step6_file.scm @@ -20,8 +20,8 @@ (receive (b e) (unzip2 core.ns) (make-Env #:binds b #:exprs (map make-func e)))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -31,19 +31,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define (_eval o) (EVAL o env)) - (define (func? x) (and=> ((env 'get) x) is-func)) - (cond - ((func? (car ast)) - => (lambda (c) - (callable-apply c (map _eval (cdr ast))))) - (else (throw 'mal-error (format #f "'~a' not found" (car ast)))))) - (define (eval_seq ast env) (cond ((null? ast) nil) @@ -53,13 +45,13 @@ (eval_seq (cdr ast) env)))) (define (EVAL ast env) - (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) (define (%unzip2 kvs) (let lp((next kvs) (k '()) (v '())) (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means ;; it'll bring some trouble in control flow. We have to use continuations to return @@ -70,6 +62,7 @@ ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. (let tco-loop((ast ast) (env env)) (match ast + ((? non-list?) (eval_ast ast env)) (() ast) (('def! k v) ((env 'set) k (EVAL v env))) (('let* kvs body) @@ -80,7 +73,8 @@ (tco-loop body new-env))) (('do rest ...) (cond - ((null? rest) (throw 'mal-error "do: Invalid form!" rest)) + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) ((= 1 (length rest)) (tco-loop (car rest) env)) (else (let ((mexpr (take rest (1- (length rest)))) @@ -91,7 +85,8 @@ (cond ((and (not (null? els)) (not (null? (cdr els)))) ;; Invalid `if' form - (throw 'mal-error "if: failed to match any pattern in form " ast)) + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) ((cond-true? (EVAL cnd env)) (tco-loop thn env)) (else (if (null? els) nil (tco-loop (car els) env))))) (('fn* params body ...) ; function definition @@ -99,15 +94,17 @@ (lambda args (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) (cond - ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast)) + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) ((= 1 (length body)) (tco-loop (car body) nenv)) (else (let ((mexpr (take body (1- (length body)))) (tail-call (car (take-right body 1)))) (eval_seq mexpr nenv) (tco-loop tail-call nenv)))))))) - ((? list?) (eval_func ast env)) ; function calling - (else (eval_ast ast env))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el))))))) (define (EVAL-string str) (EVAL (read_str str) *toplevel*)) @@ -121,12 +118,15 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) ;; initialization ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) diff --git a/guile/step7_quote.scm b/guile/step7_quote.scm index bffd8de22c..bdf9998f3e 100644 --- a/guile/step7_quote.scm +++ b/guile/step7_quote.scm @@ -20,8 +20,8 @@ (receive (b e) (unzip2 core.ns) (make-Env #:binds b #:exprs (map make-func e)))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -31,19 +31,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define (_eval o) (EVAL o env)) - (define (func? x) (and=> ((env 'get) x) is-func)) - (cond - ((func? (car ast)) - => (lambda (c) - (callable-apply c (map _eval (cdr ast))))) - (else (throw 'mal-error (format #f "'~a' not found" (car ast)))))) - (define (eval_seq ast env) (cond ((null? ast) nil) @@ -58,22 +50,15 @@ (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - ;; (define (_quasiquote ast) - ;; (define (non-pair? x) (not (pair? x))) - ;; (match ast - ;; ((? non-pair?) `(quote ,ast)) - ;; (('unquote unq) unq) - ;; (((? pair? p) ('splice-unquote unqsp) rest ...) - ;; `(concat ,p ,unqsp ,(_quasiquote rest))) - ;; (else `(cons ,(_quasiquote (car ast)) ,(_quasiquote (cdr ast)))))) (define (_quasiquote obj) (match obj ((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest))) (('unquote unq) unq) ((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest))) - ((head rest ...) (list 'cons (list 'quote head) (_quasiquote rest))) + ((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest))) (else `(quote ,obj)))) ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means ;; it'll bring some trouble in control flow. We have to use continuations to return @@ -84,6 +69,7 @@ ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. (let tco-loop((ast ast) (env env)) (match ast + ((? non-list?) (eval_ast ast env)) (() ast) (('quote obj) obj) (('quasiquote obj) (EVAL (_quasiquote (->list obj)) env)) @@ -96,7 +82,8 @@ (tco-loop body new-env))) (('do rest ...) (cond - ((null? rest) (throw 'mal-error "do: Invalid form!" rest)) + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) ((= 1 (length rest)) (tco-loop (car rest) env)) (else (let ((mexpr (take rest (1- (length rest)))) @@ -107,7 +94,8 @@ (cond ((and (not (null? els)) (not (null? (cdr els)))) ;; Invalid `if' form - (throw 'mal-error "if: failed to match any pattern in form " ast)) + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) ((cond-true? (EVAL cnd env)) (tco-loop thn env)) (else (if (null? els) nil (tco-loop (car els) env))))) (('fn* params body ...) ; function definition @@ -115,15 +103,17 @@ (lambda args (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) (cond - ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast)) + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) ((= 1 (length body)) (tco-loop (car body) nenv)) (else (let ((mexpr (take body (1- (length body)))) (tail-call (car (take-right body 1)))) (eval_seq mexpr nenv) (tco-loop tail-call nenv)))))))) - ((? list?) (eval_func ast env)) ; function calling - (else (eval_ast ast env))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el))))))) (define (EVAL-string str) (EVAL (read_str str) *toplevel*)) @@ -137,12 +127,15 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) ;; initialization ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) diff --git a/guile/step8_macros.scm b/guile/step8_macros.scm index aa098c412c..fd63938913 100644 --- a/guile/step8_macros.scm +++ b/guile/step8_macros.scm @@ -20,8 +20,8 @@ (receive (b e) (unzip2 core.ns) (make-Env #:binds b #:exprs (map make-func e)))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -31,19 +31,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define (_eval o) (EVAL o env)) - (define (func? x) (and=> ((env 'get) x) is-func)) - (cond - ((func? (car ast)) - => (lambda (c) - (callable-apply c (map _eval (cdr ast))))) - (else (throw 'mal-error (format #f "'~a' not found" (car ast)))))) - (define (eval_seq ast env) (cond ((null? ast) nil) @@ -72,7 +64,8 @@ (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) (define (_quasiquote obj) (match obj @@ -109,7 +102,8 @@ (tco-loop body new-env))) (('do rest ...) (cond - ((null? rest) (throw 'mal-error "do: Invalid form!" rest)) + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) ((= 1 (length rest)) (tco-loop (car rest) env)) (else (let ((mexpr (take rest (1- (length rest)))) @@ -120,22 +114,26 @@ (cond ((and (not (null? els)) (not (null? (cdr els)))) ;; Invalid `if' form - (throw 'mal-error "if: failed to match any pattern in form " ast)) + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) ((cond-true? (EVAL cnd env)) (tco-loop thn env)) (else (if (null? els) nil (tco-loop (car els) env))))) (('fn* params body ...) ; function definition - (make-func + (make-anonymous-func (lambda args (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) (cond - ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast)) + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) ((= 1 (length body)) (tco-loop (car body) nenv)) (else (let ((mexpr (take body (1- (length body)))) (tail-call (car (take-right body 1)))) (eval_seq mexpr nenv) (tco-loop tail-call nenv)))))))) - (else (eval_func ast env)))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el)))))))) (define (EVAL-string str) (EVAL (read_str str) *toplevel*)) @@ -149,12 +147,15 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) ;; initialization ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) diff --git a/guile/step9_try.scm b/guile/step9_try.scm index 33de5622c3..95f71fc95e 100644 --- a/guile/step9_try.scm +++ b/guile/step9_try.scm @@ -16,12 +16,21 @@ (import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) (srfi srfi-1) (ice-9 receive) (env) (core) (types)) +;; Primitives which doesn't unbox args in default. +;; This is a trick to implement meta-info taking advange of the original +;; types of Guile as possible. +(define *unbox-exception* '(meta assoc swap!)) + (define *toplevel* (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs (map make-func e)))) + (let ((env (make-Env #:binds b #:exprs (map make-func e)))) + (for-each (lambda (f) + (callable-unbox-set! ((env 'get) f) #f)) + *unbox-exception*) + env))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) @@ -31,19 +40,11 @@ ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) ((? hash-table? ht) - (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) - ht) + ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or + ;; there'll be strange bugs!!! + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define (_eval o) (EVAL o env)) - (define (func? x) (and=> (env-check x env) is-func)) - ;;(format #t "AAA: ~a~%" (func? (car ast))) - (cond - ((func? (car ast)) - => (lambda (c) - (callable-apply c (map _eval (cdr ast))))) - (else (throw 'mal-error (format #f "'~a' not found" (car ast)))))) (define (eval_seq ast env) (cond @@ -75,7 +76,8 @@ (cond ;; NOTE: reverse is very important here! ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) (define (_quasiquote obj) (match obj @@ -113,7 +115,8 @@ (tco-loop body new-env))) (('do rest ...) (cond - ((null? rest) (throw 'mal-error "do: Invalid form!" rest)) + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) ((= 1 (length rest)) (tco-loop (car rest) env)) (else (let ((mexpr (take rest (1- (length rest)))) @@ -124,21 +127,25 @@ (cond ((and (not (null? els)) (not (null? (cdr els)))) ;; Invalid `if' form - (throw 'mal-error "if: failed to match any pattern in form " ast)) + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) ((cond-true? (EVAL cnd env)) (tco-loop thn env)) (else (if (null? els) nil (tco-loop (car els) env))))) (('fn* params body ...) ; function definition - (make-func + (make-anonymous-func (lambda args (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) (cond - ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast)) + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) ((= 1 (length body)) (tco-loop (car body) nenv)) (else (let ((mexpr (take body (1- (length body)))) (tail-call (car (take-right body 1)))) (eval_seq mexpr nenv) (tco-loop tail-call nenv)))))))) + (('try* A) + (EVAL A env)) (('try* A ('catch* B C)) (catch #t @@ -146,7 +153,9 @@ (lambda e (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) (EVAL C nenv))))) - (else (eval_func ast env)))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el)))))))) (define (EVAL-string str) (EVAL (read_str str) *toplevel*)) @@ -160,12 +169,15 @@ (define (REPL) (LOOP - (catch 'mal-error - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) ;; initialization ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) diff --git a/guile/stepA_mal.scm b/guile/stepA_mal.scm index 1f9bf0e3bc..4a5f4ea3af 100644 --- a/guile/stepA_mal.scm +++ b/guile/stepA_mal.scm @@ -29,12 +29,13 @@ *unbox-exception*) env))) -(define (READ) - (read_str (_readline "user> "))) +(define (READ str) + (read_str str)) (define (eval_ast ast env) (define (_eval x) (EVAL x env)) (match ast + ((? _nil? obj) obj) ((? symbol? sym) (env-has sym env)) ((? list? lst) (map _eval lst)) ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) @@ -44,20 +45,6 @@ (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) (else ast))) -(define (eval_func ast env) - (define (_eval o) (EVAL o env)) - (define (func? x) - (let ((f (if (list? x) - (EVAL x env) - x))) - (if (callable? f) - f - (and=> (env-check f env) is-func)))) - (cond - ((func? (car ast)) - => (lambda (c) - (callable-apply c (map _eval (cdr ast))))) - (else (throw 'mal-error (format #f "'~a' not found" (car ast)))))) (define (eval_seq ast env) (cond @@ -154,18 +141,18 @@ (tail-call (car (take-right body 1)))) (eval_seq mexpr nenv) (tco-loop tail-call nenv)))))))) + (('try* A) + (EVAL A env)) (('try* A ('catch* B C)) (catch #t (lambda () (EVAL A env)) - (lambda (k . e) - (case k - ((mal-error) - (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs e))) - (EVAL C nenv))) - ;; TODO: add backtrace - (else (print-exception (current-output-port) #f k e)))))) - (else (eval_func ast env)))))) + (lambda e + (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) + (EVAL C nenv))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el)))))))) (define (EVAL-string str) (EVAL (read_str str) *toplevel*)) @@ -179,15 +166,15 @@ (define (REPL) (LOOP - (catch #t - (lambda () (PRINT (EVAL (READ) *toplevel*))) - (lambda (k . e) - (case k - ((mal-error) - (if (string=? (car e) "blank line") - (display "") - (format #t "Error: ~a~%" (car e)))) - (else (print-exception (current-output-port) #f k e))))))) + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) ;; initialization ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) diff --git a/haxe/Step0_repl.hx b/haxe/Step0_repl.hx index 9f5dbcb749..d34806a8e3 100644 --- a/haxe/Step0_repl.hx +++ b/haxe/Step0_repl.hx @@ -29,7 +29,7 @@ class Step0_repl { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + Compat.println("Error: " + exc); } } } diff --git a/haxe/Step1_read_print.hx b/haxe/Step1_read_print.hx index 3be96f66c3..dd22fb95b2 100644 --- a/haxe/Step1_read_print.hx +++ b/haxe/Step1_read_print.hx @@ -35,7 +35,7 @@ class Step1_read_print { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + Compat.println("Error: " + exc); } } } diff --git a/haxe/Step2_eval.hx b/haxe/Step2_eval.hx index a61239ade1..02d34f4a54 100644 --- a/haxe/Step2_eval.hx +++ b/haxe/Step2_eval.hx @@ -85,7 +85,7 @@ class Step2_eval { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + Compat.println("Error: " + exc); } } } diff --git a/haxe/Step3_env.hx b/haxe/Step3_env.hx index 805b984e6d..5166025841 100644 --- a/haxe/Step3_env.hx +++ b/haxe/Step3_env.hx @@ -96,7 +96,7 @@ class Step3_env { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + Compat.println("Error: " + exc); } } } diff --git a/haxe/Step4_if_fn_do.hx b/haxe/Step4_if_fn_do.hx index 064df794cb..6821da74fa 100644 --- a/haxe/Step4_if_fn_do.hx +++ b/haxe/Step4_if_fn_do.hx @@ -1,6 +1,7 @@ import Compat; import types.Types.MalType; import types.Types.*; +import types.MalException; import reader.*; import printer.*; import env.*; @@ -107,7 +108,11 @@ class Step4_if_fn_do { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/haxe/Step5_tco.hx b/haxe/Step5_tco.hx index 190e3e8704..f1b69b9c67 100644 --- a/haxe/Step5_tco.hx +++ b/haxe/Step5_tco.hx @@ -1,6 +1,7 @@ import Compat; import types.Types.MalType; import types.Types.*; +import types.MalException; import reader.*; import printer.*; import env.*; @@ -122,7 +123,11 @@ class Step5_tco { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/haxe/Step6_file.hx b/haxe/Step6_file.hx index 93513a928f..4e7856b533 100644 --- a/haxe/Step6_file.hx +++ b/haxe/Step6_file.hx @@ -1,6 +1,7 @@ import Compat; import types.Types.MalType; import types.Types.*; +import types.MalException; import reader.*; import printer.*; import env.*; @@ -137,7 +138,11 @@ class Step6_file { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/haxe/Step7_quote.hx b/haxe/Step7_quote.hx index c1fe9ec7d7..8cf7e45eeb 100644 --- a/haxe/Step7_quote.hx +++ b/haxe/Step7_quote.hx @@ -1,6 +1,7 @@ import Compat; import types.Types.MalType; import types.Types.*; +import types.MalException; import reader.*; import printer.*; import env.*; @@ -170,7 +171,11 @@ class Step7_quote { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/haxe/Step8_macros.hx b/haxe/Step8_macros.hx index 525b03be48..dc115bd7d1 100644 --- a/haxe/Step8_macros.hx +++ b/haxe/Step8_macros.hx @@ -1,6 +1,7 @@ import Compat; import types.Types.MalType; import types.Types.*; +import types.MalException; import reader.*; import printer.*; import env.*; @@ -209,7 +210,11 @@ class Step8_macros { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/haxe/Step9_try.hx b/haxe/Step9_try.hx index 52d7480fa9..07b7f0603e 100644 --- a/haxe/Step9_try.hx +++ b/haxe/Step9_try.hx @@ -232,7 +232,11 @@ class Step9_try { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/haxe/StepA_mal.hx b/haxe/StepA_mal.hx index 2d00764806..2b566d85ba 100644 --- a/haxe/StepA_mal.hx +++ b/haxe/StepA_mal.hx @@ -236,7 +236,11 @@ class StepA_mal { } catch (exc:haxe.io.Eof) { Compat.exit(0); } catch (exc:Dynamic) { - Compat.println(exc); + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; } } } diff --git a/hy/step1_read_print.hy b/hy/step1_read_print.hy index 179b09f884..ba8670e14b 100755 --- a/hy/step1_read_print.hy +++ b/hy/step1_read_print.hy @@ -25,6 +25,6 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] + (except [e Exception] (print (.join "" (apply traceback.format_exception (.exc_info sys)))))))) diff --git a/hy/step2_eval.hy b/hy/step2_eval.hy index 7d8b8fe7a0..a513ce5f08 100755 --- a/hy/step2_eval.hy +++ b/hy/step2_eval.hy @@ -59,6 +59,6 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] + (except [e Exception] (print (.join "" (apply traceback.format_exception (.exc_info sys)))))))) diff --git a/hy/step3_env.hy b/hy/step3_env.hy index 62ef837e59..c615f9e220 100755 --- a/hy/step3_env.hy +++ b/hy/step3_env.hy @@ -75,6 +75,6 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] + (except [e Exception] (print (.join "" (apply traceback.format_exception (.exc_info sys)))))))) diff --git a/hy/step4_if_fn_do.hy b/hy/step4_if_fn_do.hy index b75831d08d..17276ae043 100755 --- a/hy/step4_if_fn_do.hy +++ b/hy/step4_if_fn_do.hy @@ -2,6 +2,7 @@ (import [hy.models [HySymbol :as Sym]]) (import sys traceback) +(import [mal_types [MalException]]) (import [reader [read-str Blank]]) (import [printer [pr-str]]) (import [env [env-new env-get env-set]]) @@ -95,6 +96,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))) diff --git a/hy/step5_tco.hy b/hy/step5_tco.hy index 55e07d67aa..c137a459bf 100755 --- a/hy/step5_tco.hy +++ b/hy/step5_tco.hy @@ -2,6 +2,7 @@ (import [hy.models [HySymbol :as Sym]]) (import sys traceback) +(import [mal_types [MalException]]) (import [reader [read-str Blank]]) (import [printer [pr-str]]) (import [env [env-new env-get env-set]]) @@ -112,6 +113,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))) diff --git a/hy/step6_file.hy b/hy/step6_file.hy index e74ec2dc17..409297de7f 100755 --- a/hy/step6_file.hy +++ b/hy/step6_file.hy @@ -2,6 +2,7 @@ (import [hy.models [HyString :as Str HySymbol :as Sym]]) (import sys traceback) +(import [mal_types [MalException]]) (import [reader [read-str Blank]]) (import [printer [pr-str]]) (import [env [env-new env-get env-set]]) @@ -119,6 +120,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/hy/step7_quote.hy b/hy/step7_quote.hy index c78259a730..bd9ce05af6 100755 --- a/hy/step7_quote.hy +++ b/hy/step7_quote.hy @@ -2,6 +2,7 @@ (import [hy.models [HyString :as Str HySymbol :as Sym]]) (import sys traceback) +(import [mal_types [MalException]]) (import [reader [read-str Blank]]) (import [printer [pr-str]]) (import [env [env-new env-get env-set]]) @@ -143,6 +144,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/hy/step8_macros.hy b/hy/step8_macros.hy index 68832345d4..7297a2a882 100755 --- a/hy/step8_macros.hy +++ b/hy/step8_macros.hy @@ -2,6 +2,7 @@ (import [hy.models [HyString :as Str HySymbol :as Sym]]) (import sys traceback) +(import [mal_types [MalException]]) (import [reader [read-str Blank]]) (import [printer [pr-str]]) (import [env [env-new env-get env-set env-find]]) @@ -173,6 +174,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/hy/step9_try.hy b/hy/step9_try.hy index b1a7d50ced..d436aa701a 100755 --- a/hy/step9_try.hy +++ b/hy/step9_try.hy @@ -104,7 +104,7 @@ (macroexpand a1 env) (= (Sym "try*") a0) - (if (= (Sym "catch*") (nth a2 0)) + (if (and a2 (= (Sym "catch*") (nth a2 0))) (try (EVAL a1 env) (except [e Exception] @@ -186,6 +186,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/hy/stepA_mal.hy b/hy/stepA_mal.hy index 0981895fd9..2883ff4c7f 100755 --- a/hy/stepA_mal.hy +++ b/hy/stepA_mal.hy @@ -104,7 +104,7 @@ (macroexpand a1 env) (= (Sym "try*") a0) - (if (= (Sym "catch*") (nth a2 0)) + (if (and a2 (= (Sym "catch*") (nth a2 0))) (try (EVAL a1 env) (except [e Exception] @@ -190,6 +190,9 @@ (print (REP line))) (except [EOFError] (break)) (except [Blank]) - (except [] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))))) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/io/step4_if_fn_do.io b/io/step4_if_fn_do.io index 9f1644d542..587c4d23ae 100644 --- a/io/step4_if_fn_do.io +++ b/io/step4_if_fn_do.io @@ -70,6 +70,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/io/step5_tco.io b/io/step5_tco.io index 944bf6d716..db0867f772 100644 --- a/io/step5_tco.io +++ b/io/step5_tco.io @@ -85,6 +85,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/io/step6_file.io b/io/step6_file.io index cf985b7d7c..3bdc6a7f80 100644 --- a/io/step6_file.io +++ b/io/step6_file.io @@ -94,6 +94,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/io/step7_quote.io b/io/step7_quote.io index ce4b962424..0a0c4aeb83 100644 --- a/io/step7_quote.io +++ b/io/step7_quote.io @@ -112,6 +112,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/io/step8_macros.io b/io/step8_macros.io index 6ab02f4798..b451019f24 100644 --- a/io/step8_macros.io +++ b/io/step8_macros.io @@ -139,6 +139,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/io/step9_try.io b/io/step9_try.io index 990bcd13d2..6c56b10963 100644 --- a/io/step9_try.io +++ b/io/step9_try.io @@ -92,6 +92,7 @@ EVAL := method(ast, env, "macroexpand", return(macroexpand(ast at(1), env)), "try*", + if(ast at(2) == nil, return(EVAL(ast at(1), env))) e := try(result := EVAL(ast at(1), env)) e catch(Exception, exc := if(e type == "MalException", e val, e error) @@ -149,6 +150,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/io/stepA_mal.io b/io/stepA_mal.io index 911b21f175..cb6fd83a61 100644 --- a/io/stepA_mal.io +++ b/io/stepA_mal.io @@ -92,6 +92,7 @@ EVAL := method(ast, env, "macroexpand", return(macroexpand(ast at(1), env)), "try*", + if(ast at(2) == nil, return(EVAL(ast at(1), env))) e := try(result := EVAL(ast at(1), env)) e catch(Exception, exc := if(e type == "MalException", e val, e error) @@ -153,6 +154,9 @@ loop( if(line isEmpty, continue) e := try(REP(line) println) e catch(Exception, - ("Error: " .. (e error)) println + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) ) ) diff --git a/js/step0_repl.js b/js/step0_repl.js index 126a436f30..488c82f19a 100644 --- a/js/step0_repl.js +++ b/js/step0_repl.js @@ -27,12 +27,6 @@ if (typeof require !== 'undefined' && require.main === module) { while (true) { var line = readline.readline("user> "); if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } - } + if (line) { printer.println(rep(line)); } } } diff --git a/js/step1_read_print.js b/js/step1_read_print.js index f1fb0269be..d712a2f2bd 100644 --- a/js/step1_read_print.js +++ b/js/step1_read_print.js @@ -33,9 +33,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step2_eval.js b/js/step2_eval.js index 3b1adbd648..83c04b834a 100644 --- a/js/step2_eval.js +++ b/js/step2_eval.js @@ -77,9 +77,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step3_env.js b/js/step3_env.js index 999531fcbb..cddf5d88ca 100644 --- a/js/step3_env.js +++ b/js/step3_env.js @@ -87,9 +87,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step4_if_fn_do.js b/js/step4_if_fn_do.js index 3878b03915..ce89e632d4 100644 --- a/js/step4_if_fn_do.js +++ b/js/step4_if_fn_do.js @@ -103,9 +103,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step5_tco.js b/js/step5_tco.js index a449194aa9..2a78715b9a 100644 --- a/js/step5_tco.js +++ b/js/step5_tco.js @@ -114,9 +114,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step6_file.js b/js/step6_file.js index 71b8eb5737..b166e7e1c9 100644 --- a/js/step6_file.js +++ b/js/step6_file.js @@ -124,9 +124,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step7_quote.js b/js/step7_quote.js index 6f22844cd2..3b414f177d 100644 --- a/js/step7_quote.js +++ b/js/step7_quote.js @@ -149,9 +149,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step8_macros.js b/js/step8_macros.js index fc8eb5fd2d..54e7a22a5c 100644 --- a/js/step8_macros.js +++ b/js/step8_macros.js @@ -177,9 +177,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/step9_try.js b/js/step9_try.js index 3eac1c9804..211e82aed9 100644 --- a/js/step9_try.js +++ b/js/step9_try.js @@ -188,9 +188,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/js/stepA_mal.js b/js/stepA_mal.js index b6dbab0c37..4e66230304 100644 --- a/js/stepA_mal.js +++ b/js/stepA_mal.js @@ -192,9 +192,9 @@ if (typeof require !== 'undefined' && require.main === module) { try { if (line) { printer.println(rep(line)); } } catch (exc) { - if (exc instanceof reader.BlankException) { continue; } - if (exc.stack) { printer.println(exc.stack); } - else { printer.println(exc); } + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } } } } diff --git a/livescript/step3_env.ls b/livescript/step3_env.ls index 3c7dfc5cb8..b6100f2d1b 100644 --- a/livescript/step3_env.ls +++ b/livescript/step3_env.ls @@ -120,5 +120,7 @@ loop break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/step4_if_fn_do.ls b/livescript/step4_if_fn_do.ls index e368ff2e42..212dd755c4 100644 --- a/livescript/step4_if_fn_do.ls +++ b/livescript/step4_if_fn_do.ls @@ -168,7 +168,7 @@ eval_fn = (env, params) -> eval_apply = (env, list) -> [fn, ...args] = list |> map eval_ast env if fn.type != \function - runtime-error "#{fn.value} is not a function" + runtime-error "#{fn.value} is not a function, got a #{fn.type}" fn.value.apply env, args @@ -190,5 +190,7 @@ loop break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/step5_tco.ls b/livescript/step5_tco.ls index 04be185498..f1279bd103 100644 --- a/livescript/step5_tco.ls +++ b/livescript/step5_tco.ls @@ -186,7 +186,7 @@ eval_fn = (env, params) -> eval_apply = (env, list) -> [fn, ...args] = list |> map eval_ast env if fn.type != \function - runtime-error "#{fn.value} is not a function" + runtime-error "#{fn.value} is not a function, got a #{fn.type}" fn.value.apply env, args @@ -208,5 +208,7 @@ loop break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/step6_file.ls b/livescript/step6_file.ls index 1844ebe80f..d1b3d6d7d1 100644 --- a/livescript/step6_file.ls +++ b/livescript/step6_file.ls @@ -187,7 +187,7 @@ eval_fn = (env, params) -> eval_apply = (env, list) -> [fn, ...args] = list |> map eval_ast env if fn.type != \function - runtime-error "#{fn.value} is not a function" + runtime-error "#{fn.value} is not a function, got a #{fn.type}" fn.value.apply env, args @@ -237,5 +237,7 @@ else break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/step7_quote.ls b/livescript/step7_quote.ls index 0deea8647f..c3635e9628 100644 --- a/livescript/step7_quote.ls +++ b/livescript/step7_quote.ls @@ -194,7 +194,7 @@ eval_fn = (env, params) -> eval_apply = (env, list) -> [fn, ...args] = list |> map eval_ast env if fn.type != \function - runtime-error "#{fn.value} is not a function" + runtime-error "#{fn.value} is not a function, got a #{fn.type}" fn.value.apply env, args @@ -278,5 +278,7 @@ else break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/step8_macros.ls b/livescript/step8_macros.ls index d256ca9a47..713191658c 100644 --- a/livescript/step8_macros.ls +++ b/livescript/step8_macros.ls @@ -199,7 +199,7 @@ eval_fn = (env, params) -> eval_apply = (env, list) -> [fn, ...args] = list |> map eval_ast env if fn.type != \function - runtime-error "#{fn.value} is not a function" + runtime-error "#{fn.value} is not a function, got a #{fn.type}" fn.value.apply env, args @@ -351,5 +351,7 @@ else break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/step9_try.ls b/livescript/step9_try.ls index 1b6fd3b2af..7170464cbf 100644 --- a/livescript/step9_try.ls +++ b/livescript/step9_try.ls @@ -200,7 +200,7 @@ eval_fn = (env, params) -> eval_apply = (env, list) -> [fn, ...args] = list |> map eval_ast env if fn.type != \function - runtime-error "#{fn.value} is not a function" + runtime-error "#{fn.value} is not a function, got a #{fn.type}" fn.value.apply env, args @@ -284,11 +284,13 @@ eval_macroexpand = (env, params) -> eval_try = (env, params) -> - if params.length != 2 - runtime-error "'try*' expected 2 parameters, + if params.length > 2 + runtime-error "'try*' expected 1 or 2 parameters, got #{params.length}" - try-form = params[0] + if params.length == 1 + return eval_ast env, try-form + catch-clause = params[1] if catch-clause.type != \list or catch-clause.value.length != 3 or @@ -380,5 +382,7 @@ else break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/livescript/stepA_mal.ls b/livescript/stepA_mal.ls index eb39d8f9bb..68db80f077 100644 --- a/livescript/stepA_mal.ls +++ b/livescript/stepA_mal.ls @@ -284,11 +284,13 @@ eval_macroexpand = (env, params) -> eval_try = (env, params) -> - if params.length != 2 - runtime-error "'try*' expected 2 parameters, + if params.length > 2 + runtime-error "'try*' expected 1 or 2 parameters, got #{params.length}" - try-form = params[0] + if params.length == 1 + return eval_ast env, try-form + catch-clause = params[1] if catch-clause.type != \list or catch-clause.value.length != 3 or @@ -393,5 +395,7 @@ else break if not line? or line == '' try console.log rep line - catch {message} - console.error message + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/matlab/core.m b/matlab/core.m index fe455d9491..2b2d10477d 100644 --- a/matlab/core.m +++ b/matlab/core.m @@ -118,8 +118,13 @@ function ret = nth(seq, idx) if idx+1 > length(seq) - throw(MException('Range:nth', ... - 'nth: index out of range')) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + error('Range:nth', ... + 'nth: index out of range'); + else + throw(MException('Range:nth', ... + 'nth: index out of range')) + end end ret = seq.get(idx+1); end @@ -180,8 +185,13 @@ elseif isa(obj, 'types.Nil') ret = type_utils.nil; else - throw(MException('Type:seq',... - 'seq: called on non-sequence')) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + error('Type:seq', ... + 'seq: called on non-sequence'); + else + throw(MException('Type:seq',... + 'seq: called on non-sequence')) + end end end diff --git a/matlab/step9_try.m b/matlab/step9_try.m index b54461e3be..da6447a799 100644 --- a/matlab/step9_try.m +++ b/matlab/step9_try.m @@ -142,7 +142,7 @@ function step9_try(varargin), main(varargin), end ret = EVAL(ast.get(3).get(3), catch_env); return; else - throw(e); + rethrow(e); end end case 'do' diff --git a/matlab/stepA_mal.m b/matlab/stepA_mal.m index 8883ac85b4..8094889f99 100644 --- a/matlab/stepA_mal.m +++ b/matlab/stepA_mal.m @@ -142,7 +142,7 @@ function stepA_mal(varargin), main(varargin), end ret = EVAL(ast.get(3).get(3), catch_env); return; else - throw(e); + rethrow(e); end end case 'do' diff --git a/miniMAL/step4_if_fn_do.json b/miniMAL/step4_if_fn_do.json index 699aa6d6ae..f4406719c2 100644 --- a/miniMAL/step4_if_fn_do.json +++ b/miniMAL/step4_if_fn_do.json @@ -76,7 +76,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/miniMAL/step5_tco.json b/miniMAL/step5_tco.json index bdc12a0b4d..5377cca35f 100644 --- a/miniMAL/step5_tco.json +++ b/miniMAL/step5_tco.json @@ -84,7 +84,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/miniMAL/step6_file.json b/miniMAL/step6_file.json index 67c608832f..27f4155390 100644 --- a/miniMAL/step6_file.json +++ b/miniMAL/step6_file.json @@ -84,7 +84,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/miniMAL/step7_quote.json b/miniMAL/step7_quote.json index 28b062c7ca..b4d6aabd24 100644 --- a/miniMAL/step7_quote.json +++ b/miniMAL/step7_quote.json @@ -109,7 +109,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/miniMAL/step8_macros.json b/miniMAL/step8_macros.json index 2383e4107e..b0b894d6e4 100644 --- a/miniMAL/step8_macros.json +++ b/miniMAL/step8_macros.json @@ -133,7 +133,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/miniMAL/step9_try.json b/miniMAL/step9_try.json index 8dfc0d2752..8b05eb8d3b 100644 --- a/miniMAL/step9_try.json +++ b/miniMAL/step9_try.json @@ -97,8 +97,10 @@ ["if", ["=", ["`", "macroexpand"], "a0"], ["macroexpand", ["nth", "ast", 1], "env"], ["if", ["=", ["`", "try*"], "a0"], - ["if", ["=", ["`", "catch*"], - ["get", ["nth", ["nth", "ast", 2], 0], ["`", "val"]]], + ["if", ["and", [">", ["count", "ast"], 2], + ["=", ["`", "catch*"], + ["get", ["nth", ["nth", "ast", 2], 0], + ["`", "val"]]]], ["try", ["EVAL", ["nth", "ast", 1], "env"], ["catch", "exc", @@ -144,7 +146,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/miniMAL/stepA_mal.json b/miniMAL/stepA_mal.json index 789f88a429..30683b8743 100644 --- a/miniMAL/stepA_mal.json +++ b/miniMAL/stepA_mal.json @@ -97,8 +97,10 @@ ["if", ["=", ["`", "macroexpand"], "a0"], ["macroexpand", ["nth", "ast", 1], "env"], ["if", ["=", ["`", "try*"], "a0"], - ["if", ["=", ["`", "catch*"], - ["get", ["nth", ["nth", "ast", 2], 0], ["`", "val"]]], + ["if", ["and", [">", ["count", "ast"], 2], + ["=", ["`", "catch*"], + ["get", ["nth", ["nth", "ast", 2], 0], + ["`", "val"]]]], ["try", ["EVAL", ["nth", "ast", 1], "env"], ["catch", "exc", @@ -144,7 +146,10 @@ ["try", ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], ["`", "core.mal: defined using miniMAL"], ["map", ["fn", ["k"], ["env-set", "repl-env", diff --git a/nasm/step9_try.asm b/nasm/step9_try.asm index 5c24b599fa..a9657287f1 100644 --- a/nasm/step9_try.asm +++ b/nasm/step9_try.asm @@ -2483,6 +2483,11 @@ _start: ; Check if an object was thrown cmp rsi, 0 je .catch_done_print ; nothing to print + + push rsi + print_str_mac error_string ; print 'Error: ' + pop rsi + mov rdi, 1 call pr_str mov rsi, rax diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index c47ee2f6d9..1a5014f4d1 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -2515,6 +2515,11 @@ _start: ; Check if an object was thrown cmp rsi, 0 je .catch_done_print ; nothing to print + + push rsi + print_str_mac error_string ; print 'Error: ' + pop rsi + mov rdi, 1 call pr_str mov rsi, rax diff --git a/nim/step9_try.nim b/nim/step9_try.nim index 97884ddc16..864ca91133 100644 --- a/nim/step9_try.nim +++ b/nim/step9_try.nim @@ -17,7 +17,7 @@ proc quasiquote(ast: MalType): MalType = return list(symbol "cons", quasiquote(ast.list[0]), quasiquote(list(ast.list[1 .. ^1]))) proc is_macro_call(ast: MalType, env: Env): bool = - ast.kind == List and ast.list[0].kind == Symbol and + ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro proc macroexpand(ast: MalType, env: Env): MalType = @@ -108,6 +108,8 @@ proc eval(ast: MalType, env: Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] + if ast.list.len <= 2: + return a1.eval(env) if a2.list[0].str == "catch*": try: return a1.eval(env) @@ -149,11 +151,9 @@ proc eval(ast: MalType, env: Env): MalType = a2.eval(newEnv) return malfun(fn, a2, a1, env) - else: - defaultApply() + else: defaultApply() - else: - defaultApply() + else: defaultApply() proc print(exp: MalType): string = exp.pr_str @@ -185,6 +185,11 @@ while true: let line = readLineFromStdin("user> ") echo line.rep except Blank: discard + except IOError: quit() + except MalError: + let exc = (ref MalError) getCurrentException() + echo "Error: " & exc.t.list[0].pr_str except: + stdout.write "Error: " echo getCurrentExceptionMsg() echo getCurrentException().getStackTrace() diff --git a/nim/stepA_mal.nim b/nim/stepA_mal.nim index abc3fbc1f6..4932da837a 100644 --- a/nim/stepA_mal.nim +++ b/nim/stepA_mal.nim @@ -108,6 +108,8 @@ proc eval(ast: MalType, env: Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] + if ast.list.len <= 2: + return a1.eval(env) if a2.list[0].str == "catch*": try: return a1.eval(env) @@ -189,6 +191,10 @@ while true: echo line.rep except Blank: discard except IOError: quit() + except MalError: + let exc = (ref MalError) getCurrentException() + echo "Error: " & exc.t.list[0].pr_str except: + stdout.write "Error: " echo getCurrentExceptionMsg() echo getCurrentException().getStackTrace() diff --git a/objc/step4_if_fn_do.m b/objc/step4_if_fn_do.m index 27e24827eb..a33ce66381 100644 --- a/objc/step4_if_fn_do.m +++ b/objc/step4_if_fn_do.m @@ -134,6 +134,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objc/step5_tco.m b/objc/step5_tco.m index 541e74c4c8..b5f61e7c5d 100644 --- a/objc/step5_tco.m +++ b/objc/step5_tco.m @@ -136,6 +136,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objc/step6_file.m b/objc/step6_file.m index 843e57e3cc..0c8c421f3b 100644 --- a/objc/step6_file.m +++ b/objc/step6_file.m @@ -157,6 +157,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objc/step7_quote.m b/objc/step7_quote.m index 4917b9abb5..34ef83bbd6 100644 --- a/objc/step7_quote.m +++ b/objc/step7_quote.m @@ -191,6 +191,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objc/step8_macros.m b/objc/step8_macros.m index e9d772a32a..5c3f69e922 100644 --- a/objc/step8_macros.m +++ b/objc/step8_macros.m @@ -227,6 +227,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objc/step9_try.m b/objc/step9_try.m index ac5039d1fd..23fe89f0c5 100644 --- a/objc/step9_try.m +++ b/objc/step9_try.m @@ -246,6 +246,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objc/stepA_mal.m b/objc/stepA_mal.m index 80822234e4..1a155ac812 100644 --- a/objc/stepA_mal.m +++ b/objc/stepA_mal.m @@ -249,6 +249,9 @@ int main () { printf("%s\n", [[REP(line, repl_env) description] UTF8String]); } @catch(NSString *e) { printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); } @catch(NSException *e) { if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } printf("Exception: %s\n", [[e reason] UTF8String]); diff --git a/objpascal/step9_try.pas b/objpascal/step9_try.pas index e8626974c0..7df833d937 100644 --- a/objpascal/step9_try.pas +++ b/objpascal/step9_try.pas @@ -331,7 +331,10 @@ function do_eval(Args : TMalArray) : TMal; On E : MalEOF do Halt(0); On E : Exception do begin - WriteLn('Error: ' + E.message); + if E.ClassType = TMalException then + WriteLn('Error: ' + pr_str((E as TMalException).Val, True)) + else + WriteLn('Error: ' + E.message); WriteLn('Backtrace:'); WriteLn(GetBacktrace(E)); end; diff --git a/objpascal/stepA_mal.pas b/objpascal/stepA_mal.pas index 93002dff22..bf5afdfa41 100644 --- a/objpascal/stepA_mal.pas +++ b/objpascal/stepA_mal.pas @@ -336,7 +336,10 @@ function do_eval(Args : TMalArray) : TMal; On E : MalEOF do Halt(0); On E : Exception do begin - WriteLn('Error: ' + E.message); + if E.ClassType = TMalException then + WriteLn('Error: ' + pr_str((E as TMalException).Val, True)) + else + WriteLn('Error: ' + E.message); WriteLn('Backtrace:'); WriteLn(GetBacktrace(E)); end; diff --git a/ocaml/core.ml b/ocaml/core.ml index 5c6f19761f..73a1378807 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -128,7 +128,8 @@ let init env = begin in concat)); Env.set env (Types.symbol "nth") - (Types.fn (function [xs; T.Int i] -> List.nth (seq xs) i | _ -> T.Nil)); + (Types.fn (function [xs; T.Int i] -> + (try List.nth (seq xs) i with _ -> raise (Invalid_argument "nth: index out of range")) | _ -> T.Nil)); Env.set env (Types.symbol "first") (Types.fn (function | [xs] -> (match seq xs with x :: _ -> x | _ -> T.Nil) diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml index 61cee2decc..daea9d8eaf 100644 --- a/ocaml/step9_try.ml +++ b/ocaml/step9_try.ml @@ -99,6 +99,8 @@ and eval ast env = eval (quasiquote ast) env | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> macroexpand ast env + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary]} -> + (eval scary env) | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; T.List { T.value = [T.Symbol { T.value = "catch*" }; local ; handler]}]} -> @@ -107,7 +109,7 @@ and eval ast env = let value = match exn with | Types.MalExn value -> value | Invalid_argument msg -> T.String msg - | _ -> (T.String "OCaml exception") in + | e -> (T.String (Printexc.to_string e)) in let sub_env = Env.make (Some env) in Env.set sub_env local value; eval handler sub_env) @@ -156,8 +158,8 @@ let rec main = | Invalid_argument x -> output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); flush stderr - | _ -> - output_string stderr ("Erroringness!\n"); + | e -> + output_string stderr ((Printexc.to_string e) ^ "\n"); flush stderr done with End_of_file -> () diff --git a/ocaml/stepA_mal.ml b/ocaml/stepA_mal.ml index a8cbd1c3a3..d427f8c079 100644 --- a/ocaml/stepA_mal.ml +++ b/ocaml/stepA_mal.ml @@ -99,6 +99,8 @@ and eval ast env = eval (quasiquote ast) env | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> macroexpand ast env + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary]} -> + (eval scary env) | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; T.List { T.value = [T.Symbol { T.value = "catch*" }; local ; handler]}]} -> @@ -107,7 +109,7 @@ and eval ast env = let value = match exn with | Types.MalExn value -> value | Invalid_argument msg -> T.String msg - | _ -> (T.String "OCaml exception") in + | e -> (T.String (Printexc.to_string e)) in let sub_env = Env.make (Some env) in Env.set sub_env local value; eval handler sub_env) @@ -160,8 +162,8 @@ let rec main = | Invalid_argument x -> output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); flush stderr - | _ -> - output_string stderr ("Erroringness!\n"); + | e -> + output_string stderr ((Printexc.to_string e) ^ "\n"); flush stderr done end diff --git a/perl/step9_try.pl b/perl/step9_try.pl index 8b4b06a9ec..17ce2d4d1b 100644 --- a/perl/step9_try.pl +++ b/perl/step9_try.pl @@ -254,8 +254,12 @@ sub REP { # ignore and continue } default { - chomp $err; - print "Error: $err\n"; + if (ref $err) { + print "Error: ".printer::_pr_str($err)."\n"; + } else { + chomp $err; + print "Error: $err\n"; + } } } }; diff --git a/perl/stepA_mal.pl b/perl/stepA_mal.pl index 2911ccf15b..a875ed168b 100644 --- a/perl/stepA_mal.pl +++ b/perl/stepA_mal.pl @@ -261,8 +261,12 @@ sub REP { # ignore and continue } default { - chomp $err; - print "Error: $err\n"; + if (ref $err) { + print "Error: ".printer::_pr_str($err)."\n"; + } else { + chomp $err; + print "Error: $err\n"; + } } } }; diff --git a/perl6/step9_try.pl b/perl6/step9_try.pl index 30c3a4ce74..23615889f3 100644 --- a/perl6/step9_try.pl +++ b/perl6/step9_try.pl @@ -103,6 +103,7 @@ ($ast is copy, $env is copy) when 'try*' { return eval($a1, $env); CATCH { + .rethrow if !$a2; my $ex = $_ ~~ X::MalThrow ?? .value !! MalString(.Str); my $new_env = $env; $env.set($a2[1].val, $ex); @@ -146,7 +147,8 @@ ($source_file?, *@args) while (my $line = prompt 'user> ').defined { say rep($line); CATCH { - when X::MalException { .Str.say } + when X::MalThrow { say "Error: " ~ pr_str(.value, True) } + when X::MalException { say "Error: " ~ .Str } } } } diff --git a/perl6/stepA_mal.pl b/perl6/stepA_mal.pl index 76c843ad2a..1f7dc5157e 100644 --- a/perl6/stepA_mal.pl +++ b/perl6/stepA_mal.pl @@ -103,6 +103,7 @@ ($ast is copy, $env is copy) when 'try*' { return eval($a1, $env); CATCH { + .rethrow if !$a2; my $ex = $_ ~~ X::MalThrow ?? .value !! MalString(.Str); my $new_env = $env; $env.set($a2[1].val, $ex); @@ -150,7 +151,8 @@ ($source_file?, *@args) while (my $line = prompt 'user> ').defined { say rep($line); CATCH { - when X::MalException { .Str.say } + when X::MalThrow { say "Error: " ~ pr_str(.value, True) } + when X::MalException { say "Error: " ~ .Str } } } } diff --git a/php/step9_try.php b/php/step9_try.php index 7b03d4ecfe..7f87f1b706 100644 --- a/php/step9_try.php +++ b/php/step9_try.php @@ -209,6 +209,8 @@ function rep($str) { } } catch (BlankException $e) { continue; + } catch (_Error $e) { + echo "Error: " . _pr_str($e->obj, True) . "\n"; } catch (Exception $e) { echo "Error: " . $e->getMessage() . "\n"; echo $e->getTraceAsString() . "\n"; diff --git a/php/stepA_mal.php b/php/stepA_mal.php index 115732b6ca..d1cb507f4c 100644 --- a/php/stepA_mal.php +++ b/php/stepA_mal.php @@ -222,6 +222,8 @@ function rep($str) { } } catch (BlankException $e) { continue; + } catch (_Error $e) { + echo "Error: " . _pr_str($e->obj, True) . "\n"; } catch (Exception $e) { echo "Error: " . $e->getMessage() . "\n"; echo $e->getTraceAsString() . "\n"; diff --git a/plsql/step9_try.sql b/plsql/step9_try.sql index a9205b49a1..d69eee379b 100644 --- a/plsql/step9_try.sql +++ b/plsql/step9_try.sql @@ -441,7 +441,11 @@ BEGIN io.close(1); -- close output stream RETURN 0; END IF; - io.writeline('Error: ' || SQLERRM); + IF SQLCODE <> -20000 THEN + io.writeline('Error: ' || SQLERRM); + ELSE + io.writeline('Error: ' || printer.pr_str(M, H, err_val)); + END IF; io.writeline(dbms_utility.format_error_backtrace); END; END LOOP; diff --git a/plsql/stepA_mal.sql b/plsql/stepA_mal.sql index 2391e3fefa..ea69541668 100644 --- a/plsql/stepA_mal.sql +++ b/plsql/stepA_mal.sql @@ -445,7 +445,11 @@ BEGIN io.close(1); -- close output stream RETURN 0; END IF; - io.writeline('Error: ' || SQLERRM); + IF SQLCODE <> -20000 THEN + io.writeline('Error: ' || SQLERRM); + ELSE + io.writeline('Error: ' || printer.pr_str(M, H, err_val)); + END IF; io.writeline(dbms_utility.format_error_backtrace); END; END LOOP; diff --git a/ps/core.ps b/ps/core.ps index de77ab27d56cfbbed9b88874730d6ff13bf01a2f..ae4aa8e0db90d14109340af4151ec1e04796a4f8 100644 GIT binary patch delta 166 zcmccSwBBXI22SbX)Ix>Kl!{mdT|0%mk_-@)pOnR=4`ffS5!YY_%1>tGS6~LJnY@5q zG#W@Nfb`^~=A{Fb=aeW^b16Up)GUSc)Do~*Eka5IXr7fqW?o8ag+hL5i9&vwLQ!H~ kda9;Ed`U)8emO|}*Q!Y&dK}&tdrjh3Qqnbs1BA36Xu_6B%}yt2Mc+E={Z6=AbOGr%j7dc`e32oLat!i zL0Ak-hY9O~>1JU+Fnv)NtZtHs5twTPrD4jeM9jhB8%4k-PrfUn4d&k!;g~ESssd!Q zPTnBSGuctp1T0=EDhH;u#YDk!)nZ(eH;cN1#eRuGe1$CMEe7$il%T-mTu~0F9*7fH oh=I%pdPPhEOg|A5oU9HsSCWN?8$IM62r5l}FCn~{O?(D70BZVXNdN!< delta 176 zcmXYnF$)1<0EQRoO5(fk?)xMWXOWXT1_LF-C5!Q_egQwhk9aZ>WiYTPi%mB9DHId4 zONOW3p7%NRSHWQ_*b2=>_xo8yNvB>gh9=b>}&bcZ#RdWJQ{%FzBiTo^}}N RGBcfF5%o8fJmxaX#21I9J39aX diff --git a/ps/stepA_mal.ps b/ps/stepA_mal.ps index 8e6611a41a4c534d2b6dbd3374195e54202fcfbc..c2b10eece6a41b494fe16279ce511fc869c67811 100644 GIT binary patch delta 385 zcmbQ_wZ><|HlfMYV%(GG2y%;NBo-?qCzd29e7zLpA|9$ z)Bl7tfi&ynXg z#1%}h78L{2b47H)^gkiC$rnUCz-$RoeK74VY6PY$p)^d-K~ZzC_zzKt+5Tc2lXb)( zZuJ)fiLp+u5pw{mc`wc}`G^?AE*lBn$@M@!NdALZAXwf}9O5@rIj+f*#Kpn#E5#+C z>bWML5r^3EUR(t%CoBPyW0|Zi0SX7v$&xHQe5k=Vd84?<??7U F2LQYAZ{Pp` delta 182 zcmZ4EGs$biHlfLHg~TUw2pdke71o?AAjL8{PgrJhpRn>IQU1wCgcT>h6!x5KCZaPr zO~iQeToKpF&qTx~iRw-^6!n|jEUG_wo2b#`H$V&&o@^s#KDk^>XYz6}?a4D$r6(&& zicaPdx1Bssf@5;9xY*=eaZ#`h1rqF&CyKjIz9VjkB4#QfJ~==_0;)y}s840`F(BU& OXwGj5&dte^CwTyjcRHN_ diff --git a/python/core.py b/python/core.py index 86a7ec8eb0..414a5a037f 100644 --- a/python/core.py +++ b/python/core.py @@ -2,13 +2,13 @@ from itertools import chain import mal_types as types -from mal_types import List, Vector +from mal_types import MalException, List, Vector import mal_readline import reader import printer # Errors/Exceptions -def throw(exc): raise Exception(exc) +def throw(obj): raise MalException(obj) # String functions diff --git a/python/mal_types.py b/python/mal_types.py index 32c42e1d69..a4bf288b01 100644 --- a/python/mal_types.py +++ b/python/mal_types.py @@ -30,11 +30,9 @@ def _equal_Q(a, b): if not _equal_Q(a[i], b[i]): return False return True elif _hash_map_Q(a): - akeys = a.keys() - bkeys = b.keys() + akeys = sorted(a.keys()) + bkeys = sorted(b.keys()) if len(akeys) != len(bkeys): return False - akeys.sort() - bkeys.sort() for i in range(len(akeys)): if akeys[i] != bkeys[i]: return False if not _equal_Q(a[akeys[i]], b[bkeys[i]]): return False @@ -58,6 +56,13 @@ def _clone(obj): else: return copy.copy(obj) +# +# Exception type +# + +class MalException(Exception): + def __init__(self, object): + self.object = object # Scalars def _nil_Q(exp): return exp is None diff --git a/python/step9_try.py b/python/step9_try.py index 80b7f5d2f5..a6fb42903d 100644 --- a/python/step9_try.py +++ b/python/step9_try.py @@ -99,14 +99,19 @@ def EVAL(ast, env): exec(compile(ast[1], '', 'single') in globals()) return None elif "try*" == a0: + if len(ast) < 3: + return EVAL(ast[1], env) a1, a2 = ast[1], ast[2] if a2[0] == "catch*": + err = None try: - return EVAL(a1, env); + return EVAL(a1, env) + except types.MalException as exc: + err = exc.object except Exception as exc: - exc = exc.args[0] - catch_env = Env(env, [a2[1]], [exc]) - return EVAL(a2[2], catch_env) + err = exc.args[0] + catch_env = Env(env, [a2[1]], [err]) + return EVAL(a2[2], catch_env) else: return EVAL(a1, env); elif "do" == a0: @@ -166,5 +171,7 @@ def REP(str): if line == "": continue print(REP(line)) except reader.Blank: continue + except types.MalException as e: + print("Error:", printer._pr_str(e.object)) except Exception as e: print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/python/stepA_mal.py b/python/stepA_mal.py index 2da3f7190f..576bc5ef90 100644 --- a/python/stepA_mal.py +++ b/python/stepA_mal.py @@ -102,14 +102,19 @@ def EVAL(ast, env): f = eval(ast[1]) return f(*el) elif "try*" == a0: + if len(ast) < 3: + return EVAL(ast[1], env) a1, a2 = ast[1], ast[2] if a2[0] == "catch*": + err = None try: - return EVAL(a1, env); + return EVAL(a1, env) + except types.MalException as exc: + err = exc.object except Exception as exc: - exc = exc.args[0] - catch_env = Env(env, [a2[1]], [exc]) - return EVAL(a2[2], catch_env) + err = exc.args[0] + catch_env = Env(env, [a2[1]], [err]) + return EVAL(a2[2], catch_env) else: return EVAL(a1, env); elif "do" == a0: @@ -173,5 +178,7 @@ def REP(str): if line == "": continue print(REP(line)) except reader.Blank: continue + except types.MalException as e: + print("Error:", printer._pr_str(e.object)) except Exception as e: print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/r/step9_try.r b/r/step9_try.r index 80c49487e3..2575baac34 100644 --- a/r/step9_try.r +++ b/r/step9_try.r @@ -189,7 +189,7 @@ repeat { tryCatch({ cat(rep(line),"\n", sep="") }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") + cat("Error: ", .pr_str(get_error(err),TRUE),"\n", sep="") }) # R debug/fatal with tracebacks: #cat(rep(line),"\n", sep="") diff --git a/r/stepA_mal.r b/r/stepA_mal.r index 7db7972ee9..ecdb89cfbf 100644 --- a/r/stepA_mal.r +++ b/r/stepA_mal.r @@ -193,7 +193,7 @@ repeat { tryCatch({ cat(rep(line),"\n", sep="") }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") + cat("Error: ", .pr_str(get_error(err),TRUE),"\n", sep="") }) # R debug/fatal with tracebacks: #cat(rep(line),"\n", sep="") diff --git a/rpython/step9_try.py b/rpython/step9_try.py index c39f808a00..6d2d8db3f5 100644 --- a/rpython/step9_try.py +++ b/rpython/step9_try.py @@ -111,6 +111,8 @@ def EVAL(ast, env): elif u"macroexpand" == a0sym: return macroexpand(ast[1], env) elif u"try*" == a0sym: + if len(ast) < 3: + return EVAL(ast[1], env); a1, a2 = ast[1], ast[2] a20 = a2[0] if isinstance(a20, MalSym): diff --git a/rpython/stepA_mal.py b/rpython/stepA_mal.py index 68a9960798..0e3d54e84f 100644 --- a/rpython/stepA_mal.py +++ b/rpython/stepA_mal.py @@ -120,6 +120,8 @@ def EVAL(ast, env): elif u"macroexpand" == a0sym: return macroexpand(ast[1], env) elif u"try*" == a0sym: + if len(ast) < 3: + return EVAL(ast[1], env); a1, a2 = ast[1], ast[2] a20 = a2[0] if isinstance(a20, MalSym): diff --git a/ruby/step9_try.rb b/ruby/step9_try.rb index 828f8c15ba..71d16be752 100644 --- a/ruby/step9_try.rb +++ b/ruby/step9_try.rb @@ -174,7 +174,11 @@ def PRINT(exp) begin puts REP[line] rescue Exception => e - puts "Error: #{e}" + if e.is_a? MalException + puts "Error: #{_pr_str(e.data, true)}" + else + puts "Error: #{e}" + end puts "\t#{e.backtrace.join("\n\t")}" end end diff --git a/ruby/stepA_mal.rb b/ruby/stepA_mal.rb index 54a660cc40..9071b74e74 100644 --- a/ruby/stepA_mal.rb +++ b/ruby/stepA_mal.rb @@ -184,7 +184,11 @@ def PRINT(exp) begin puts REP[line] rescue Exception => e - puts "Error: #{e}" + if e.is_a? MalException + puts "Error: #{_pr_str(e.data, true)}" + else + puts "Error: #{e}" + end puts "\t#{e.backtrace.join("\n\t")}" end end diff --git a/scheme/step4_if_fn_do.scm b/scheme/step4_if_fn_do.scm index 3a112d028e..b077be9a11 100644 --- a/scheme/step4_if_fn_do.scm +++ b/scheme/step4_if_fn_do.scm @@ -102,7 +102,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/scheme/step5_tco.scm b/scheme/step5_tco.scm index 51506e72bd..87a029158c 100644 --- a/scheme/step5_tco.scm +++ b/scheme/step5_tco.scm @@ -108,7 +108,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/scheme/step6_file.scm b/scheme/step6_file.scm index 79c34e51e7..1c7e956f73 100644 --- a/scheme/step6_file.scm +++ b/scheme/step6_file.scm @@ -116,7 +116,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/scheme/step7_quote.scm b/scheme/step7_quote.scm index 487a61037e..f0f2c80596 100644 --- a/scheme/step7_quote.scm +++ b/scheme/step7_quote.scm @@ -144,7 +144,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/scheme/step8_macros.scm b/scheme/step8_macros.scm index 8df319a3d2..c9f177e3ed 100644 --- a/scheme/step8_macros.scm +++ b/scheme/step8_macros.scm @@ -185,7 +185,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/scheme/step9_try.scm b/scheme/step9_try.scm index e9c0d3975d..b28e786ce2 100644 --- a/scheme/step9_try.scm +++ b/scheme/step9_try.scm @@ -103,16 +103,18 @@ ((macroexpand) (macroexpand (cadr items) env)) ((try*) - (let* ((form (cadr items)) - (handler (mal-value (list-ref items 2)))) - (guard - (ex ((error-object? ex) - (handle-catch - (mal-string (error-object-message ex)) - handler)) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (handle-catch (cdr ex) handler))) - (EVAL form env)))) + (if (< (length items) 3) + (EVAL (cadr items) env) + (let* ((form (cadr items)) + (handler (mal-value (list-ref items 2)))) + (guard + (ex ((error-object? ex) + (handle-catch + (mal-string (error-object-message ex)) + handler)) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (handle-catch (cdr ex) handler))) + (EVAL form env))))) ((let*) (let ((env* (make-env env)) (binds (->list (mal-value (cadr items)))) @@ -201,7 +203,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/scheme/stepA_mal.scm b/scheme/stepA_mal.scm index f2da4e98f8..1a64c51d48 100644 --- a/scheme/stepA_mal.scm +++ b/scheme/stepA_mal.scm @@ -103,16 +103,18 @@ ((macroexpand) (macroexpand (cadr items) env)) ((try*) - (let* ((form (cadr items)) - (handler (mal-value (list-ref items 2)))) - (guard - (ex ((error-object? ex) - (handle-catch - (mal-string (error-object-message ex)) - handler)) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (handle-catch (cdr ex) handler))) - (EVAL form env)))) + (if (< (length items) 3) + (EVAL (cadr items) env) + (let* ((form (cadr items)) + (handler (mal-value (list-ref items 2)))) + (guard + (ex ((error-object? ex) + (handle-catch + (mal-string (error-object-message ex)) + handler)) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (handle-catch (cdr ex) handler))) + (EVAL form env))))) ((let*) (let ((env* (make-env env)) (binds (->list (mal-value (cadr items)))) @@ -206,7 +208,11 @@ (when (not (memv 'empty-input (error-object-irritants ex))) (display "[error] ") (display (error-object-message ex)) - (newline)))) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) (display (rep input)) (newline)) (loop)))) diff --git a/swift3/Sources/step4_if_fn_do/main.swift b/swift3/Sources/step4_if_fn_do/main.swift index dabb4f2c1a..17b4c90b14 100644 --- a/swift3/Sources/step4_if_fn_do/main.swift +++ b/swift3/Sources/step4_if_fn_do/main.swift @@ -127,5 +127,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/swift3/Sources/step5_tco/main.swift b/swift3/Sources/step5_tco/main.swift index ae6e12a6bd..337d76f1ed 100644 --- a/swift3/Sources/step5_tco/main.swift +++ b/swift3/Sources/step5_tco/main.swift @@ -132,5 +132,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/swift3/Sources/step6_file/main.swift b/swift3/Sources/step6_file/main.swift index 84667cf884..e24a6b39ad 100644 --- a/swift3/Sources/step6_file/main.swift +++ b/swift3/Sources/step6_file/main.swift @@ -147,5 +147,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/swift3/Sources/step7_quote/main.swift b/swift3/Sources/step7_quote/main.swift index d228591a71..252d89f6d6 100644 --- a/swift3/Sources/step7_quote/main.swift +++ b/swift3/Sources/step7_quote/main.swift @@ -185,5 +185,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/swift3/Sources/step8_macros/main.swift b/swift3/Sources/step8_macros/main.swift index 11e851cee8..a53483f0f7 100644 --- a/swift3/Sources/step8_macros/main.swift +++ b/swift3/Sources/step8_macros/main.swift @@ -237,5 +237,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/swift3/Sources/step9_try/main.swift b/swift3/Sources/step9_try/main.swift index 6660900808..900dd3e371 100644 --- a/swift3/Sources/step9_try/main.swift +++ b/swift3/Sources/step9_try/main.swift @@ -270,5 +270,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/swift3/Sources/stepA_mal/main.swift b/swift3/Sources/stepA_mal/main.swift index 56d8fe4e88..8c796a057b 100644 --- a/swift3/Sources/stepA_mal/main.swift +++ b/swift3/Sources/stepA_mal/main.swift @@ -273,5 +273,7 @@ while true { print("Error: \(msg)") } catch (MalError.General(let msg)) { print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") } } diff --git a/tcl/step9_try.tcl b/tcl/step9_try.tcl index cbe6e798c3..d6a97d312a 100644 --- a/tcl/step9_try.tcl +++ b/tcl/step9_try.tcl @@ -267,7 +267,12 @@ while {true} { continue } if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" + if {$exception == "__MalException__"} { + set res [pr_str $::mal_exception_obj 1] + puts "Error: $res" + } else { + puts "Error: $exception" + } if { $DEBUG_MODE } { puts $::errorInfo } diff --git a/tcl/stepA_mal.tcl b/tcl/stepA_mal.tcl index 010c2f5230..23dcdb07a4 100644 --- a/tcl/stepA_mal.tcl +++ b/tcl/stepA_mal.tcl @@ -275,7 +275,12 @@ while {true} { continue } if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" + if {$exception == "__MalException__"} { + set res [pr_str $::mal_exception_obj 1] + puts "Error: $res" + } else { + puts "Error: $exception" + } if { $DEBUG_MODE } { puts $::errorInfo } diff --git a/tests/step9_try.mal b/tests/step9_try.mal index 5108914994..21e4132dbb 100644 --- a/tests/step9_try.mal +++ b/tests/step9_try.mal @@ -1,3 +1,11 @@ +;; +;; Testing throw + +(throw "err1") +;/.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*err1.* +(throw {:msg "err2"}) +;/.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*msg.*err2.* + ;; ;; Testing try*/catch* @@ -8,6 +16,11 @@ ;/"exc is:" "'abc' not found" ;=>nil +;; Make sure error from core can be caught +(try* (nth [] 1) (catch* exc (prn "exc is:" exc))) +;/"exc is:".*(length|range|[Bb]ounds|beyond).* +;=>nil + (try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7))) ;/"exc:" "my exception" ;=>7 @@ -304,6 +317,11 @@ ;;;; "exc is:" ["data" "foo"] ;;;;=>7 ;;;;=>7 +;; +;; Testing try* without catch* +(try* xyz) +;/.*\'?xyz\'? not found.* + ;; ;; Testing throwing non-strings (try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7))) diff --git a/ts/Makefile b/ts/Makefile index 902f2771c3..5b36261c10 100644 --- a/ts/Makefile +++ b/ts/Makefile @@ -11,7 +11,7 @@ all: ts node_modules: npm install -step%.js: node_modules types.ts reader.ts printer.ts env.ts core.ts +step%.js: node_modules types.ts reader.ts printer.ts env.ts core.ts step%.ts ./node_modules/.bin/tsc -p ./ diff --git a/ts/step4_if_fn_do.ts b/ts/step4_if_fn_do.ts index e98b4beae6..fd42ed738b 100644 --- a/ts/step4_if_fn_do.ts +++ b/ts/step4_if_fn_do.ts @@ -1,6 +1,6 @@ import { readline } from "./node_readline"; -import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isSeq } from "./types"; +import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isAST, isSeq } from "./types"; import { Env } from "./env"; import * as core from "./core"; import { readStr } from "./reader"; @@ -159,7 +159,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/ts/step5_tco.ts b/ts/step5_tco.ts index 02e881bbb6..04f76d4816 100644 --- a/ts/step5_tco.ts +++ b/ts/step5_tco.ts @@ -1,6 +1,6 @@ import { readline } from "./node_readline"; -import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isSeq } from "./types"; +import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isAST, isSeq } from "./types"; import { Env } from "./env"; import * as core from "./core"; import { readStr } from "./reader"; @@ -165,7 +165,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/ts/step6_file.ts b/ts/step6_file.ts index 225385da19..d86525f637 100644 --- a/ts/step6_file.ts +++ b/ts/step6_file.ts @@ -1,6 +1,6 @@ import { readline } from "./node_readline"; -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isSeq } from "./types"; +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; import { Env } from "./env"; import * as core from "./core"; import { readStr } from "./reader"; @@ -180,7 +180,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/ts/step7_quote.ts b/ts/step7_quote.ts index f360bfee61..df84c68346 100644 --- a/ts/step7_quote.ts +++ b/ts/step7_quote.ts @@ -1,6 +1,6 @@ import { readline } from "./node_readline"; -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isSeq } from "./types"; +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; import { Env } from "./env"; import * as core from "./core"; import { readStr } from "./reader"; @@ -226,7 +226,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/ts/step8_macros.ts b/ts/step8_macros.ts index d3152fb298..5de9415e9a 100644 --- a/ts/step8_macros.ts +++ b/ts/step8_macros.ts @@ -1,6 +1,6 @@ import { readline } from "./node_readline"; -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isSeq } from "./types"; +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; import { Env } from "./env"; import * as core from "./core"; import { readStr } from "./reader"; @@ -292,7 +292,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/ts/step9_try.ts b/ts/step9_try.ts index cae3d1dc9b..d949938f1b 100644 --- a/ts/step9_try.ts +++ b/ts/step9_try.ts @@ -194,6 +194,9 @@ function evalMal(ast: MalType, env: Env): MalType { try { return evalMal(ast.list[1], env); } catch (e) { + if (ast.list.length < 3) { + throw e; + } const catchBody = ast.list[2]; if (!isSeq(catchBody)) { throw new Error(`unexpected return type: ${catchBody.type}, expected: list or vector`); @@ -314,7 +317,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/ts/stepA_mal.ts b/ts/stepA_mal.ts index 6943ce6c6d..9546cbd47c 100644 --- a/ts/stepA_mal.ts +++ b/ts/stepA_mal.ts @@ -194,6 +194,9 @@ function evalMal(ast: MalType, env: Env): MalType { try { return evalMal(ast.list[1], env); } catch (e) { + if (ast.list.length < 3) { + throw e; + } const catchBody = ast.list[2]; if (!isSeq(catchBody)) { throw new Error(`unexpected return type: ${catchBody.type}, expected: list or vector`); @@ -318,7 +321,11 @@ while (true) { try { console.log(rep(line)); } catch (e) { - const err: Error = e; - console.error(err.message); + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } } } diff --git a/vb/step9_try.vb b/vb/step9_try.vb index e94cca7824..65158adde3 100644 --- a/vb/step9_try.vb +++ b/vb/step9_try.vb @@ -191,8 +191,8 @@ Namespace Mal DirectCast(a2,MalList).slice(1,2), New MalList(exc))) End If - Throw e End If + Throw e End Try Case "do" eval_ast(ast.slice(1, ast.size()-1), env) diff --git a/vb/stepA_mal.vb b/vb/stepA_mal.vb index 08ba138c6f..39a2a1eed6 100644 --- a/vb/stepA_mal.vb +++ b/vb/stepA_mal.vb @@ -191,8 +191,8 @@ Namespace Mal DirectCast(a2,MalList).slice(1,2), New MalList(exc))) End If - Throw e End If + Throw e End Try Case "do" eval_ast(ast.slice(1, ast.size()-1), env) diff --git a/vimscript/step9_try.vim b/vimscript/step9_try.vim index 421e59cd74..da0ea89922 100644 --- a/vimscript/step9_try.vim +++ b/vimscript/step9_try.vim @@ -247,7 +247,11 @@ while 1 try call PrintLn(REP(line, repl_env)) catch - call PrintLn("Error: " . v:exception) + if v:exception == "__MalException__" + call PrintLn("Error: " . PrStr(g:MalExceptionObj, 1)) + else + call PrintLn("Error: " . v:exception) + end endtry endwhile qall! diff --git a/vimscript/stepA_mal.vim b/vimscript/stepA_mal.vim index 2f64d98747..4c416ad943 100644 --- a/vimscript/stepA_mal.vim +++ b/vimscript/stepA_mal.vim @@ -252,7 +252,11 @@ while 1 try call PrintLn(REP(line, repl_env)) catch - call PrintLn("Error: " . v:exception) + if v:exception == "__MalException__" + call PrintLn("Error: " . PrStr(g:MalExceptionObj, 1)) + else + call PrintLn("Error: " . v:exception) + end endtry endwhile qall! diff --git a/wasm/step4_if_fn_do.wam b/wasm/step4_if_fn_do.wam index d52da0e6ee..902ec36a52 100644 --- a/wasm/step4_if_fn_do.wam +++ b/wasm/step4_if_fn_do.wam @@ -269,7 +269,7 @@ (func $main (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0) + $res 0 $repl_env 0 $ms 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -300,7 +300,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam index c7a0984438..ca0aeb1364 100644 --- a/wasm/step5_tco.wam +++ b/wasm/step5_tco.wam @@ -318,7 +318,7 @@ (func $main (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0) + $res 0 $repl_env 0 $ms 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -349,7 +349,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam index 4898f21a18..e3029b03be 100644 --- a/wasm/step6_file.wam +++ b/wasm/step6_file.wam @@ -323,9 +323,9 @@ (func $main (param $argc i32 $argv i32) (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 + $res 0 $repl_env 0 $ms 0 ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) + $i 0 $ret 0 $empty 0 $current 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -404,7 +404,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam index bfbfed10f7..753f97a8ad 100644 --- a/wasm/step7_quote.wam +++ b/wasm/step7_quote.wam @@ -385,9 +385,9 @@ (func $main (param $argc i32 $argv i32) (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 + $res 0 $repl_env 0 $ms 0 ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) + $i 0 $ret 0 $empty 0 $current 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -466,7 +466,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam index 445d0fea11..95d0642d8b 100644 --- a/wasm/step8_macros.wam +++ b/wasm/step8_macros.wam @@ -468,9 +468,9 @@ (func $main (param $argc i32 $argv i32) (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 + $res 0 $repl_env 0 $ms 0 ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) + $i 0 $ret 0 $empty 0 $current 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -551,7 +551,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam index 61d91003cd..312314b380 100644 --- a/wasm/step9_try.wam +++ b/wasm/step9_try.wam @@ -515,9 +515,9 @@ (func $main (param $argc i32 $argv i32) (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 + $res 0 $repl_env 0 $ms 0 ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) + $i 0 $ret 0 $empty 0 $current 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -598,7 +598,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index 495e3e6807..f1bed3d709 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -515,9 +515,9 @@ (func $main (param $argc i32 $argv i32) (result i32) (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 + $res 0 $repl_env 0 $ms 0 ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $tmp 0 $val2 0) + $i 0 $ret 0 $empty 0 $current 0 $val2 0) ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) @@ -602,7 +602,14 @@ (set_local $res ($REP $line $repl_env)) (if (get_global $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + (if (i32.eq 2 (get_global $error_type)) + (then + (set_local $ms ($pr_str (get_global $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (get_global $error_val))) + (else + ($printf_1 "Error: %s\n" (get_global $error_str)))) (set_global $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) diff --git a/yorick/step9_try.i b/yorick/step9_try.i index a4434974ea..bb1c2123be 100644 --- a/yorick/step9_try.i +++ b/yorick/step9_try.i @@ -134,7 +134,7 @@ func EVAL(ast, env) return macroexpand(*lst(2), env) } else if (a1 == "try*") { ret = EVAL(*lst(2), env) - if (structof(ret) == MalError) { + if (structof(ret) == MalError && numberof(lst) > 2) { exc = *ret.obj if (is_void(exc)) { exc = MalString(val=ret.message) @@ -255,7 +255,14 @@ func main(void) if (!line) break if (strlen(line) > 0) { result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message + if (structof(result) == MalError) { + exc = *result.obj + if (is_void(exc)) { + write, format="Error: %s\n", result.message + } else { + write, format="Error: %s\n", pr_str(exc, 1) + } + } else write, format="%s\n", result } } diff --git a/yorick/stepA_mal.i b/yorick/stepA_mal.i index 53829636dc..1a629028b3 100644 --- a/yorick/stepA_mal.i +++ b/yorick/stepA_mal.i @@ -134,7 +134,7 @@ func EVAL(ast, env) return macroexpand(*lst(2), env) } else if (a1 == "try*") { ret = EVAL(*lst(2), env) - if (structof(ret) == MalError) { + if (structof(ret) == MalError && numberof(lst) > 2) { exc = *ret.obj if (is_void(exc)) { exc = MalString(val=ret.message) @@ -223,12 +223,10 @@ func prepare_argv_list(args) } repl_env = nil -stdin_file = open("/dev/stdin", "r") func main(void) { extern repl_env - extern stdin_file repl_env = env_new(pointer(0)) // core.i: defined using Yorick @@ -254,13 +252,21 @@ func main(void) } RE, "(println (str \"Mal [\" *host-language* \"]\"))", repl_env + stdin_file = open("/dev/stdin", "r") while (1) { write, format="%s", "user> " line = rdline(stdin_file, prompt="") if (!line) break if (strlen(line) > 0) { result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message + if (structof(result) == MalError) { + exc = *result.obj + if (is_void(exc)) { + write, format="Error: %s\n", result.message + } else { + write, format="Error: %s\n", pr_str(exc, 1) + } + } else write, format="%s\n", result } } From 24c6bbf7a69929d47429ad329d233585962a3f39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E9=99=86=E9=81=A5?= Date: Tue, 18 Dec 2018 14:05:56 +0800 Subject: [PATCH 0420/1998] In objc. Modified conj, meta and with-meta to pass all the tests in stepA. --- objc/core.m | 20 +++++++++++++++----- objc/types.m | 4 ++++ 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/objc/core.m b/objc/core.m index 2acceeec8b..3a77d0db86 100644 --- a/objc/core.m +++ b/objc/core.m @@ -6,6 +6,7 @@ #import "printer.h" #import "malfunc.h" #import "core.h" +#import NSObject * wrap_tf(BOOL val) { return val ? [MalTrue alloc] : [MalFalse alloc]; @@ -268,7 +269,7 @@ + (NSDictionary *)ns { if ([args[0] isKindOfClass:[MalVector class]]) { [res addObjectsFromArray:args[0]]; [res addObjectsFromArray:_rest(args)]; - return (NSObject *)[MalVector arrayWithArray:res]; + return (NSObject *)[MalVector fromArray:res]; } else { [res addObjectsFromArray:[[_rest(args) reverseObjectEnumerator] allObjects]]; @@ -299,20 +300,29 @@ + (NSDictionary *)ns { } }, - @"meta": ^(NSArray *args){ + @"meta": ^id (NSArray *args){ if ([args[0] isKindOfClass:[MalFunc class]]) { return [(MalFunc *)args[0] meta]; } else { - return (NSObject *)[NSNull alloc]; + id res = objc_getAssociatedObject(args[0], @"meta"); + return res ? res : (NSObject *)[NSNull alloc]; } }, - @"with-meta": ^(NSArray *args){ + @"with-meta": ^id (NSArray *args){ if ([args[0] isKindOfClass:[MalFunc class]]) { MalFunc * cmf = [(MalFunc *)args[0] copy]; cmf.meta = args[1]; return cmf; + } else if (!block_Q(args[0])) { + id res = [args[0] copy]; + objc_setAssociatedObject(res, @"meta", args[1], OBJC_ASSOCIATION_RETAIN_NONATOMIC); + return res; } else { - @throw @"with-meta: object type not supported"; + id (^blk)(NSArray *args) = args[0]; + id (^wrapBlock)(NSArray *args) = ^id (NSArray *args) { return blk(args); }; + id (^res)(NSArray *args) = [wrapBlock copy]; // under mrc: copy to get a malloc block instead of a stack block. + objc_setAssociatedObject(res, @"meta", args[1], OBJC_ASSOCIATION_RETAIN_NONATOMIC); + return res; } }, @"atom": ^(NSArray *args){ diff --git a/objc/types.m b/objc/types.m index 55a2e43532..356c746223 100644 --- a/objc/types.m +++ b/objc/types.m @@ -91,6 +91,10 @@ - (id)objectAtIndex:(NSUInteger)index { return _array[index]; } +- (id)copyWithZone:(NSZone *)zone { + return [[MalVector alloc] initWithArray:[_array copy]]; +} + @end From 7aaf054b0a880921135847fad9233545048a7ba0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Fri, 4 Jan 2019 17:03:00 -0600 Subject: [PATCH 0421/1998] tests/step3_env: don't assume def! is lexical. --- tests/step3_env.mal | 4 ---- 1 file changed, 4 deletions(-) diff --git a/tests/step3_env.mal b/tests/step3_env.mal index 1539e5625e..cc8270d87f 100644 --- a/tests/step3_env.mal +++ b/tests/step3_env.mal @@ -62,10 +62,6 @@ y ;=>4 (let* (z 2) (let* (q 9) a)) ;=>4 -(let* (x 4) (def! a 5)) -;=>5 -a -;=>4 ;>>> deferrable=True ;>>> optional=True From 70cefa38a9e247a46a1d84a2c44e74162b8b5978 Mon Sep 17 00:00:00 2001 From: Raj Mahey Date: Thu, 10 Jan 2019 13:30:21 -0800 Subject: [PATCH 0422/1998] Updated README change "yes the" into "yes, the". Stylised make command and changed download to downloaded --- README.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 1b68bbfeb9..9b5f7a763c 100644 --- a/README.md +++ b/README.md @@ -108,7 +108,7 @@ The mal (make a lisp) steps are: Mal was presented publicly for the first time in a lightning talk at Clojure West 2014 (unfortunately there is no video). See examples/clojurewest2014.mal for the presentation that was given at the -conference (yes the presentation is a mal program). At Midwest.io +conference (yes, the presentation is a mal program). At Midwest.io 2015, Joel Martin gave a presentation on Mal titled "Achievement Unlocked: A Better Path to Language Learning". [Video](https://www.youtube.com/watch?v=lgyOAiRtZGw), @@ -131,7 +131,7 @@ FAQ](docs/FAQ.md) where I attempt to answer some common questions. The simplest way to run any given implementation is to use docker. Every implementation has a docker image pre-built with language -dependencies installed. You can launch the REPL using a convenience +dependencies installed. You can launch the REPL using a convenient target in the top level Makefile (where IMPL is the implementation directory name and stepX is the step to run): @@ -1232,10 +1232,10 @@ make "docker-build^IMPL" **Notes**: * Docker images are named *"kanaka/mal-test-IMPL"* * JVM-based language implementations (Groovy, Java, Clojure, Scala): - you will probably need to run these implementations once manually - first (make DOCKERIZE=1 "repl^IMPL")before you can run tests because + you will probably need to run this command once manually + first `make DOCKERIZE=1 "repl^IMPL"` before you can run tests because runtime dependencies need to be downloaded to avoid the tests timing - out. These dependencies are download to dot-files in the /mal + out. These dependencies are downloaded to dot-files in the /mal directory so they will persist between runs. ## Projects using mal From 99472e257661daa131a2e16f0c905c9a586115dd Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 12 Jan 2019 14:57:58 -0600 Subject: [PATCH 0423/1998] Clojure: reader/printer instead of monkey patching Update the Clojure/ClojureScript implementation to have full reader and printer/pr-str impementation instead of monkey patching Clojure's reader and print functions. --- clojure/Makefile | 2 +- clojure/src/mal/core.cljc | 26 +++--- clojure/src/mal/printer.cljc | 90 +++++++-------------- clojure/src/mal/reader.cljc | 110 ++++++++++++++++++-------- clojure/src/mal/step1_read_print.cljc | 2 +- clojure/src/mal/step2_eval.cljc | 2 +- clojure/src/mal/step3_env.cljc | 2 +- clojure/src/mal/step4_if_fn_do.cljc | 2 +- clojure/src/mal/step5_tco.cljc | 2 +- clojure/src/mal/step6_file.cljc | 2 +- clojure/src/mal/step7_quote.cljc | 2 +- clojure/src/mal/step8_macros.cljc | 2 +- clojure/src/mal/step9_try.cljc | 2 +- clojure/src/mal/stepA_mal.cljc | 2 +- 14 files changed, 127 insertions(+), 121 deletions(-) diff --git a/clojure/Makefile b/clojure/Makefile index f994b5ea0a..f5b4f20ccc 100644 --- a/clojure/Makefile +++ b/clojure/Makefile @@ -1,6 +1,6 @@ clojure_MODE ?= clj SOURCES_UTIL = src/mal/readline.$(clojure_MODE) -SOURCES_BASE = $(SOURCES_UTIL) src/mal/printer.cljc +SOURCES_BASE = $(SOURCES_UTIL) src/mal/reader.cljc src/mal/printer.cljc SOURCES_LISP = src/mal/env.cljc src/mal/core.cljc src/mal/stepA_mal.cljc SRCS = $(SOURCES_BASE) src/mal/env.cljc src/mal/core.cljc SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) diff --git a/clojure/src/mal/core.cljc b/clojure/src/mal/core.cljc index 283c9a3907..3e023b307a 100644 --- a/clojure/src/mal/core.cljc +++ b/clojure/src/mal/core.cljc @@ -1,7 +1,9 @@ (ns mal.core - (:require [mal.readline :as readline] + (:refer-clojure :exclude [pr-str]) + (:require [clojure.string :refer [join]] + [mal.readline :as readline] [mal.reader :as reader] - [mal.printer :as printer])) + [mal.printer :refer [pr-str atom?]])) ;; Errors/exceptions (defn mal_throw [obj] @@ -14,10 +16,6 @@ #?(:clj (defn time-ms [] (System/currentTimeMillis)) :cljs (defn time-ms [] (.getTime (js/Date.)))) -;; Atom functions -#?(:clj (defn atom? [atm] (= (type atm) clojure.lang.Atom)) - :cljs (defn atom? [atm] (satisfies? IAtom atm))) - ;; Metadata functions ;; - store metadata at :meta key of the real metadata (defn mal_with_meta [obj m] @@ -43,10 +41,10 @@ ['fn? (fn [o] (if (and (fn? o) (not (:ismacro (meta o)))) true false))] ['macro? (fn [o] (if (and (fn? o) (:ismacro (meta o))) true false))] - ['pr-str pr-str] - ['str printer/_str] - ['prn prn] - ['println println] + ['pr-str (fn [& xs] (join " " (map #(pr-str % true) xs)))] + ['str (fn [& xs] (join "" (map #(pr-str % false) xs)))] + ['prn (fn [& xs] (println (join " " (map #(pr-str % true) xs))))] + ['println (fn [& xs] (println (join " " (map #(pr-str % false) xs))))] ['readline readline/readline] ['read-string reader/read-string] ['slurp slurp] @@ -59,7 +57,7 @@ ['* *] ['/ /] ['time-ms time-ms] - + ['list list] ['list? seq?] ['vector vector] @@ -72,17 +70,17 @@ ['contains? contains?] ['keys (fn [hm] (let [ks (keys hm)] (if (nil? ks) '() ks)))] ['vals (fn [hm] (let [vs (vals hm)] (if (nil? vs) '() vs)))] - + ['sequential? sequential?] ['cons cons] - ['concat concat] + ['concat #(apply list (apply concat %&))] ['nth nth] ['first first] ['rest rest] ['empty? empty?] ['count count] ['apply apply] - ['map #(doall (map %1 %2))] + ['map #(apply list (map %1 %2))] ['conj conj] ['seq (fn [obj] (seq (if (string? obj) (map str obj) obj)))] diff --git a/clojure/src/mal/printer.cljc b/clojure/src/mal/printer.cljc index dc4d76a405..1d1d92ee99 100644 --- a/clojure/src/mal/printer.cljc +++ b/clojure/src/mal/printer.cljc @@ -1,63 +1,29 @@ -(ns mal.printer) +(ns mal.printer + (:refer-clojure :exclude [pr-str]) + (:require [clojure.string :as S])) + +;; atom? +#?(:clj (defn atom? [atm] (= (type atm) clojure.lang.Atom)) + :cljs (defn atom? [atm] (satisfies? IAtom atm))) + +(defn escape [s] + (-> s (S/replace "\\" "\\\\") + (S/replace "\"" "\\\"") + (S/replace "\n" "\\n"))) + +(defn pr-str + ([obj] (pr-str obj true)) + ([obj print-readably] + (let [_r print-readably] + (cond + (= nil obj) "nil" + (string? obj) (if _r (str "\"" (escape obj) "\"") obj) + + (list? obj) (str "(" (S/join " " (map #(pr-str % _r) obj)) ")") + (vector? obj) (str "[" (S/join " " (map #(pr-str % _r) obj)) "]") + (map? obj) (str "{" (S/join " " (map (fn [[k v]] + (str (pr-str k _r) " " + (pr-str v _r))) obj)) "}") + (atom? obj) (str "(atom " (pr-str @obj _r) ")") + :else (str obj))))) -#?(:clj (import '(java.io Writer))) - -;; TODO Better: -;; (extend-protocol IPrintWithWriter -;; Atom -;; ... -;; PersistentArrayMap -;; ... -;; PersistentHashMap -;; ...) - -;; Override atom printer -#?(:clj (defmethod clojure.core/print-method clojure.lang.Atom [a writer] - (.write writer "(atom ") - (.write writer (pr-str @a)) - (.write writer ")")) - :cljs (extend-type Atom - IPrintWithWriter - (-pr-writer [a writer _] - (-write writer (str "(atom " (pr-str @a) ")"))))) - - -;; Override hash-map printer to remove comma separators -#?(:clj (defmethod print-method clojure.lang.IPersistentMap [hm ^Writer w] - (.write w "{") - (when-let [xs (seq hm)] - (loop [[[k v] & xs] xs] - (print-method k w) - (.write w " ") - (print-method v w) - (when xs (.write w " ") (recur xs)))) - (.write w "}")) - :cljs (extend-type PersistentHashMap - IPrintWithWriter - (-pr-writer [hm w _] - (-write w "{") - (when-let [xs (seq hm)] - (loop [[[k v] & xs] xs] - (-write w (pr-str k)) - (-write w " ") - (-write w (pr-str v)) - (when xs (-write w " ") (recur xs)))) - (-write w "}")))) - - -;; Add a version of str that is the same all the way down (no -;; print-readably and nil printing all the way down) -(defn- pr- - ([] nil) - ([x] - #?(:clj (print-method x *out*) - :cljs (pr x))) - ([x & more] - (pr- x) - (if-let [nmore (next more)] - (recur (first more) nmore) - (apply pr- more)))) - -(defn _str [& xs] - (binding [*print-readably* nil] - (with-out-str (apply pr- xs)))) diff --git a/clojure/src/mal/reader.cljc b/clojure/src/mal/reader.cljc index fbe36d5788..93b2df3b52 100644 --- a/clojure/src/mal/reader.cljc +++ b/clojure/src/mal/reader.cljc @@ -1,37 +1,79 @@ (ns mal.reader - (:refer-clojure :exclude [read-string]) - #?(:clj (:require [clojure.tools.reader :as r] - [clojure.tools.reader.reader-types :as rt])) - #?(:cljs (:require [cljs.tools.reader :as r] - [cljs.tools.reader.reader-types :as rt]))) - -;; change tools.reader syntax-quote to quasiquote -(defn- wrap [sym] - (fn [rdr _] (list sym (#'r/read rdr true nil)))) - -(defn- wrap-with [sym] - (fn [rdr arg _] (list sym (#'r/read rdr true nil) arg))) - -;; Override some tools.reader reader macros so that we can do our own -;; metadata and quasiquote handling -(def new-rmacros - (fn [f] - (fn [ch] - (case ch - \` (wrap 'quasiquote) - \~ (fn [rdr comma] - (if-let [ch (rt/peek-char rdr)] - (if (identical? \@ ch) - ((wrap 'splice-unquote) (doto rdr rt/read-char) \@) - ((wrap 'unquote) rdr \~)))) - \^ (fn [rdr comma] - (let [m (#'r/read rdr)] - ((wrap-with 'with-meta) rdr m \^))) - \@ (wrap 'deref) - (f ch))))) - -#?(:clj (alter-var-root #'r/macros new-rmacros) - :cljs (set! r/macros (new-rmacros r/macros))) + (:refer-clojure :exclude [read-string]) + (:require [clojure.string :as S])) + +(defn throw-str [s] + (throw #?(:cljs (js/Error. s) + :clj (Exception. s)))) + +(defn rdr [tokens] + {:tokens (vec tokens) :position (atom 0)}) + +(defn rdr-peek [rdr] + (get (vec (:tokens rdr)) @(:position rdr))) + +(defn rdr-next [rdr] + (get (vec (:tokens rdr)) (dec (swap! (:position rdr) inc)))) + +(def tok-re #"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\].|[^\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)") +(def int-re #"^-?[0-9]+$") +(def str-re #"^\"(.*)\"$") + +(defn tokenize [s] + (filter #(not= \; (first %)) + (map second (re-seq tok-re s)))) + +(defn unescape [s] + (-> s (S/replace "\\\\" "\u029e") + (S/replace "\\\"" "\"") + (S/replace "\\n" "\n") + (S/replace "\u029e" "\\"))) + +(defn read-atom [rdr] + (let [token (rdr-next rdr)] + (cond + (re-seq int-re token) #?(:cljs (js/parseInt token) + :clj (Integer/parseInt token)) + (re-seq str-re token) (unescape (second (re-find str-re token))) + (= \: (get token 0)) (keyword (subs token 1)) + (= "nil" token) nil + (= "true" token) true + (= "false" token) false + :else (symbol token)))) + +(declare read-form) + +(defn read-seq [rdr start end] + (assert (= start (rdr-next rdr))) ;; pull off start + (loop [lst []] + (let [token (rdr-peek rdr)] + (cond + (= token end) (do (rdr-next rdr) lst) + (not token) (throw-str (str "expected '" end "', got EOF")) + :else (recur (conj lst (read-form rdr))))))) + +(defn read-form [rdr] + (let [tok (rdr-peek rdr)] + (cond + (= "'" tok) (do (rdr-next rdr) (list 'quote (read-form rdr))) + (= "`" tok) (do (rdr-next rdr) (list 'quasiquote (read-form rdr))) + (= "~" tok) (do (rdr-next rdr) (list 'unquote (read-form rdr))) + (= "~@" tok) (do (rdr-next rdr) (list 'splice-unquote (read-form rdr))) + + (= "^" tok) (do (rdr-next rdr) (let [m (read-form rdr)] + (list 'with-meta (read-form rdr) m))) + (= "@" tok) (do (rdr-next rdr) (list 'deref (read-form rdr))) + + (= ")" tok) (throw-str "unexpected ')'") + (= "(" tok) (apply list (read-seq rdr "(" ")")) + + (= "]" tok) (throw-str "unexpected ']'") + (= "[" tok) (vec (read-seq rdr "[" "]")) + + (= "}" tok) (throw-str "unexpected '}'") + (= "{" tok) (apply hash-map (read-seq rdr "{" "}")) + + :else (read-atom rdr)))) (defn read-string [s] - (r/read-string s)) + (read-form (rdr (tokenize s)))) diff --git a/clojure/src/mal/step1_read_print.cljc b/clojure/src/mal/step1_read_print.cljc index d942174286..2b95bffbdb 100644 --- a/clojure/src/mal/step1_read_print.cljc +++ b/clojure/src/mal/step1_read_print.cljc @@ -14,7 +14,7 @@ ast) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (defn rep diff --git a/clojure/src/mal/step2_eval.cljc b/clojure/src/mal/step2_eval.cljc index 51c0042239..2727f0585c 100644 --- a/clojure/src/mal/step2_eval.cljc +++ b/clojure/src/mal/step2_eval.cljc @@ -42,7 +42,7 @@ (apply f args))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env {'+ + diff --git a/clojure/src/mal/step3_env.cljc b/clojure/src/mal/step3_env.cljc index 2779574ac9..6a2c8da5a3 100644 --- a/clojure/src/mal/step3_env.cljc +++ b/clojure/src/mal/step3_env.cljc @@ -54,7 +54,7 @@ (apply f args)))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/step4_if_fn_do.cljc b/clojure/src/mal/step4_if_fn_do.cljc index 4cca3a3b2c..fe3e4c9b02 100644 --- a/clojure/src/mal/step4_if_fn_do.cljc +++ b/clojure/src/mal/step4_if_fn_do.cljc @@ -70,7 +70,7 @@ (apply f args)))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/step5_tco.cljc b/clojure/src/mal/step5_tco.cljc index 886c4911a0..dc1209e1e6 100644 --- a/clojure/src/mal/step5_tco.cljc +++ b/clojure/src/mal/step5_tco.cljc @@ -79,7 +79,7 @@ (apply f args)))))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/step6_file.cljc b/clojure/src/mal/step6_file.cljc index e7b884dcc0..6e9ac76279 100644 --- a/clojure/src/mal/step6_file.cljc +++ b/clojure/src/mal/step6_file.cljc @@ -79,7 +79,7 @@ (apply f args)))))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/step7_quote.cljc b/clojure/src/mal/step7_quote.cljc index a22645b019..f1eccfed46 100644 --- a/clojure/src/mal/step7_quote.cljc +++ b/clojure/src/mal/step7_quote.cljc @@ -102,7 +102,7 @@ (apply f args)))))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/step8_macros.cljc b/clojure/src/mal/step8_macros.cljc index f5a552084a..48f8551f84 100644 --- a/clojure/src/mal/step8_macros.cljc +++ b/clojure/src/mal/step8_macros.cljc @@ -127,7 +127,7 @@ (apply f args)))))))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/step9_try.cljc b/clojure/src/mal/step9_try.cljc index 2e0b91c75d..4859ba8aeb 100644 --- a/clojure/src/mal/step9_try.cljc +++ b/clojure/src/mal/step9_try.cljc @@ -144,7 +144,7 @@ (apply f args)))))))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) diff --git a/clojure/src/mal/stepA_mal.cljc b/clojure/src/mal/stepA_mal.cljc index efa7494684..1758ec0e4a 100644 --- a/clojure/src/mal/stepA_mal.cljc +++ b/clojure/src/mal/stepA_mal.cljc @@ -152,7 +152,7 @@ (apply f args)))))))))) ;; print -(defn PRINT [exp] (pr-str exp)) +(defn PRINT [exp] (printer/pr-str exp)) ;; repl (def repl-env (env/env)) From 6a51946b52f5b5cfe2e883e7c67b5e000d6dae57 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 14 Jan 2019 22:37:46 -0600 Subject: [PATCH 0424/1998] wasm: use platform_os for JS mode. Drop platform_js and use refactor platform_os to support JS mode. Add get_time_ms import to platform_os so this depends on run.js and fooboot providing that. --- wasm/Makefile | 2 +- wasm/platform_js.wam | 44 --------------------------------------- wasm/platform_os.wam | 9 ++------ wasm/run.js | 8 +++++-- wasm/step0_repl.wam | 2 +- wasm/step1_read_print.wam | 1 - wasm/step2_eval.wam | 1 - wasm/step3_env.wam | 1 - wasm/step4_if_fn_do.wam | 1 - wasm/step5_tco.wam | 1 - 10 files changed, 10 insertions(+), 60 deletions(-) delete mode 100644 wasm/platform_js.wam diff --git a/wasm/Makefile b/wasm/Makefile index c86f2ff167..8f920e5809 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,4 +1,4 @@ -MODE ?= $(if $(filter node js,$(wasm_MODE)),js,$(if $(filter wace_fooboot,$(wasm_MODE)),os,libc)) +MODE ?= $(if $(filter node js wace_fooboot,$(wasm_MODE)),os,libc) WASM_AS ?= wasm-as WAMP ?= node_modules/.bin/wamp diff --git a/wasm/platform_js.wam b/wasm/platform_js.wam deleted file mode 100644 index 3993e16330..0000000000 --- a/wasm/platform_js.wam +++ /dev/null @@ -1,44 +0,0 @@ -(module $platform_js - - (import "env" "exit" (func $lib_exit (param i32))) - (import "env" "printline" (func $lib_printline (param i32) (result i32))) - (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) - (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) - (import "env" "time_ms" (func $lib_time_ms (result i32))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $fatal (param $code i32 $msg i32) - ($print $msg) - ($lib_exit $code) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $print (param $addr i32) - (drop ($lib_printline $addr))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $readline (param $prompt i32 $buf i32) (result i32) - ;; TODO: don't hardcode count to 200 - (LET $res ($lib_readline $prompt $buf 200)) - $res - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $read_file (param $path i32 $buf i32) (result i32) - (LET $size ($lib_read_file $path $buf)) - ;; Add null to string - (i32.store8 (i32.add $buf $size) 0) - (i32.add $size 1) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $get_time_ms (result i32) - ($lib_time_ms) - ) - -) diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index c0ae33c147..197c81e200 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -1,14 +1,11 @@ (module $platform_os (import "env" "exit" (func $lib_exit (param i32))) - (import "env" "stdout" (global $lib_stdout i32)) (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) - (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) - (import "env" "add_history" (func $lib_add_history (param i32))) - (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) + (import "env" "get_time_ms" (func $lib_get_time_ms (result i32))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -27,8 +24,6 @@ (func $readline (param $prompt i32 $buf i32) (result i32) ;; TODO: don't hardcode count to 200 (LET $res ($lib_readline $prompt $buf 200)) - (if $res - ($lib_add_history $buf)) $res ) @@ -44,7 +39,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $get_time_ms (result i32) - 0 + ($lib_get_time_ms) ) ) diff --git a/wasm/run.js b/wasm/run.js index da01761ae8..849483128e 100755 --- a/wasm/run.js +++ b/wasm/run.js @@ -94,7 +94,7 @@ async function loadWebAssembly(filename, args) { return put_string(memory, buf, contents) } - function time_ms() { + function get_time_ms() { return (new Date()).getTime() } @@ -111,7 +111,11 @@ async function loadWebAssembly(filename, args) { imports.env.printline = printline imports.env.readline = readline imports.env.read_file = read_file - imports.env.time_ms = time_ms + imports.env.get_time_ms = get_time_ms + + + imports.env.stdout = 0 + imports.env.fputs = printline imports.env.memory = memory imports.env.memoryBase = memoryBase diff --git a/wasm/step0_repl.wam b/wasm/step0_repl.wam index dd7658495b..26b80fdf9e 100644 --- a/wasm/step0_repl.wam +++ b/wasm/step0_repl.wam @@ -24,7 +24,7 @@ (LET $line (STATIC_ARRAY 201)) ;; DEBUG - ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ;;($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; Start REPL (block $repl_done diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam index ad9c272cc6..1de13a9965 100644 --- a/wasm/step1_read_print.wam +++ b/wasm/step1_read_print.wam @@ -39,7 +39,6 @@ $res 0) ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) ;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) ;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam index ee169e6e51..c843ab59ce 100644 --- a/wasm/step2_eval.wam +++ b/wasm/step2_eval.wam @@ -190,7 +190,6 @@ $res 0 $repl_env 0) ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) ;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) ;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam index 5d87b08a90..67e29fbdbb 100644 --- a/wasm/step3_env.wam +++ b/wasm/step3_env.wam @@ -238,7 +238,6 @@ $res 0 $repl_env 0) ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) ;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) ;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) diff --git a/wasm/step4_if_fn_do.wam b/wasm/step4_if_fn_do.wam index 902ec36a52..24f3c7f7d5 100644 --- a/wasm/step4_if_fn_do.wam +++ b/wasm/step4_if_fn_do.wam @@ -272,7 +272,6 @@ $res 0 $repl_env 0 $ms 0) ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) ;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) ;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam index ca0aeb1364..6186604080 100644 --- a/wasm/step5_tco.wam +++ b/wasm/step5_tco.wam @@ -321,7 +321,6 @@ $res 0 $repl_env 0 $ms 0) ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) ;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) ;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) ;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) From 0a19c2f1c794acac8cbd5b39f8d943f0225bed6e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 16 Jan 2019 00:13:51 -0600 Subject: [PATCH 0425/1998] wasm: update to 2019 wat syntax, use .wat extension wasm: update to wat syntax as of Jan 2019. Examples: - get_local -> local.get - i32.wrap/i64 -> i32.warp_i64 - etc The distinction between wat and wast has been clarified: - wat: textual format for web assembly modules - wast: superset of wat used in the specification to define tests. --- .gitignore | 2 +- wasm/Makefile | 6 +- wasm/core.wam | 222 +++++++++++------------ wasm/debug.wam | 96 +++++----- wasm/env.wam | 38 ++-- wasm/mem.wam | 160 ++++++++--------- wasm/package.json | 4 +- wasm/platform_libc.wam | 22 +-- wasm/platform_os.wam | 2 +- wasm/printer.wam | 88 +++++----- wasm/printf.wam | 112 ++++++------ wasm/reader.wam | 120 ++++++------- wasm/step0_repl.wam | 2 +- wasm/step1_read_print.wam | 36 ++-- wasm/step2_eval.wam | 122 ++++++------- wasm/step3_env.wam | 144 +++++++-------- wasm/step4_if_fn_do.wam | 186 ++++++++++---------- wasm/step5_tco.wam | 198 ++++++++++----------- wasm/step6_file.wam | 232 ++++++++++++------------ wasm/step7_quote.wam | 270 ++++++++++++++-------------- wasm/step8_macros.wam | 330 +++++++++++++++++----------------- wasm/step9_try.wam | 360 +++++++++++++++++++------------------- wasm/stepA_mal.wam | 360 +++++++++++++++++++------------------- wasm/string.wam | 68 +++---- wasm/types.wam | 138 +++++++-------- 25 files changed, 1659 insertions(+), 1659 deletions(-) diff --git a/.gitignore b/.gitignore index aa4aa493c8..d5c41ff45f 100644 --- a/.gitignore +++ b/.gitignore @@ -144,5 +144,5 @@ elm/elm-stuff elm/*.js !elm/node_readline.js !elm/bootstrap.js -wasm/*.wast +wasm/*.wat wasm/*.wasm diff --git a/wasm/Makefile b/wasm/Makefile index 8f920e5809..0c5e1b1df2 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -18,8 +18,8 @@ node_modules/.bin/wamp: npm install %.wasm: %.wam - $(WAMP) $(filter %.wam,$^) > $*.wast - $(WASM_AS) $*.wast -o $@ + $(WAMP) $(filter %.wam,$^) > $*.wat + $(WASM_AS) $*.wat -o $@ step0_repl.wasm: $(STEP0_DEPS) step1_read_print.wasm step2_eval.wasm: $(STEP1_DEPS) @@ -30,7 +30,7 @@ step7_quote.wasm step8_macros.wasm step9_try.wasm stepA_mal.wasm: $(STEP4_DEPS) .PHONY: clean clean: - rm -f *.wast *.wasm + rm -f *.wat *.wasm .PHONY: stats tests diff --git a/wasm/core.wam b/wasm/core.wam index 59e906782e..5b719fcd8b 100644 --- a/wasm/core.wam +++ b/wasm/core.wam @@ -7,35 +7,35 @@ (func $APPLY (param $f i32) (param $args i32) (result i32) (local $res i32 $env i32 $ftype i32 $a i32) - (set_local $f ($DEREF_META $f)) - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $f ($DEREF_META $f)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then ;; Must be kept in sync with EVAL's FUNCTION_T evaluation (if (i32.eq ($VAL0 $f) 0) ;; eval (then - (set_local $res ($EVAL ($MEM_VAL1_ptr $args) - (get_global $repl_env)))) + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) (else - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))))) - (else (if (OR (i32.eq $ftype (get_global $MALFUNC_T)) - (i32.eq $ftype (get_global $MACRO_T))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))))) + (else (if (OR (i32.eq $ftype (global.get $MALFUNC_T)) + (i32.eq $ftype (global.get $MACRO_T))) (then ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; claim the AST before releasing the list containing it - (set_local $a ($MEM_VAL0_ptr $f)) + (local.set $a ($MEM_VAL0_ptr $f)) (drop ($INC_REF $a)) - (set_local $res ($EVAL $a $env)) + (local.set $res ($EVAL $a $env)) ($RELEASE $env) ($RELEASE $a)) (else ($THROW_STR_1 "APPLY of non-function type: %d\n" $ftype) - (set_local $res 0))))) + (local.set $res 0))))) $res ) @@ -49,30 +49,30 @@ ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))))) (func $throw (param $args i32) (result i32) - (set_global $error_type 2) - (set_global $error_val ($INC_REF ($MEM_VAL1_ptr $args))) + (global.set $error_type 2) + (global.set $error_val ($INC_REF ($MEM_VAL1_ptr $args))) 0 ) (func $nil_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (get_global $NIL_T)))) + (global.get $NIL_T)))) (func $true_Q (param $args i32) (result i32) (LET $ast ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $BOOLEAN_T)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $BOOLEAN_T)) (i32.eq ($VAL0 $ast) 1))) ) (func $false_Q (param $args i32) (result i32) (LET $ast ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $BOOLEAN_T)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $BOOLEAN_T)) (i32.eq ($VAL0 $ast) 0))) ) (func $number_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (get_global $INTEGER_T)))) + (global.get $INTEGER_T)))) (func $string_Q (param $args i32) (result i32) (LET $mv ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $mv) (get_global $STRING_T)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $mv) (global.get $STRING_T)) (i32.ne (i32.load8_u ($to_String $mv)) (CHR "\x7f")))) ) @@ -82,30 +82,30 @@ (if (result i32) (i32.eq (i32.load8_u $str) (CHR "\x7f")) (then ($INC_REF ($MEM_VAL1_ptr $args))) (else - (drop ($sprintf_1 (get_global $printf_buf) "\x7f%s" $str)) - ($STRING (get_global $STRING_T) (get_global $printf_buf)))) + (drop ($sprintf_1 (global.get $printf_buf) "\x7f%s" $str)) + ($STRING (global.get $STRING_T) (global.get $printf_buf)))) ) (func $keyword_Q (param $args i32) (result i32) (LET $ast ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (get_global $STRING_T)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $STRING_T)) (i32.eq (i32.load8_u ($to_String $ast)) (CHR "\x7f")))) ) (func $fn_Q (param $args i32) (result i32) (LET $type ($TYPE ($MEM_VAL1_ptr $args))) - ($TRUE_FALSE (OR (i32.eq $type (get_global $FUNCTION_T)) - (i32.eq $type (get_global $MALFUNC_T))))) + ($TRUE_FALSE (OR (i32.eq $type (global.get $FUNCTION_T)) + (i32.eq $type (global.get $MALFUNC_T))))) (func $macro_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (get_global $MACRO_T)))) + (global.get $MACRO_T)))) (func $symbol (param $args i32) (result i32) - ($STRING (get_global $SYMBOL_T) ($to_String ($MEM_VAL1_ptr $args)))) + ($STRING (global.get $SYMBOL_T) ($to_String ($MEM_VAL1_ptr $args)))) (func $symbol_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (get_global $SYMBOL_T)))) + (global.get $SYMBOL_T)))) (func $core_pr_str (param $args i32) (result i32) ($pr_str_seq $args 1 " ")) @@ -115,21 +115,21 @@ (LET $res ($pr_str_seq $args 1 " ")) ($printf_1 "%s\n" ($to_String $res)) ($RELEASE $res) - ($INC_REF (get_global $NIL)) + ($INC_REF (global.get $NIL)) ) (func $println (param $args i32) (result i32) (LET $res ($pr_str_seq $args 0 " ")) ($printf_1 "%s\n" ($to_String $res)) ($RELEASE $res) - ($INC_REF (get_global $NIL)) + ($INC_REF (global.get $NIL)) ) (func $core_readline (param $args i32) (result i32) (LET $line (STATIC_ARRAY 201) $mv 0) (if (i32.eqz ($readline ($to_String ($MEM_VAL1_ptr $args)) $line)) - (return ($INC_REF (get_global $NIL)))) - (set_local $mv ($STRING (get_global $STRING_T) $line)) + (return ($INC_REF (global.get $NIL)))) + (local.set $mv ($STRING (global.get $STRING_T) $line)) $mv ) @@ -137,14 +137,14 @@ ($read_str ($to_String ($MEM_VAL1_ptr $args)))) (func $slurp (param $args i32) (result i32) - (LET $mv ($STRING_INIT (get_global $STRING_T)) + (LET $mv ($STRING_INIT (global.get $STRING_T)) $size ($read_file ($to_String ($MEM_VAL1_ptr $args)) ($to_String $mv))) (if (i32.eqz $size) (then ($THROW_STR_1 "failed to read file '%s'" ($to_String ($MEM_VAL1_ptr $args))) - (return ($INC_REF (get_global $NIL))))) - (set_local $mv ($STRING_FINALIZE $mv $size)) + (return ($INC_REF (global.get $NIL))))) + (local.set $mv ($STRING_FINALIZE $mv $size)) $mv ) @@ -191,17 +191,17 @@ (func $list_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) - (get_global $LIST_T)))) + (global.get $LIST_T)))) (func $vector (param $args i32) (result i32) - ($FORCE_SEQ_TYPE (get_global $VECTOR_T) $args)) + ($FORCE_SEQ_TYPE (global.get $VECTOR_T) $args)) (func $vector_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) - (get_global $VECTOR_T)))) + (global.get $VECTOR_T)))) (func $hash_map (param $args i32) (result i32) - (LET $type (get_global $HASHMAP_T) + (LET $type (global.get $HASHMAP_T) $res ($MAP_LOOP_START $type) $val2 0 $val3 0 @@ -216,20 +216,20 @@ (loop $loop (br_if $done (i32.eqz ($VAL0 $args))) - (set_local $val2 ($INC_REF ($MEM_VAL1_ptr $args))) - (set_local $val3 ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + (local.set $val2 ($INC_REF ($MEM_VAL1_ptr $args))) + (local.set $val3 ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) ;; skip two - (set_local $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) + (local.set $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) ;; update the return sequence structure ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) (br $loop) ) @@ -242,21 +242,21 @@ (func $hash_map_Q (param $args i32) (result i32) ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) - (get_global $HASHMAP_T)))) + (global.get $HASHMAP_T)))) (func $assoc (param $args i32) (result i32) (LET $hm ($MEM_VAL1_ptr $args) $key 0) - (set_local $args ($MEM_VAL0_ptr $args)) + (local.set $args ($MEM_VAL0_ptr $args)) (drop ($INC_REF $hm)) (block $done (loop $loop (br_if $done (OR (i32.eqz ($VAL0 $args)) (i32.eqz ($VAL0 ($MEM_VAL0_ptr $args))))) - (set_local $hm ($ASSOC1 $hm ($MEM_VAL1_ptr $args) + (local.set $hm ($ASSOC1 $hm ($MEM_VAL1_ptr $args) ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) - (set_local $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) + (local.set $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) (br $loop) ) @@ -267,23 +267,23 @@ (func $get (param $args i32) (result i32) (LET $hm ($MEM_VAL1_ptr $args) $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - (if (result i32) (i32.eq $hm (get_global $NIL)) - (then ($INC_REF (get_global $NIL))) - (else ($INC_REF (i32.wrap/i64 ($HASHMAP_GET $hm $key))))) + (if (result i32) (i32.eq $hm (global.get $NIL)) + (then ($INC_REF (global.get $NIL))) + (else ($INC_REF (i32.wrap_i64 ($HASHMAP_GET $hm $key))))) ) (func $contains_Q (param $args i32) (result i32) (LET $hm ($MEM_VAL1_ptr $args) $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ($TRUE_FALSE - (if (result i32) (i32.eq $hm (get_global $NIL)) + (if (result i32) (i32.eq $hm (global.get $NIL)) (then 0) - (else (i32.wrap/i64 + (else (i32.wrap_i64 (i64.shr_u ($HASHMAP_GET $hm $key) (i64.const 32)))))) ) (func $keys_or_vals (param $hm i32 $keys i32) (result i32) - (LET $res ($MAP_LOOP_START (get_global $LIST_T)) + (LET $res ($MAP_LOOP_START (global.get $LIST_T)) $val2 0 ;; MAP_LOOP stack $ret $res @@ -295,23 +295,23 @@ (br_if $done (i32.eqz ($VAL0 $hm))) (if $keys - (then (set_local $val2 ($INC_REF ($MEM_VAL1_ptr $hm)))) - (else (set_local $val2 ($INC_REF ($MEM_VAL2_ptr $hm))))) + (then (local.set $val2 ($INC_REF ($MEM_VAL1_ptr $hm)))) + (else (local.set $val2 ($INC_REF ($MEM_VAL2_ptr $hm))))) ;; next element - (set_local $hm ($MEM_VAL0_ptr $hm)) + (local.set $hm ($MEM_VAL0_ptr $hm)) ;; update the return sequence structure ;; do not release val2 since we are pulling it from the ;; arguments and not creating it here ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE (get_global $LIST_T) + (local.set $res ($MAP_LOOP_UPDATE (global.get $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) (br $loop) ) @@ -329,45 +329,45 @@ (func $sequential_Q (param $args i32) (result i32) ($TRUE_FALSE (OR (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (get_global $LIST_T)) + (global.get $LIST_T)) (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (get_global $VECTOR_T))))) + (global.get $VECTOR_T))))) (func $cons (param $args i32) (result i32) ($LIST ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) ($MEM_VAL1_ptr $args))) (func $concat (param $args i32) (result i32) (local $last_sl i64) - (LET $res ($INC_REF (get_global $EMPTY_LIST)) + (LET $res ($INC_REF (global.get $EMPTY_LIST)) $current $res $sl 0 $last 0 $arg 0) (block $done (loop $loop - (br_if $done (i32.le_u $args (get_global $EMPTY_HASHMAP))) - (set_local $arg ($MEM_VAL1_ptr $args)) + (br_if $done (i32.le_u $args (global.get $EMPTY_HASHMAP))) + (local.set $arg ($MEM_VAL1_ptr $args)) ;; skip empty elements - (if (i32.le_s $arg (get_global $EMPTY_HASHMAP)) + (if (i32.le_s $arg (global.get $EMPTY_HASHMAP)) (then - (set_local $args ($MEM_VAL0_ptr $args)) + (local.set $args ($MEM_VAL0_ptr $args)) (br $loop))) - (set_local $last_sl ($SLICE $arg 0 -1)) - (set_local $sl (i32.wrap/i64 $last_sl)) - (set_local $last (i32.wrap/i64 (i64.shr_u $last_sl (i64.const 32)))) - (if (i32.eq $res (get_global $EMPTY_LIST)) + (local.set $last_sl ($SLICE $arg 0 -1)) + (local.set $sl (i32.wrap_i64 $last_sl)) + (local.set $last (i32.wrap_i64 (i64.shr_u $last_sl (i64.const 32)))) + (if (i32.eq $res (global.get $EMPTY_LIST)) (then ;; if this is the first element, set the return to the slice - (set_local $res $sl)) + (local.set $res $sl)) (else ;; otherwise attach current to sliced (i32.store ($VAL0_ptr $current) ($IDX $sl)))) ;; update current to end of sliced list - (set_local $current $last) + (local.set $current $last) ;; release empty since no longer part of the slice - ($RELEASE (get_global $EMPTY_LIST)) + ($RELEASE (global.get $EMPTY_LIST)) - (set_local $args ($MEM_VAL0_ptr $args)) + (local.set $args ($MEM_VAL0_ptr $args)) (br $loop) ) ) @@ -382,8 +382,8 @@ (block $done (loop $loop (br_if $done (OR (i32.ge_s $i $idx) (i32.eqz ($VAL0 $a)))) - (set_local $i (i32.add $i 1)) - (set_local $a ($MEM_VAL0_ptr $a)) + (local.set $i (i32.add $i 1)) + (local.set $a ($MEM_VAL0_ptr $a)) (br $loop) ) ) @@ -396,21 +396,21 @@ ) (func $first (param $args i32) (result i32) - (LET $res (get_global $NIL) + (LET $res (global.get $NIL) $a ($MEM_VAL1_ptr $args)) - (if (AND (i32.ne $a (get_global $NIL)) + (if (AND (i32.ne $a (global.get $NIL)) (i32.ne ($VAL0 $a) 0)) - (set_local $res ($MEM_VAL1_ptr $a))) + (local.set $res ($MEM_VAL1_ptr $a))) ($INC_REF $res) ) (func $rest (param $args i32) (result i32) (LET $a ($MEM_VAL1_ptr $args)) - (if (i32.eq $a (get_global $NIL)) - (return ($INC_REF (get_global $EMPTY_LIST)))) + (if (i32.eq $a (global.get $NIL)) + (return ($INC_REF (global.get $EMPTY_LIST)))) (if (i32.ne ($VAL0 $a) 0) - (set_local $a ($MEM_VAL0_ptr $a))) - ($FORCE_SEQ_TYPE (get_global $LIST_T) $a) + (local.set $a ($MEM_VAL0_ptr $a))) + ($FORCE_SEQ_TYPE (global.get $LIST_T) $a) ) ;;; @@ -433,19 +433,19 @@ (if (i32.le_s $rest_count 1) (then ;; no intermediate args - (if (i32.ne ($TYPE ($MEM_VAL1_ptr $rest_args)) (get_global $LIST_T)) + (if (i32.ne ($TYPE ($MEM_VAL1_ptr $rest_args)) (global.get $LIST_T)) (then ;; not a list, so convert it first - (set_local $f_args ($FORCE_SEQ_TYPE (get_global $LIST_T) + (local.set $f_args ($FORCE_SEQ_TYPE (global.get $LIST_T) ($MEM_VAL1_ptr $rest_args)))) (else ;; inc ref since we will release after APPLY - (set_local $f_args ($INC_REF ($MEM_VAL1_ptr $rest_args)))))) + (local.set $f_args ($INC_REF ($MEM_VAL1_ptr $rest_args)))))) (else ;; 1 or more intermediate args - (set_local $last_sl ($SLICE $rest_args 0 (i32.sub $rest_count 1))) - (set_local $f_args (i32.wrap/i64 $last_sl)) - (set_local $last (i32.wrap/i64 (i64.shr_u $last_sl (i64.const 32)))) + (local.set $last_sl ($SLICE $rest_args 0 (i32.sub $rest_count 1))) + (local.set $f_args (i32.wrap_i64 $last_sl)) + (local.set $last (i32.wrap_i64 (i64.shr_u $last_sl (i64.const 32)))) ;; release the terminator of the new list (we skip over it) ;; we already checked for an empty list above, so $last is ;; a real non-empty list @@ -454,7 +454,7 @@ (i32.store ($VAL0_ptr $last) ($IDX ($LAST $rest_args))) )) - (set_local $res ($APPLY $f $f_args)) + (local.set $res ($APPLY $f $f_args)) ;; release new args ($RELEASE $f_args) @@ -465,7 +465,7 @@ (LET $f ($MEM_VAL1_ptr $args) $rest_args ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) $f_args 0 - $res ($MAP_LOOP_START (get_global $LIST_T)) + $res ($MAP_LOOP_START (global.get $LIST_T)) ;; push MAP_LOOP stack $ret $res $current $res @@ -476,18 +476,18 @@ (br_if $done (i32.eqz ($VAL1 $rest_args))) ;; create argument list for apply - (set_local $f_args ($ALLOC (get_global $LIST_T) - (get_global $EMPTY_LIST) + (local.set $f_args ($ALLOC (global.get $LIST_T) + (global.get $EMPTY_LIST) ($MEM_VAL1_ptr $rest_args) 0)) - (set_local $res ($APPLY $f $f_args)) + (local.set $res ($APPLY $f $f_args)) ($RELEASE $f_args) ;; go to the next element - (set_local $rest_args ($MEM_VAL0_ptr $rest_args)) + (local.set $rest_args ($MEM_VAL0_ptr $rest_args)) - (if (get_global $error_type) + (if (global.get $error_type) (then ;; if error, release the unattached element ($RELEASE $res) @@ -495,13 +495,13 @@ ;; update the return sequence structure ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE (get_global $LIST_T) + (local.set $res ($MAP_LOOP_UPDATE (global.get $LIST_T) $empty $current $res 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) (br $loop) ) @@ -517,19 +517,19 @@ (LET $mv ($MEM_VAL1_ptr $args) $meta ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) ;; remove existing metadata first - ($ALLOC (get_global $METADATA_T) ($DEREF_META $mv) $meta 0) + ($ALLOC (global.get $METADATA_T) ($DEREF_META $mv) $meta 0) ) (func $meta (param $args i32) (result i32) - (if (result i32) (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $METADATA_T)) + (if (result i32) (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (global.get $METADATA_T)) (then ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL1_ptr $args)))) - (else ($INC_REF (get_global $NIL))))) + (else ($INC_REF (global.get $NIL))))) (func $atom (param $args i32) (result i32) - ($ALLOC_SCALAR (get_global $ATOM_T) ($VAL1 $args))) + ($ALLOC_SCALAR (global.get $ATOM_T) ($VAL1 $args))) (func $atom_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (get_global $ATOM_T)))) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (global.get $ATOM_T)))) (func $deref (param $args i32) (result i32) ($INC_REF ($MEM_VAL0_ptr ($MEM_VAL1_ptr $args)))) @@ -571,14 +571,14 @@ (func $pr_memory_summary (param $args i32) (result i32) ($PR_MEMORY_SUMMARY_SMALL) - ($INC_REF (get_global $NIL)) + ($INC_REF (global.get $NIL)) ) (func $nop (param $args i32) (result i32) - ($INC_REF (get_global $NIL))) + ($INC_REF (global.get $NIL))) (table - anyfunc + funcref (elem $nop ;; placeholder for eval which will use 0 $equal_Q $throw diff --git a/wasm/debug.wam b/wasm/debug.wam index 19e5c10f6f..66ad533a4a 100644 --- a/wasm/debug.wam +++ b/wasm/debug.wam @@ -1,25 +1,25 @@ (module $debug (func $checkpoint_user_memory - (set_global $mem_user_start (get_global $mem_unused_start)) - (set_global $string_mem_user_start (get_global $string_mem_next)) + (global.set $mem_user_start (global.get $mem_unused_start)) + (global.set $string_mem_user_start (global.get $string_mem_next)) ) (func $CHECK_FREE_LIST (result i32) (LET $first (i32.add - (get_global $mem) - (i32.mul (get_global $mem_free_list) 4)) + (global.get $mem) + (i32.mul (global.get $mem_free_list) 4)) $count 0) (block $done (loop $loop (br_if $done (i32.ge_s $first - (i32.add (get_global $mem) - (i32.mul (get_global $mem_unused_start) + (i32.add (global.get $mem) + (i32.mul (global.get $mem_unused_start) 4)))) - (set_local $count (i32.add $count ($MalVal_size $first))) - (set_local $first (i32.add (get_global $mem) (i32.mul 4 ($VAL0 $first)))) + (local.set $count (i32.add $count ($MalVal_size $first))) + (local.set $first (i32.add (global.get $mem) (i32.mul 4 ($VAL0 $first)))) (br $loop) ) ) @@ -27,24 +27,24 @@ ) (func $PR_MEMORY_SUMMARY_SMALL - (LET $free (i32.sub (get_global $MEM_SIZE) - (i32.mul (get_global $mem_unused_start) 4)) + (LET $free (i32.sub (global.get $MEM_SIZE) + (i32.mul (global.get $mem_unused_start) 4)) $free_list_count ($CHECK_FREE_LIST) - $mv (get_global $NIL) + $mv (global.get $NIL) $mem_ref_count 0) (block $done (loop $loop (br_if $done (i32.ge_s $mv (i32.add - (get_global $mem) - (i32.mul (get_global $mem_unused_start) + (global.get $mem) + (i32.mul (global.get $mem_unused_start) 4)))) - (if (i32.ne ($TYPE $mv) (get_global $FREE_T)) - (set_local $mem_ref_count (i32.add $mem_ref_count + (if (i32.ne ($TYPE $mv) (global.get $FREE_T)) + (local.set $mem_ref_count (i32.add $mem_ref_count (i32.shr_u (i32.load $mv) 5)))) - (set_local $mv (i32.add $mv (i32.mul 4 ($MalVal_size $mv)))) + (local.set $mv (i32.add $mv (i32.mul 4 ($MalVal_size $mv)))) (br $loop) ) ) @@ -52,24 +52,24 @@ ($printf_3 "Free: %d, Values: %d (refs: %d), Emptys: " $free (i32.sub - (i32.sub (get_global $mem_unused_start) 1) + (i32.sub (global.get $mem_unused_start) 1) $free_list_count) $mem_ref_count) - (set_local $mv (get_global $NIL)) + (local.set $mv (global.get $NIL)) (block $done (loop $loop - (br_if $done (i32.gt_s $mv (get_global $TRUE))) + (br_if $done (i32.gt_s $mv (global.get $TRUE))) ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) - (set_local $mv (i32.add $mv 8)) + (local.set $mv (i32.add $mv 8)) (br $loop) ) ) - (set_local $mv (get_global $EMPTY_LIST)) + (local.set $mv (global.get $EMPTY_LIST)) (block $done (loop $loop - (br_if $done (i32.gt_s $mv (get_global $EMPTY_HASHMAP))) + (br_if $done (i32.gt_s $mv (global.get $EMPTY_HASHMAP))) ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) - (set_local $mv (i32.add $mv 12)) + (local.set $mv (i32.add $mv 12)) (br $loop) ) ) @@ -95,8 +95,8 @@ (then ($printf_1 ", size %2d" $size)) (else ($printf_1 ", refs %2d" ($REFS $mv)))) - (if (OR (i32.eq $type (get_global $STRING_T)) - (i32.eq $type (get_global $SYMBOL_T))) + (if (OR (i32.eq $type (global.get $STRING_T)) + (i32.eq $type (global.get $SYMBOL_T))) ;; for strings/symbolx pointers, print hex values (then ($printf_2 " [%4d|%3ds" ($MalVal_refcnt_type $idx) $val0)) (else ($printf_2 " [%4d|%4d" ($MalVal_refcnt_type $idx) $val0))) @@ -141,7 +141,7 @@ ($print ($to_String $mv)) (br $done)) ;; 6: list - (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) (then ($print "()")) (else @@ -151,7 +151,7 @@ ($MalVal_val $idx 0)))) (br $done)) ;; 7: vector - (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) (then ($print "[]")) (else @@ -161,7 +161,7 @@ ($MalVal_val $idx 0)))) (br $done)) ;; 8: hashmap - (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) (then ($print "{}")) (else @@ -192,9 +192,9 @@ (br $done)) ;; 15: FREE ($printf_1 "FREE next: 0x%x" $val0) - (if (i32.eq $idx (get_global $mem_free_list)) + (if (i32.eq $idx (global.get $mem_free_list)) ($print " (free start)")) - (if (i32.eq $val0 (get_global $mem_unused_start)) + (if (i32.eq $val0 (global.get $mem_unused_start)) ($print " (free end)")) (br $done)) ;; 16: unknown @@ -210,18 +210,18 @@ (LET $ms 0 $idx 0) ($printf_2 "String - showing %d -> %d:\n" - $start (i32.sub (get_global $string_mem_next) - (get_global $string_mem))) - (if (i32.le_s (i32.sub (get_global $string_mem_next) - (get_global $string_mem)) + $start (i32.sub (global.get $string_mem_next) + (global.get $string_mem))) + (if (i32.le_s (i32.sub (global.get $string_mem_next) + (global.get $string_mem)) $start) (then ($print " ---\n")) (else - (set_local $ms (get_global $string_mem)) + (local.set $ms (global.get $string_mem)) (block $done (loop $loop - (br_if $done (i32.ge_u $ms (get_global $string_mem_next))) - (set_local $idx (i32.sub $ms (get_global $string_mem))) + (br_if $done (i32.ge_u $ms (global.get $string_mem_next))) + (local.set $idx (i32.sub $ms (global.get $string_mem))) (if (i32.ge_s $idx $start) ($printf_4 "%4d: refs %2d, size %2d >> '%s'\n" $idx @@ -229,7 +229,7 @@ (i32.load16_u (i32.add $ms 2)) (i32.add $ms 4))) - (set_local $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (local.set $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) (br $loop) ) ))) @@ -240,31 +240,31 @@ $idx 0) (if (i32.lt_s $start 0) (then - (set_local $start (get_global $mem_user_start)) - (set_local $string_start (i32.sub (get_global $string_mem_user_start) - (get_global $string_mem))))) + (local.set $start (global.get $mem_user_start)) + (local.set $string_start (i32.sub (global.get $string_mem_user_start) + (global.get $string_mem))))) (if (i32.lt_s $end 0) - (set_local $end (get_global $mem_unused_start))) + (local.set $end (global.get $mem_unused_start))) ;;; printf("Values - (mem) showing %d -> %d", start, end) ;;; printf(" (unused start: %d, free list: %d):\n", ;;; mem_unused_start, mem_free_list) ($printf_4 "Values - (mem) showing 0x%x -> 0x%x (unused start: 0x%x, free list: 0x%x):\n" $start $end - (get_global $mem_unused_start) - (get_global $mem_free_list)) + (global.get $mem_unused_start) + (global.get $mem_free_list)) (if (i32.le_s $end $start) (then ($print " ---\n") - (set_local $end (get_global $mem_unused_start))) + (local.set $end (global.get $mem_unused_start))) (else - (set_local $idx $start) + (local.set $idx $start) ;;; while (idx < end) (block $loopvals_exit (loop $loopvals (br_if $loopvals_exit (i32.ge_s $idx $end)) - (set_local $idx ($PR_MEMORY_VALUE $idx)) + (local.set $idx ($PR_MEMORY_VALUE $idx)) (br $loopvals) ) ))) @@ -277,7 +277,7 @@ (loop $loop (br_if $loop_exit (i32.ge_u $start $end)) ($printf_2 "0x%x 0x%x\n" $start (i32.load $start)) - (set_local $start (i32.add 4 $start)) + (local.set $start (i32.add 4 $start)) (br $loop) ) ) diff --git a/wasm/env.wam b/wasm/env.wam index 3132b4a9bb..cd10c76918 100644 --- a/wasm/env.wam +++ b/wasm/env.wam @@ -2,7 +2,7 @@ (func $ENV_NEW (param $outer i32) (result i32) (LET $data ($HASHMAP) ;; allocate the data hashmap - $env ($ALLOC (get_global $ENVIRONMENT_T) $data $outer 0)) + $env ($ALLOC (global.get $ENVIRONMENT_T) $data $outer 0)) ;; environment takes ownership ($RELEASE $data) $env @@ -18,15 +18,15 @@ (br_if $done (i32.eqz ($VAL0 $binds))) ;; get/deref the key from binds - (set_local $key ($MEM_VAL1_ptr $binds)) + (local.set $key ($MEM_VAL1_ptr $binds)) (if (i32.eqz ($strcmp "&" ($to_String $key))) (then ;; ENV_NEW_BIND_VARGS ;; get/deref the key from the next element of binds - (set_local $binds ($MEM_VAL0_ptr $binds)) - (set_local $key ($MEM_VAL1_ptr $binds)) + (local.set $binds ($MEM_VAL0_ptr $binds)) + (local.set $key ($MEM_VAL1_ptr $binds)) ;; the value is the remaining list in exprs - (set_local $exprs ($FORCE_SEQ_TYPE (get_global $LIST_T) $exprs)) + (local.set $exprs ($FORCE_SEQ_TYPE (global.get $LIST_T) $exprs)) ;; set the binding in the environment data (drop ($ENV_SET $env $key $exprs)) ;; list is owned by the environment @@ -37,8 +37,8 @@ ;; set the binding in the environment data (drop ($ENV_SET $env $key ($MEM_VAL1_ptr $exprs))) ;; go to next element of binds and exprs - (set_local $binds ($MEM_VAL0_ptr $binds)) - (set_local $exprs ($MEM_VAL0_ptr $exprs)))) + (local.set $binds ($MEM_VAL0_ptr $binds)) + (local.set $exprs ($MEM_VAL0_ptr $exprs)))) (br $loop) ) @@ -65,17 +65,17 @@ (block $done (loop $loop - (set_local $data ($MEM_VAL0_ptr $env)) - (set_local $found_res ($HASHMAP_GET $data $key)) + (local.set $data ($MEM_VAL0_ptr $env)) + (local.set $found_res ($HASHMAP_GET $data $key)) ;;; if (found) - (if (i32.wrap/i64 (i64.shr_u $found_res (i64.const 32))) + (if (i32.wrap_i64 (i64.shr_u $found_res (i64.const 32))) (then - (set_local $res (i32.wrap/i64 $found_res)) + (local.set $res (i32.wrap_i64 $found_res)) (br $done))) - (set_local $env ($MEM_VAL1_ptr $env)) - (if (i32.eq $env (get_global $NIL)) + (local.set $env ($MEM_VAL1_ptr $env)) + (if (i32.eq $env (global.get $NIL)) (then - (set_local $env 0) + (local.set $env 0) (br $done))) (br $loop) ) @@ -83,17 +83,17 @@ ;; combine res/env as hi 32/low 32 of i64 (i64.or - (i64.shl (i64.extend_u/i32 $res) (i64.const 32)) - (i64.extend_u/i32 $env)) + (i64.shl (i64.extend_i32_u $res) (i64.const 32)) + (i64.extend_i32_u $env)) ) (func $ENV_GET (param $env i32 $key i32) (result i32) (local $res_env i64) (LET $res 0) - (set_local $res_env ($ENV_FIND $env $key)) - (set_local $env (i32.wrap/i64 $res_env)) - (set_local $res (i32.wrap/i64 (i64.shr_u $res_env (i64.const 32)))) + (local.set $res_env ($ENV_FIND $env $key)) + (local.set $env (i32.wrap_i64 $res_env)) + (local.set $res (i32.wrap_i64 (i64.shr_u $res_env (i64.const 32)))) (if (i32.eqz $env) (then diff --git a/wasm/mem.wam b/wasm/mem.wam index 7a6e634c1f..0eda0175ad 100644 --- a/wasm/mem.wam +++ b/wasm/mem.wam @@ -29,20 +29,20 @@ (func $MEM_VAL0_ptr (param $mv i32) (result i32) - (i32.add (get_global $mem) + (i32.add (global.get $mem) (i32.mul (i32.load (i32.add $mv 4)) 4))) (func $MEM_VAL1_ptr (param $mv i32) (result i32) - (i32.add (get_global $mem) + (i32.add (global.get $mem) (i32.mul (i32.load (i32.add $mv 8)) 4))) (func $MEM_VAL2_ptr (param $mv i32) (result i32) - (i32.add (get_global $mem) + (i32.add (global.get $mem) (i32.mul (i32.load (i32.add $mv 12)) 4))) ;; Returns the memory index mem of mv ;; Will usually be used with a load or store by the caller (func $IDX (param $mv i32) (result i32) ;; MalVal memory 64 bit (2 * i32) aligned - (i32.div_u (i32.sub $mv (get_global $mem)) 4)) + (i32.div_u (i32.sub $mv (global.get $mem)) 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -50,7 +50,7 @@ (func $MalVal_ptr (param $mv_idx i32) (result i32) ;; MalVal memory 64 bit (2 * i32) aligned ;;; mem[mv_idx].refcnt_type - (i32.add (get_global $mem) (i32.mul $mv_idx 4))) + (i32.add (global.get $mem) (i32.mul $mv_idx 4))) ;; Returns the address of 'mem[mv_idx].refcnt_type' (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) @@ -100,7 +100,7 @@ (func $MalVal_size (param $mv i32) (result i32) (LET $type ($TYPE $mv)) ;; if (type == FREE_T) - (if (result i32) (i32.eq $type (get_global $FREE_T)) + (if (result i32) (i32.eq $type (global.get $FREE_T)) (then ;;; return (mv->refcnt_type & 0xffe0)>>5 (i32.shr_u (i32.and (i32.load $mv) 0xffe0) 5)) ;;; / 32 @@ -119,46 +119,46 @@ ($init_printf_mem) ;; error_str string buffer - (set_global $error_str (STATIC_ARRAY 100)) + (global.set $error_str (STATIC_ARRAY 100)) ;; reader token string buffer - (set_global $token_buf (STATIC_ARRAY 256)) + (global.set $token_buf (STATIC_ARRAY 256)) ;; printer string buffer - (set_global $printer_buf (STATIC_ARRAY 4096)) + (global.set $printer_buf (STATIC_ARRAY 4096)) - (set_local $heap_size (i32.add (get_global $MEM_SIZE) - (get_global $STRING_MEM_SIZE))) - (set_global $heap_start (i32.add (get_global $memoryBase) - (get_global $S_STRING_END))) - (set_global $heap_end (i32.add (get_global $heap_start) + (local.set $heap_size (i32.add (global.get $MEM_SIZE) + (global.get $STRING_MEM_SIZE))) + (global.set $heap_start (i32.add (global.get $memoryBase) + (global.get $S_STRING_END))) + (global.set $heap_end (i32.add (global.get $heap_start) $heap_size)) - (set_global $mem (get_global $heap_start)) - (set_global $mem_unused_start 0) - (set_global $mem_free_list 0) + (global.set $mem (global.get $heap_start)) + (global.set $mem_unused_start 0) + (global.set $mem_free_list 0) - (set_global $string_mem (i32.add (get_global $heap_start) - (get_global $MEM_SIZE))) - (set_global $string_mem_next (get_global $string_mem)) + (global.set $string_mem (i32.add (global.get $heap_start) + (global.get $MEM_SIZE))) + (global.set $string_mem_next (global.get $string_mem)) - (set_global $mem_user_start (get_global $mem_unused_start)) - (set_global $string_mem_user_start (get_global $string_mem_next)) + (global.set $mem_user_start (global.get $mem_unused_start)) + (global.set $string_mem_user_start (global.get $string_mem_next)) ;; Empty values - (set_global $NIL - ($ALLOC_SCALAR (get_global $NIL_T) 0)) - (set_global $FALSE - ($ALLOC_SCALAR (get_global $BOOLEAN_T) 0)) - (set_global $TRUE - ($ALLOC_SCALAR (get_global $BOOLEAN_T) 1)) - (set_global $EMPTY_LIST - ($ALLOC (get_global $LIST_T) - (get_global $NIL) (get_global $NIL) (get_global $NIL))) - (set_global $EMPTY_VECTOR - ($ALLOC (get_global $VECTOR_T) - (get_global $NIL) (get_global $NIL) (get_global $NIL))) - (set_global $EMPTY_HASHMAP - ($ALLOC (get_global $HASHMAP_T) - (get_global $NIL) (get_global $NIL) (get_global $NIL))) + (global.set $NIL + ($ALLOC_SCALAR (global.get $NIL_T) 0)) + (global.set $FALSE + ($ALLOC_SCALAR (global.get $BOOLEAN_T) 0)) + (global.set $TRUE + ($ALLOC_SCALAR (global.get $BOOLEAN_T) 1)) + (global.set $EMPTY_LIST + ($ALLOC (global.get $LIST_T) + (global.get $NIL) (global.get $NIL) (global.get $NIL))) + (global.set $EMPTY_VECTOR + ($ALLOC (global.get $VECTOR_T) + (global.get $NIL) (global.get $NIL) (global.get $NIL))) + (global.set $EMPTY_HASHMAP + ($ALLOC (global.get $HASHMAP_T) + (global.get $NIL) (global.get $NIL) (global.get $NIL))) ;; ($print "<<< init_memory\n") @@ -169,32 +169,32 @@ (func $ALLOC_INTERNAL (param $type i32 $val1 i32 $val2 i32 $val3 i32) (result i32) - (LET $prev (get_global $mem_free_list) - $res (get_global $mem_free_list) + (LET $prev (global.get $mem_free_list) + $res (global.get $mem_free_list) $size ($MalType_size $type)) (block $loop_done (loop $loop ;; res == mem_unused_start - (if (i32.eq $res (get_global $mem_unused_start)) + (if (i32.eq $res (global.get $mem_unused_start)) (then ;; ALLOC_UNUSED ;;; if (res + size > MEM_SIZE) - (if (i32.gt_u (i32.add $res $size) (get_global $MEM_SIZE)) + (if (i32.gt_u (i32.add $res $size) (global.get $MEM_SIZE)) ;; Out of memory, exit ($fatal 7 "Out of mal memory!\n")) ;;; if (mem_unused_start += size) - (set_global $mem_unused_start - (i32.add (get_global $mem_unused_start) $size)) + (global.set $mem_unused_start + (i32.add (global.get $mem_unused_start) $size)) ;;; if (prev == res) (if (i32.eq $prev $res) (then - (set_global $mem_free_list (get_global $mem_unused_start))) + (global.set $mem_free_list (global.get $mem_unused_start))) (else ;;; mem[prev].val[0] = mem_unused_start (i32.store ($MalVal_val_ptr $prev 0) - (get_global $mem_unused_start)))) + (global.get $mem_unused_start)))) (br $loop_done))) ;; if (MalVal_size(mem+res) == size) (if (i32.eq ($MalVal_size ($MalVal_ptr $res)) @@ -202,20 +202,20 @@ (then ;; ALLOC_MIDDLE ;;; if (res == mem_free_list) - (if (i32.eq $res (get_global $mem_free_list)) + (if (i32.eq $res (global.get $mem_free_list)) ;; set free pointer (mem_free_list) to next free ;;; mem_free_list = mem[res].val[0]; - (set_global $mem_free_list ($MalVal_val $res 0))) + (global.set $mem_free_list ($MalVal_val $res 0))) ;; if (res != mem_free_list) - (if (i32.ne $res (get_global $mem_free_list)) + (if (i32.ne $res (global.get $mem_free_list)) ;; set previous free to next free ;;; mem[prev].val[0] = mem[res].val[0] (i32.store ($MalVal_val_ptr $prev 0) ($MalVal_val $res 0))) (br $loop_done))) ;;; prev = res - (set_local $prev $res) + (local.set $prev $res) ;;; res = mem[res].val[0] - (set_local $res ($MalVal_val $res 0)) + (local.set $res ($MalVal_val $res 0)) (br $loop) ) ) @@ -271,11 +271,11 @@ ;;; if (mv == NULL) { return; } (if (i32.eqz $mv) (return)) ;;; idx = mv - mem - (set_local $idx ($IDX $mv)) + (local.set $idx ($IDX $mv)) ;;; type = mv->refcnt_type & 31 - (set_local $type (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 + (local.set $type (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 ;;; size = MalType_size(type) - (set_local $size ($MalType_size $type)) + (local.set $size ($MalType_size $type)) ;; DEBUG ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) @@ -283,7 +283,7 @@ (if (i32.eq 0 $mv) ($fatal 7 "RELEASE of NULL!\n")) - (if (i32.eq (get_global $FREE_T) $type) + (if (i32.eq (global.get $FREE_T) $type) (then ($printf_2 "RELEASE of already free mv: 0x%x, idx: 0x%x\n" $mv $idx) ($fatal 1 ""))) @@ -297,7 +297,7 @@ (i32.sub ($MalVal_refcnt_type $idx) 32)) ;; nil, false, true, empty sequences - (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) (then (if (i32.lt_u ($MalVal_refcnt_type $idx) 32) (then @@ -316,7 +316,7 @@ (br $done)) ;; string, kw, symbol ;; release string, then FREE reference - ($RELEASE_STRING (i32.add (get_global $string_mem) ($VAL0 $mv))) + ($RELEASE_STRING (i32.add (global.get $string_mem) ($VAL0 $mv))) (br $done)) ;; list, vector (if (i32.ne ($MalVal_val $idx 0) 0) @@ -362,23 +362,23 @@ ;; set type(FREE/15) and size ;;; mv->refcnt_type = size*32 + FREE_T - (i32.store $mv (i32.add (i32.mul $size 32) (get_global $FREE_T))) - (i32.store ($MalVal_val_ptr $idx 0) (get_global $mem_free_list)) - (set_global $mem_free_list $idx) + (i32.store $mv (i32.add (i32.mul $size 32) (global.get $FREE_T))) + (i32.store ($MalVal_val_ptr $idx 0) (global.get $mem_free_list)) + (global.set $mem_free_list $idx) (if (i32.ge_u $size 3) (i32.store ($MalVal_val_ptr $idx 1) 0)) (if (i32.eq $size 4) (i32.store ($MalVal_val_ptr $idx 2) 0)) ) ;; find string in string memory or 0 if not found (func $FIND_STRING (param $str i32) (result i32) - (LET $ms (get_global $string_mem)) + (LET $ms (global.get $string_mem)) (block $done (loop $loop - (br_if $done (i32.ge_s $ms (get_global $string_mem_next))) + (br_if $done (i32.ge_s $ms (global.get $string_mem_next))) (if (i32.eqz ($strcmp $str (i32.add $ms 4))) (return $ms)) - (set_local $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (local.set $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) (br $loop) ) ) @@ -394,7 +394,7 @@ ;; search for matching string in string_mem (if $intern (then - (set_local $ms ($FIND_STRING $str)) + (local.set $ms ($FIND_STRING $str)) (if $ms (then ;;; ms->refcnt += 1 @@ -402,13 +402,13 @@ (return $ms))))) ;; no existing matching string so create a new one - (set_local $ms (get_global $string_mem_next)) + (local.set $ms (global.get $string_mem_next)) (i32.store16 $ms 1) ;;; ms->size = sizeof(MalString)+size+1 (i32.store16 offset=2 $ms (i32.add (i32.add 4 $size) 1)) ($memmove (i32.add $ms 4) $str (i32.add $size 1)) ;;; string_mem_next = (void *)ms + ms->size - (set_global $string_mem_next + (global.set $string_mem_next ;;(i32.add $ms (i32.load16_u (i32.add $ms 2)))) (i32.add $ms (i32.load16_u offset=2 $ms))) @@ -422,44 +422,44 @@ (if (i32.le_s (i32.load16_u $ms) 0) (then ($printf_2 "Release of already free string: %d (0x%x)\n" - (i32.sub $ms (get_global $string_mem)) $ms) + (i32.sub $ms (global.get $string_mem)) $ms) ($fatal 1 ""))) ;;; size = ms->size - (set_local $size (i32.load16_u (i32.add $ms 2))) + (local.set $size (i32.load16_u (i32.add $ms 2))) ;;; *next = (void *)ms + size - (set_local $next (i32.add $ms $size)) + (local.set $next (i32.add $ms $size)) ;;; ms->refcnt -= 1 (i32.store16 $ms (i32.sub (i32.load16_u $ms) 1)) (if (i32.eqz (i32.load16_u $ms)) (then - (if (i32.gt_s (get_global $string_mem_next) $next) + (if (i32.gt_s (global.get $string_mem_next) $next) (then ;; If no more references to this string then free it up by ;; shifting up every string afterwards to fill the gap ;; (splice). - ($memmove $ms $next (i32.sub (get_global $string_mem_next) + ($memmove $ms $next (i32.sub (global.get $string_mem_next) $next)) ;; Scan the mem values for string types after the freed ;; string and shift their indexes by size - (set_local $ms_idx (i32.sub $ms (get_global $string_mem))) - (set_local $idx ($IDX (get_global $EMPTY_HASHMAP))) + (local.set $ms_idx (i32.sub $ms (global.get $string_mem))) + (local.set $idx ($IDX (global.get $EMPTY_HASHMAP))) (loop $loop - (set_local $mv ($MalVal_ptr $idx)) - (set_local $type ($TYPE $mv)) + (local.set $mv ($MalVal_ptr $idx)) + (local.set $type ($TYPE $mv)) (if (AND (i32.gt_s ($VAL0 $mv) $ms_idx) - (OR (i32.eq $type (get_global $STRING_T)) - (i32.eq $type (get_global $SYMBOL_T)))) + (OR (i32.eq $type (global.get $STRING_T)) + (i32.eq $type (global.get $SYMBOL_T)))) (i32.store ($VAL0_ptr $mv) (i32.sub ($VAL0 $mv) $size))) - (set_local $idx (i32.add $idx ($MalVal_size $mv))) + (local.set $idx (i32.add $idx ($MalVal_size $mv))) - (br_if $loop (i32.lt_s $idx (get_global $mem_unused_start))) + (br_if $loop (i32.lt_s $idx (global.get $mem_unused_start))) ))) - (set_global $string_mem_next - (i32.sub (get_global $string_mem_next) $size)))) + (global.set $string_mem_next + (i32.sub (global.get $string_mem_next) $size)))) ) ) diff --git a/wasm/package.json b/wasm/package.json index 6eecf267fc..3f19a299fc 100644 --- a/wasm/package.json +++ b/wasm/package.json @@ -1,9 +1,9 @@ { "name": "mal", "version": "0.0.1", - "description": "Make a Lisp (mal) language implemented in Javascript", + "description": "Make a Lisp (mal) language implemented in WebAssembly", "dependencies": { - "@kanaka/wamp": "1.0.4", + "@kanaka/wamp": "1.0.6", "ffi-napi": "^2.4.4", "text-encoding": "0.6.4" } diff --git a/wasm/platform_libc.wam b/wasm/platform_libc.wam index 1c769af00a..351f1f4c05 100644 --- a/wasm/platform_libc.wam +++ b/wasm/platform_libc.wam @@ -32,7 +32,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $print (param $addr i32) - (drop ($lib_fputs $addr (get_global $lib_stdout)))) + (drop ($lib_fputs $addr (global.get $lib_stdout)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -43,7 +43,7 @@ (if $line (then ($lib_add_history $line) - (set_local $len ($strlen $line)) + (local.set $len ($strlen $line)) ($memmove $buf $line $len) ($lib_free $line))) (i32.store8 (i32.add $buf $len) (CHR "\x00")) @@ -55,7 +55,7 @@ ;; Returns malloc'd string. Must be free by caller (func $read_file (param $path i32 $buf i32) (result i32) (LET $fst (STATIC_ARRAY 100) ;; at least STAT_SIZE - $fd ($lib_open $path (get_global $O_RDONLY) 0) + $fd ($lib_open $path (global.get $O_RDONLY) 0) $st_size 0 $sz 0) @@ -63,13 +63,13 @@ (then ($printf_1 "ERROR: slurp failed to open '%s'\n" $path) (return 0))) - (if (i32.lt_s ($lib___fxstat (get_global $STAT_VER_LINUX) $fd $fst) 0) + (if (i32.lt_s ($lib___fxstat (global.get $STAT_VER_LINUX) $fd $fst) 0) (then ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) (return 0))) - (set_local $st_size (i32.load - (i32.add $fst (get_global $STAT_ST_SIZE_OFFSET)))) - (set_local $sz ($lib_read $fd $buf $st_size)) + (local.set $st_size (i32.load + (i32.add $fst (global.get $STAT_ST_SIZE_OFFSET)))) + (local.set $sz ($lib_read $fd $buf $st_size)) (if (i32.ne $sz $st_size) (then ($printf_1 "ERROR: slurp failed to stat '%s'\n" $path) @@ -88,12 +88,12 @@ $usecs 0 $msecs 0) (drop ($lib_gettimeofday $tv 0)) - (set_local $secs (i32.load (i32.add $tv (get_global $TV_SEC_OFFSET)))) + (local.set $secs (i32.load (i32.add $tv (global.get $TV_SEC_OFFSET)))) ;; subtract 30 years to make sure secs is positive and can be ;; multiplied by 1000 - (set_local $secs (i32.sub $secs 0x38640900)) - (set_local $usecs (i32.load (i32.add $tv (get_global $TV_USEC_OFFSET)))) - (set_local $msecs (i32.add (i32.mul $secs 1000) + (local.set $secs (i32.sub $secs 0x38640900)) + (local.set $usecs (i32.load (i32.add $tv (global.get $TV_USEC_OFFSET)))) + (local.set $msecs (i32.add (i32.mul $secs 1000) (i32.div_u $usecs 1000))) $msecs ) diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index 197c81e200..cb76c7ff93 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -17,7 +17,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $print (param $addr i32) - (drop ($lib_fputs $addr (get_global $lib_stdout)))) + (drop ($lib_fputs $addr (global.get $lib_stdout)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/wasm/printer.wam b/wasm/printer.wam index 0bd08236c7..65708e13b9 100644 --- a/wasm/printer.wam +++ b/wasm/printer.wam @@ -15,55 +15,55 @@ (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 $type)) ;; 0: nil ($memmove $res "nil" 4) - (set_local $res (i32.add 3 $res)) + (local.set $res (i32.add 3 $res)) (br $done)) ;; 1: boolean (if (i32.eq $val0 0) (then ;; false ($memmove $res "false" 6) - (set_local $res (i32.add 5 $res))) + (local.set $res (i32.add 5 $res))) (else ;; true ($memmove $res "true" 5) - (set_local $res (i32.add 4 $res)))) + (local.set $res (i32.add 4 $res)))) (br $done)) ;; 2: integer - (set_local $res ($sprintf_1 $res "%d" $val0)) + (local.set $res ($sprintf_1 $res "%d" $val0)) (br $done)) ;; 3: float/ERROR - (set_local $res ($sprintf_1 $res "%d" " *** GOT FLOAT *** ")) + (local.set $res ($sprintf_1 $res "%d" " *** GOT FLOAT *** ")) (br $done)) ;; 4: string/kw - (set_local $sval ($to_String $mv)) + (local.set $sval ($to_String $mv)) (if (i32.eq (i32.load8_u $sval) (CHR "\x7f")) (then - (set_local $res ($sprintf_1 $res ":%s" (i32.add $sval 1)))) + (local.set $res ($sprintf_1 $res ":%s" (i32.add $sval 1)))) (else (if $print_readably (then ;; escape backslashes, quotes, and newlines - (set_local $res ($sprintf_1 $res "\"" 0)) - (set_local $res (i32.add $res ($REPLACE3 $res ($to_String $mv) + (local.set $res ($sprintf_1 $res "\"" 0)) + (local.set $res (i32.add $res ($REPLACE3 $res ($to_String $mv) "\\" "\\\\" "\"" "\\\"" "\n" "\\n"))) - (set_local $res ($sprintf_1 $res "\"" 0))) + (local.set $res ($sprintf_1 $res "\"" 0))) (else - (set_local $res ($sprintf_1 $res "%s" $sval)))))) + (local.set $res ($sprintf_1 $res "%s" $sval)))))) (br $done)) ;; 5: symbol - (set_local $res ($sprintf_1 $res "%s" ($to_String $mv))) + (local.set $res ($sprintf_1 $res "%s" ($to_String $mv))) (br $done)) ;; 6: list, fallthrouogh ) ;; 7: vector, fallthrough ) ;; 8: hashmap - (set_local + (local.set $res ($sprintf_1 $res "%c" - (if (result i32) (i32.eq $type (get_global $LIST_T)) + (if (result i32) (i32.eq $type (global.get $LIST_T)) (then (CHR "(")) - (else (if (result i32) (i32.eq $type (get_global $VECTOR_T)) + (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) (then (CHR "[")) (else (CHR "{"))))))) ;; PR_SEQ_LOOP @@ -72,73 +72,73 @@ (loop $seq_loop (br_if $done_seq (i32.eq ($VAL0 $mv) 0)) ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) - (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + (local.set $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) ;; if this is a hash-map, print the next element - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then ;;; res += snprintf(res, 2, " ") - (set_local $res ($sprintf_1 $res " " 0)) - (set_local $res ($pr_str_val $res ($MEM_VAL2_ptr $mv) + (local.set $res ($sprintf_1 $res " " 0)) + (local.set $res ($pr_str_val $res ($MEM_VAL2_ptr $mv) $print_readably)))) ;;; mv = MEM_VAL0(mv) - (set_local $mv ($MEM_VAL0_ptr $mv)) + (local.set $mv ($MEM_VAL0_ptr $mv)) ;;; if (VAL0(mv) != 0) (if (i32.ne ($VAL0 $mv) 0) ;;; res += snprintf(res, 2, " ") - (set_local $res ($sprintf_1 $res " " 0))) + (local.set $res ($sprintf_1 $res " " 0))) (br $seq_loop) ) ) - (set_local + (local.set $res ($sprintf_1 $res "%c" - (if (result i32) (i32.eq $type (get_global $LIST_T)) + (if (result i32) (i32.eq $type (global.get $LIST_T)) (then (CHR ")")) - (else (if (result i32) (i32.eq $type (get_global $VECTOR_T)) + (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) (then (CHR "]")) (else (CHR "}"))))))) (br $done)) ;; 9: function ($memmove $res "#" 10) - (set_local $res (i32.add 9 $res)) + (local.set $res (i32.add 9 $res)) (br $done)) ;; 10: mal function ($memmove $res "(fn* " 6) - (set_local $res (i32.add 5 $res)) - (set_local $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + (local.set $res (i32.add 5 $res)) + (local.set $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) ($memmove $res " " 2) - (set_local $res (i32.add 1 $res)) - (set_local $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + (local.set $res (i32.add 1 $res)) + (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) ($memmove $res ")" 2) - (set_local $res (i32.add 1 $res)) + (local.set $res (i32.add 1 $res)) (br $done)) ;; 11: macro fn ($memmove $res "#" 13) - (set_local $res (i32.add 12 $res)) + (local.set $res (i32.add 12 $res)) (br $done)) ;; 12: atom ($memmove $res "(atom " 7) - (set_local $res (i32.add 6 $res)) - (set_local $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + (local.set $res (i32.add 6 $res)) + (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) ($memmove $res ")" 2) - (set_local $res (i32.add 1 $res)) + (local.set $res (i32.add 1 $res)) (br $done)) ;; 13: environment ($memmove $res "#" 11) - (set_local $res (i32.add 10 $res)) + (local.set $res (i32.add 10 $res)) (br $done)) ;; 14: metadata ;; recur on object itself - (set_local $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) (br $done)) ;; 15: FREE ($memmove $res "#" 12) - (set_local $res (i32.add 11 $res)) + (local.set $res (i32.add 11 $res)) (br $done)) ;; 16: default ($memmove $res "#" 11) - (set_local $res (i32.add 10 $res)) + (local.set $res (i32.add 10 $res)) ) $res @@ -146,7 +146,7 @@ (func $pr_str_internal (param $seq i32) (param $mv i32) (param $print_readably i32) (param $sep i32) (result i32) - (LET $res ($STRING_INIT (get_global $STRING_T)) + (LET $res ($STRING_INIT (global.get $STRING_T)) $res_str ($to_String $res)) (if $seq @@ -154,17 +154,17 @@ (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $mv))) - (set_local $res_str ($pr_str_val $res_str ($MEM_VAL1_ptr $mv) $print_readably)) - (set_local $mv ($MEM_VAL0_ptr $mv)) + (local.set $res_str ($pr_str_val $res_str ($MEM_VAL1_ptr $mv) $print_readably)) + (local.set $mv ($MEM_VAL0_ptr $mv)) (if (i32.ne ($VAL0 $mv) 0) - (set_local $res_str ($sprintf_1 $res_str "%s" $sep))) + (local.set $res_str ($sprintf_1 $res_str "%s" $sep))) (br $loop) ) )) (else - (set_local $res_str ($pr_str_val $res_str $mv $print_readably)))) + (local.set $res_str ($pr_str_val $res_str $mv $print_readably)))) - (set_local $res ($STRING_FINALIZE $res (i32.sub $res_str ($to_String $res)))) + (local.set $res ($STRING_FINALIZE $res (i32.sub $res_str ($to_String $res)))) $res ) diff --git a/wasm/printf.wam b/wasm/printf.wam index b06a23864e..7c5d730d0d 100644 --- a/wasm/printf.wam +++ b/wasm/printf.wam @@ -4,46 +4,46 @@ (func $init_printf_mem ;; sprintf static buffer - (set_global $printf_buf (STATIC_ARRAY 256)) + (global.set $printf_buf (STATIC_ARRAY 256)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $printf_1 (param $fmt i32) (param $v0 i32) - (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 0 0 0 0 0)) - ($print (get_global $printf_buf)) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 0 0 0 0 0)) + ($print (global.get $printf_buf)) ) (func $printf_2 (param $fmt i32 $v0 i32 $v1 i32) - (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 0 0 0 0)) - ($print (get_global $printf_buf)) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 0 0 0 0)) + ($print (global.get $printf_buf)) ) (func $printf_3 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) - (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 0 0 0)) - ($print (get_global $printf_buf)) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 0 0 0)) + ($print (global.get $printf_buf)) ) (func $printf_4 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) - (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) - ($print (get_global $printf_buf)) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) + ($print (global.get $printf_buf)) ) (func $printf_5 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) - (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) - ($print (get_global $printf_buf)) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) + ($print (global.get $printf_buf)) ) (func $printf_6 (param $fmt i32) (param $v0 i32) (param $v1 i32) (param $v2 i32) (param $v3 i32) (param $v4 i32) (param $v5 i32) - (drop ($sprintf_6 (get_global $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) - ($print (get_global $printf_buf)) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) + ($print (global.get $printf_buf)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -62,27 +62,27 @@ (if (AND (i32.lt_s $val 0) (i32.eq $radix 10)) (then - (set_local $neg 1) - (set_local $val (i32.sub 0 $val)))) + (local.set $neg 1) + (local.set $val (i32.sub 0 $val)))) ;; Calculate smallest to most significant digit (loop $loop - (set_local $digit (i32.rem_u $val $radix)) + (local.set $digit (i32.rem_u $val $radix)) (i32.store8 $pbuf (if (result i32) (i32.lt_u $digit 10) (i32.add (CHR "0") $digit) (i32.sub (i32.add (CHR "A") $digit) 10))) - (set_local $pbuf (i32.add $pbuf 1)) - (set_local $val (i32.div_u $val $radix)) + (local.set $pbuf (i32.add $pbuf 1)) + (local.set $val (i32.div_u $val $radix)) (br_if $loop (i32.gt_u $val 0)) ) - (set_local $i (i32.sub $pbuf $buf)) + (local.set $i (i32.sub $pbuf $buf)) (block $done (loop $loop (br_if $done (i32.ge_u $i $pad_cnt)) (i32.store8 $pbuf $pad_char) - (set_local $pbuf (i32.add $pbuf 1)) - (set_local $i (i32.add $i 1)) + (local.set $pbuf (i32.add $pbuf 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -90,22 +90,22 @@ (if $neg (then (i32.store8 $pbuf (CHR "-")) - (set_local $pbuf (i32.add $pbuf 1)))) + (local.set $pbuf (i32.add $pbuf 1)))) (i32.store8 $pbuf (CHR "\x00")) ;; now reverse it - (set_local $len (i32.sub $pbuf $buf)) - (set_local $i 0) + (local.set $len (i32.sub $pbuf $buf)) + (local.set $i 0) (block $done (loop $loop (br_if $done (i32.ge_u $i (i32.div_u $len 2))) - (set_local $j (i32.load8_u (i32.add $buf $i))) - (set_local $k (i32.add $buf (i32.sub (i32.sub $len $i) 1))) + (local.set $j (i32.load8_u (i32.add $buf $i))) + (local.set $k (i32.add $buf (i32.sub (i32.sub $len $i) 1))) (i32.store8 (i32.add $buf $i) (i32.load8_u $k)) (i32.store8 $k $j) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -132,17 +132,17 @@ ;; set $v to the current parameter (block (block (block (block (block (block (br_table 0 1 2 3 4 5 0 $vidx)) - (; 0 ;) (set_local $v $v0) (br $after_v)) - (; 1 ;) (set_local $v $v1) (br $after_v)) - (; 2 ;) (set_local $v $v2) (br $after_v)) - (; 3 ;) (set_local $v $v3) (br $after_v)) - (; 4 ;) (set_local $v $v4) (br $after_v)) - (; 5 ;) (set_local $v $v5) (br $after_v) + (; 0 ;) (local.set $v $v0) (br $after_v)) + (; 1 ;) (local.set $v $v1) (br $after_v)) + (; 2 ;) (local.set $v $v2) (br $after_v)) + (; 3 ;) (local.set $v $v3) (br $after_v)) + (; 4 ;) (local.set $v $v4) (br $after_v)) + (; 5 ;) (local.set $v $v5) (br $after_v) ) ;;; while ((ch=*(fmt++))) - (set_local $ch (i32.load8_u $fmt)) - (set_local $fmt (i32.add 1 $fmt)) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) (br_if $done (i32.eqz $ch)) ;; TODO: check buffer length @@ -150,71 +150,71 @@ (then ;; TODO: check buffer length (i32.store8 $pstr $ch) - (set_local $pstr (i32.add 1 $pstr)) + (local.set $pstr (i32.add 1 $pstr)) (br $loop))) ;;; ch=*(fmt++) - (set_local $ch (i32.load8_u $fmt)) - (set_local $fmt (i32.add 1 $fmt)) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) (br_if $done (i32.eqz $ch)) - (set_local $pad_cnt 0) - (set_local $pad_char (CHR " ")) + (local.set $pad_cnt 0) + (local.set $pad_char (CHR " ")) (if (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9"))) (then ;; padding requested (if (i32.eq $ch (CHR "0")) (then ;; zero padding requested - (set_local $pad_char (CHR "0")) + (local.set $pad_char (CHR "0")) ;;; ch=*(fmt++) - (set_local $ch (i32.load8_u $fmt)) - (set_local $fmt (i32.add 1 $fmt)) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) (br_if $done (i32.eqz $ch)))) (loop $loop - (set_local $pad_cnt (i32.mul $pad_cnt 10)) - (set_local $pad_cnt (i32.add $pad_cnt + (local.set $pad_cnt (i32.mul $pad_cnt 10)) + (local.set $pad_cnt (i32.add $pad_cnt (i32.sub $ch (CHR "0")))) - (set_local $ch (i32.load8_u $fmt)) - (set_local $fmt (i32.add 1 $fmt)) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) (br_if $loop (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9")))) ))) (if (i32.eq (CHR "d") $ch) (then - (set_local $pstr ($_sprintnum $pstr $v 10 $pad_cnt $pad_char))) + (local.set $pstr ($_sprintnum $pstr $v 10 $pad_cnt $pad_char))) (else (if (i32.eq (CHR "x") $ch) (then - (set_local $pstr ($_sprintnum $pstr $v 16 $pad_cnt $pad_char))) + (local.set $pstr ($_sprintnum $pstr $v 16 $pad_cnt $pad_char))) (else (if (i32.eq (CHR "s") $ch) (then - (set_local $len ($strlen $v)) + (local.set $len ($strlen $v)) (block $done (loop $loop (br_if $done (i32.le_s $pad_cnt $len)) (i32.store8 $pstr (CHR " ")) - (set_local $pstr (i32.add $pstr 1)) - (set_local $pad_cnt (i32.sub $pad_cnt 1)) + (local.set $pstr (i32.add $pstr 1)) + (local.set $pad_cnt (i32.sub $pad_cnt 1)) (br $loop) ) ) ($memmove $pstr $v $len) - (set_local $pstr (i32.add $pstr $len))) + (local.set $pstr (i32.add $pstr $len))) (else (if (i32.eq (CHR "c") $ch) (then (i32.store8 $pstr $v) - (set_local $pstr (i32.add $pstr 1))) + (local.set $pstr (i32.add $pstr 1))) (else (if (i32.eq (CHR "%") $ch) (then (i32.store8 $pstr (CHR "%")) - (set_local $pstr (i32.add $pstr 1)) + (local.set $pstr (i32.add $pstr 1)) (br $loop)) ;; don't increase vidx (else ($printf_1 "Illegal format character: '%c'\n" $ch) ($fatal 3 ""))))))))))) - (set_local $vidx (i32.add 1 $vidx)) + (local.set $vidx (i32.add 1 $vidx)) (br $loop) ) ) diff --git a/wasm/reader.wam b/wasm/reader.wam index e87c01eb5f..0a46736535 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -6,17 +6,17 @@ (func $skip_spaces (param $str i32) (result i32) (LET $found 0 - $c (i32.load8_u (i32.add $str (get_global $read_index)))) + $c (i32.load8_u (i32.add $str (global.get $read_index)))) (block $done (loop $loop ;;; while (c == ' ' || c == ',' || c == '\n') (br_if $done (AND (i32.ne $c (CHR " ")) (i32.ne $c (CHR ",")) (i32.ne $c (CHR "\n")))) - (set_local $found 1) + (local.set $found 1) ;;; c=str[++(*index)] - (set_global $read_index (i32.add (get_global $read_index) 1)) - (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (global.set $read_index (i32.add (global.get $read_index) 1)) + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) (br $loop) ) ) @@ -26,16 +26,16 @@ (func $skip_to_eol (param $str i32) (result i32) (LET $found 0 - $c (i32.load8_u (i32.add $str (get_global $read_index)))) + $c (i32.load8_u (i32.add $str (global.get $read_index)))) (if (i32.eq $c (CHR ";")) (then - (set_local $found 1) + (local.set $found 1) (block $done (loop $loop ;;; c=str[++(*index)] - (set_global $read_index (i32.add (get_global $read_index) 1)) - (set_local $c (i32.load8_u (i32.add $str - (get_global $read_index)))) + (global.set $read_index (i32.add (global.get $read_index) 1)) + (local.set $c (i32.load8_u (i32.add $str + (global.get $read_index)))) ;;; while (c != '\0' && c != '\n') (br_if $loop (AND (i32.ne $c (CHR "\x00")) (i32.ne $c (CHR "\n")))) @@ -64,12 +64,12 @@ ;; read first character ;;; c=str[++(*index)] - (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) - (set_global $read_index (i32.add (get_global $read_index) 1)) + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (global.set $read_index (i32.add (global.get $read_index) 1)) ;; read first character ;;; token[token_index++] = c - (i32.store8 (i32.add (get_global $token_buf) $token_index) $c) - (set_local $token_index (i32.add $token_index 1)) + (i32.store8 (i32.add (global.get $token_buf) $token_index) $c) + (local.set $token_index (i32.add $token_index 1)) ;; single/double character token (if (OR (i32.eq $c (CHR "(")) (i32.eq $c (CHR ")")) @@ -81,7 +81,7 @@ (i32.eq $c (CHR "`")) (i32.eq $c (CHR "@")) (AND (i32.eq $c (CHR "~")) - (i32.ne (i32.load8_u (i32.add $str (get_global $read_index))) + (i32.ne (i32.load8_u (i32.add $str (global.get $read_index))) (CHR "@")))) (then @@ -89,13 +89,13 @@ (nop)) (else ;;; if (c == '"') instring = true - (set_local $instring (i32.eq $c (CHR "\""))) + (local.set $instring (i32.eq $c (CHR "\""))) (block $done (loop $loop ;; peek at next character ;;; c = str[*index] - (set_local $c (i32.load8_u - (i32.add $str (get_global $read_index)))) + (local.set $c (i32.load8_u + (i32.add $str (global.get $read_index)))) ;;; if (c == '\0') break (br_if $done (i32.eq $c 0)) ;;; if (!instring) @@ -113,34 +113,34 @@ (i32.eq $c (CHR "\n")))))) ;; read next character ;;; token[token_index++] = str[(*index)++] - (i32.store8 (i32.add (get_global $token_buf) $token_index) + (i32.store8 (i32.add (global.get $token_buf) $token_index) (i32.load8_u - (i32.add $str (get_global $read_index)))) - (set_local $token_index (i32.add $token_index 1)) - (set_global $read_index (i32.add (get_global $read_index) 1)) + (i32.add $str (global.get $read_index)))) + (local.set $token_index (i32.add $token_index 1)) + (global.set $read_index (i32.add (global.get $read_index) 1)) ;;; if (token[0] == '~' && token[1] == '@') break (br_if $done (AND (i32.eq (i32.load8_u - (i32.add (get_global $token_buf) 0)) + (i32.add (global.get $token_buf) 0)) (CHR "~")) (i32.eq (i32.load8_u - (i32.add (get_global $token_buf) 1)) + (i32.add (global.get $token_buf) 1)) (CHR "@")))) ;;; if ((!instring) || escaped) (if (OR (i32.eqz $instring) $escaped) (then - (set_local $escaped 0) + (local.set $escaped 0) (br $loop))) (if (i32.eq $c (CHR "\\")) - (set_local $escaped 1)) + (local.set $escaped 1)) (br_if $done (i32.eq $c (CHR "\""))) (br $loop) ) ))) ;;; token[token_index] = '\0' - (i32.store8 (i32.add (get_global $token_buf) $token_index) 0) - (get_global $token_buf) + (i32.store8 (i32.add (global.get $token_buf) $token_index) 0) + (global.get $token_buf) ) (func $read_seq (param $str i32 $type i32 $end i32) (result i32) @@ -160,7 +160,7 @@ ;; peek at next character ;;; c = str[*index] - (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) (if (i32.eq $c (CHR "\x00")) (then ($THROW_STR_0 "unexpected EOF") @@ -169,31 +169,31 @@ (then ;; read next character ;;; c = str[(*index)++] - (set_local $c (i32.load8_u (i32.add $str (get_global $read_index)))) - (set_global $read_index (i32.add (get_global $read_index) 1)) + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (global.set $read_index (i32.add (global.get $read_index) 1)) (br $done))) ;; value (or key for hash-maps) - (set_local $val2 ($read_form $str)) + (local.set $val2 ($read_form $str)) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $val2) (br $done))) ;; if this is a hash-map, READ_FORM again - (if (i32.eq $type (get_global $HASHMAP_T)) - (set_local $val3 ($read_form $str))) + (if (i32.eq $type (global.get $HASHMAP_T)) + (local.set $val3 ($read_form $str))) ;; update the return sequence structure ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) (br $loop) ) @@ -204,17 +204,17 @@ ) (func $read_macro (param $str i32 $sym i32 $with_meta i32) (result i32) - (LET $first ($STRING (get_global $SYMBOL_T) $sym) + (LET $first ($STRING (global.get $SYMBOL_T) $sym) $second ($read_form $str) $third 0 $res $second) - (if (get_global $error_type) (return $res)) + (if (global.get $error_type) (return $res)) (if (i32.eqz $with_meta) (then - (set_local $res ($LIST2 $first $second))) + (local.set $res ($LIST2 $first $second))) (else - (set_local $third ($read_form $str)) - (set_local $res ($LIST3 $first $third $second)) + (local.set $third ($read_form $str)) + (local.set $res ($LIST3 $first $third $second)) ;; release values, list has ownership ($RELEASE $third))) ;; release values, list has ownership @@ -226,17 +226,17 @@ (func $read_form (param $str i32) (result i32) (LET $tok 0 $c0 0 $c1 0 $res 0 $slen 0) - (if (get_global $error_type) (return 0)) + (if (global.get $error_type) (return 0)) - (set_local $tok ($read_token $str)) + (local.set $tok ($read_token $str)) ;;($printf_1 ">>> read_form 1: %s\n" $tok) ;;; c0 = token[0] - (set_local $c0 (i32.load8_u $tok)) - (set_local $c1 (i32.load8_u (i32.add $tok 1))) + (local.set $c0 (i32.load8_u $tok)) + (local.set $c1 (i32.load8_u (i32.add $tok 1))) (if (i32.eq $c0 0) (then - (return ($INC_REF (get_global $NIL)))) + (return ($INC_REF (global.get $NIL)))) (else (if (OR (AND (i32.ge_u $c0 (CHR "0")) (i32.le_u $c0 (CHR "9"))) (AND (i32.eq $c0 (CHR "-")) @@ -247,10 +247,10 @@ (else (if (i32.eq $c0 (CHR ":")) (then (i32.store8 $tok (CHR "\x7f")) - (return ($STRING (get_global $STRING_T) $tok))) + (return ($STRING (global.get $STRING_T) $tok))) (else (if (i32.eq $c0 (CHR "\"")) (then - (set_local $slen ($strlen (i32.add $tok 1))) + (local.set $slen ($strlen (i32.add $tok 1))) (if (i32.ne (i32.load8_u (i32.add $tok $slen)) (CHR "\"")) (then ($THROW_STR_0 "expected '\"'") @@ -259,18 +259,18 @@ ;; unescape backslashes, quotes, and newlines ;; remove the trailing quote (i32.store8 (i32.add $tok $slen) (CHR "\x00")) - (set_local $tok (i32.add $tok 1)) + (local.set $tok (i32.add $tok 1)) (drop ($REPLACE3 0 $tok "\\\"" "\"" "\\n" "\n" "\\\\" "\\")) - (return ($STRING (get_global $STRING_T) $tok))))) + (return ($STRING (global.get $STRING_T) $tok))))) (else (if (i32.eqz ($strcmp "nil" $tok)) - (then (return ($INC_REF (get_global $NIL)))) + (then (return ($INC_REF (global.get $NIL)))) (else (if (i32.eqz ($strcmp "false" $tok)) - (then (return ($INC_REF (get_global $FALSE)))) + (then (return ($INC_REF (global.get $FALSE)))) (else (if (i32.eqz ($strcmp "true" $tok)) - (then (return ($INC_REF (get_global $TRUE)))) + (then (return ($INC_REF (global.get $TRUE)))) (else (if (i32.eqz ($strcmp "'" $tok)) (then (return ($read_macro $str "quote" 0))) (else (if (i32.eqz ($strcmp "`" $tok)) @@ -284,11 +284,11 @@ (else (if (i32.eqz ($strcmp "@" $tok)) (then (return ($read_macro $str "deref" 0))) (else (if (i32.eq $c0 (CHR "(")) - (then (return ($read_seq $str (get_global $LIST_T) (CHR ")")))) + (then (return ($read_seq $str (global.get $LIST_T) (CHR ")")))) (else (if (i32.eq $c0 (CHR "[")) - (then (return ($read_seq $str (get_global $VECTOR_T) (CHR "]")))) + (then (return ($read_seq $str (global.get $VECTOR_T) (CHR "]")))) (else (if (i32.eq $c0 (CHR "{")) - (then (return ($read_seq $str (get_global $HASHMAP_T) (CHR "}")))) + (then (return ($read_seq $str (global.get $HASHMAP_T) (CHR "}")))) (else (if (OR (i32.eq $c0 (CHR ")")) (i32.eq $c0 (CHR "]")) (i32.eq $c0 (CHR "}"))) @@ -296,13 +296,13 @@ ($THROW_STR_1 "unexpected '%c'" $c0) (return 0)) (else - (return ($STRING (get_global $SYMBOL_T) $tok)))) + (return ($STRING (global.get $SYMBOL_T) $tok)))) )))))))))))))))))))))))))))))))) 0 ;; not reachable ) (func $read_str (param $str i32) (result i32) - (set_global $read_index 0) + (global.set $read_index 0) ($read_form $str) ) diff --git a/wasm/step0_repl.wam b/wasm/step0_repl.wam index 26b80fdf9e..354d46ce55 100644 --- a/wasm/step0_repl.wam +++ b/wasm/step0_repl.wam @@ -24,7 +24,7 @@ (LET $line (STATIC_ARRAY 201)) ;; DEBUG - ;;($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) + ;;($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) ;; Start REPL (block $repl_done diff --git a/wasm/step1_read_print.wam b/wasm/step1_read_print.wam index 1de13a9965..a41d3331cd 100644 --- a/wasm/step1_read_print.wam +++ b/wasm/step1_read_print.wam @@ -19,14 +19,14 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv1 0 $mv2 0 $ms 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $mv2 ($EVAL $mv1 $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($EVAL $mv1 $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from MAL_READ @@ -39,18 +39,18 @@ $res 0) ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) ;; ($PR_MEMORY_RAW -;; (get_global $mem) (i32.add (get_global $mem) -;; (i32.mul (get_global $mem_unused_start) 4))) +;; (global.get $mem) (i32.add (global.get $mem) +;; (i32.mul (global.get $mem_unused_start) 4))) - (drop ($STRING (get_global $STRING_T) "uvw")) - (drop ($STRING (get_global $STRING_T) "xyz")) + (drop ($STRING (global.get $STRING_T) "uvw")) + (drop ($STRING (global.get $STRING_T) "xyz")) ;;($PR_MEMORY -1 -1) @@ -59,11 +59,11 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line 0)) - (if (get_global $error_type) + (local.set $res ($REP $line 0)) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step2_eval.wam b/wasm/step2_eval.wam index c843ab59ce..0ce9712b5c 100644 --- a/wasm/step2_eval.wam +++ b/wasm/step2_eval.wam @@ -13,8 +13,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -24,71 +24,71 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res2 ($HASHMAP_GET $env $ast)) - (set_local $res (i32.wrap/i64 $res2)) - (set_local $found (i32.wrap/i64 (i64.shr_u $res2 + (local.set $res2 ($HASHMAP_GET $env $ast)) + (local.set $res (i32.wrap_i64 $res2)) + (local.set $found (i32.wrap_i64 (i64.shr_u $res2 (i64.const 32)))) (if (i32.eqz $found) ($THROW_STR_1 "'%s' not found" ($to_String $ast))) - (set_local $res ($INC_REF $res)) + (local.set $res ($INC_REF $res)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop ;; check if we are done evaluating the source sequence (br_if $done (i32.eq ($VAL0 $ast) 0)) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -96,7 +96,7 @@ (type $fnT (func (param i32) (result i32))) - (table anyfunc + (table funcref (elem $add $subtract $multiply $divide)) @@ -104,15 +104,15 @@ (LET $res 0 $ftype 0 $f_args 0 $f 0 $args 0) - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) (return 0)) + (if (global.get $error_type) (return 0)) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (return ($EVAL_AST $ast $env))) ;; APPLY_LIST @@ -120,23 +120,23 @@ (return ($INC_REF $ast))) ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (return $f_args)) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0))) + (local.set $res 0))) ($RELEASE $f_args) @@ -152,14 +152,14 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv1 0 $mv2 0 $ms 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $mv2 ($EVAL $mv1 $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($EVAL $mv1 $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from MAL_READ and EVAL @@ -190,19 +190,19 @@ $res 0 $repl_env 0) ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($HASHMAP)) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($HASHMAP)) + (local.set $repl_env (global.get $repl_env)) - (set_local $repl_env ($ASSOC1_S $repl_env "+" ($FUNCTION 0))) - (set_local $repl_env ($ASSOC1_S $repl_env "-" ($FUNCTION 1))) - (set_local $repl_env ($ASSOC1_S $repl_env "*" ($FUNCTION 2))) - (set_local $repl_env ($ASSOC1_S $repl_env "/" ($FUNCTION 3))) + (local.set $repl_env ($ASSOC1_S $repl_env "+" ($FUNCTION 0))) + (local.set $repl_env ($ASSOC1_S $repl_env "-" ($FUNCTION 1))) + (local.set $repl_env ($ASSOC1_S $repl_env "*" ($FUNCTION 2))) + (local.set $repl_env ($ASSOC1_S $repl_env "/" ($FUNCTION 3))) ;;($PR_MEMORY -1 -1) @@ -211,11 +211,11 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step3_env.wam b/wasm/step3_env.wam index 67e29fbdbb..df04633b31 100644 --- a/wasm/step3_env.wam +++ b/wasm/step3_env.wam @@ -12,8 +12,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -23,63 +23,63 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop ;; check if we are done evaluating the source sequence (br_if $done (i32.eq ($VAL0 $ast) 0)) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -87,7 +87,7 @@ (type $fnT (func (param i32) (result i32))) - (table anyfunc + (table funcref (elem $add $subtract $multiply $divide)) @@ -104,84 +104,84 @@ $a0 0 $a0sym 0 $a1 0 $a2 0 $let_env 0) - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) (return 0)) + (if (global.get $error_type) (return 0)) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (return ($EVAL_AST $ast $env))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (return $res)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (if (global.get $error_type) (return $res)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res))) + (local.set $res ($ENV_SET $env $a1 $res))) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $let_env ($ENV_NEW $env)) + (local.set $let_env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $let_env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) - (set_local $res ($EVAL $a2 $let_env)) + (local.set $res ($EVAL $a2 $let_env)) ;; EVAL_RETURN ($RELEASE $let_env)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (return $f_args)) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f)))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0))) + (local.set $res 0))) ($RELEASE $f_args))))) @@ -197,14 +197,14 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv1 0 $mv2 0 $ms 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $mv2 ($EVAL $mv1 $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($EVAL $mv1 $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from MAL_READ and EVAL @@ -231,21 +231,21 @@ ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) (func $pr_memory (param $args i32) (result i32) ($PR_MEMORY -1 -1) - ($INC_REF (get_global $NIL))) + ($INC_REF (global.get $NIL))) (func $main (result i32) (LET $line (STATIC_ARRAY 201) $res 0 $repl_env 0) ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) (drop ($ENV_SET_S $repl_env "+" ($FUNCTION 0))) (drop ($ENV_SET_S $repl_env "-" ($FUNCTION 1))) @@ -259,11 +259,11 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step4_if_fn_do.wam b/wasm/step4_if_fn_do.wam index 24f3c7f7d5..da16f570cf 100644 --- a/wasm/step4_if_fn_do.wam +++ b/wasm/step4_if_fn_do.wam @@ -12,8 +12,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -23,63 +23,63 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop ;; check if we are done evaluating the source sequence (br_if $done (i32.eq ($VAL0 $ast) 0)) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -98,135 +98,135 @@ $a0 0 $a0sym 0 $a1 0 $a2 0 $a3 0 $let_env 0 $fn_env 0 $a 0) - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) (return 0)) + (if (global.get $error_type) (return 0)) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (return ($EVAL_AST $ast $env))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (return ($INC_REF $ast))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (if (get_global $error_type) (return $res)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (if (global.get $error_type) (return $res)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res))) + (local.set $res ($ENV_SET $env $a1 $res))) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $let_env ($ENV_NEW $env)) + (local.set $let_env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $let_env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) - (set_local $res ($EVAL $a2 $let_env)) + (local.set $res ($EVAL $a2 $let_env)) ;; EVAL_RETURN ($RELEASE $let_env)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env)) - (set_local $res ($LAST $el)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env)) + (local.set $res ($LAST $el)) ($RELEASE $el)) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL)))) + (local.set $res ($INC_REF (global.get $NIL)))) (else - (set_local $a3 ($MAL_GET_A3 $ast)) - (set_local $res ($EVAL $a3 $env))))) + (local.set $a3 ($MAL_GET_A3 $ast)) + (local.set $res ($EVAL $a3 $env))))) (else ($RELEASE $res) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env))))))) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env))))))) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($ALLOC (get_global $MALFUNC_T) $a2 $a1 $env))) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($ALLOC (global.get $MALFUNC_T) $a2 $a1 $env))) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (return $f_args)) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))) ;; release f/args ($RELEASE $f_args)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then - (set_local $fn_env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $fn_env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; claim the AST before releasing the list containing it - (set_local $a ($MEM_VAL0_ptr $f)) + (local.set $a ($MEM_VAL0_ptr $f)) (drop ($INC_REF $a)) ;; release f/args ($RELEASE $f_args) - (set_local $res ($EVAL $a $fn_env)) + (local.set $res ($EVAL $a $fn_env)) ;; EVAL_RETURN ($RELEASE $fn_env) ($RELEASE $a)) (else ;; create new environment using env and params stored in function ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args))))))))))))))) $res @@ -241,10 +241,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -255,11 +255,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -272,14 +272,14 @@ $res 0 $repl_env 0 $ms 0) ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -296,18 +296,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step5_tco.wam b/wasm/step5_tco.wam index 6186604080..20d8fda7d3 100644 --- a/wasm/step5_tco.wam +++ b/wasm/step5_tco.wam @@ -12,8 +12,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -23,16 +23,16 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop @@ -42,47 +42,47 @@ (if $skiplast (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -105,67 +105,67 @@ (block $EVAL_return (loop $TCO_loop - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res 0) + (local.set $res 0) (br $EVAL_return))) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (then - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) (br $EVAL_return))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $prev_env $env) ;; save env for later release - (set_local $env ($ENV_NEW $env)) + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) @@ -174,73 +174,73 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then ;; EVAL the rest through second to last - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (set_local $ast ($LAST $ast)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL))) + (local.set $res ($INC_REF (global.get $NIL))) (br $EVAL_return)) (else - (set_local $ast ($MAL_GET_A3 $ast))))) + (local.set $ast ($MAL_GET_A3 $ast))))) (else ($RELEASE $res) - (set_local $ast ($MAL_GET_A2 $ast)))))) + (local.set $ast ($MAL_GET_A2 $ast)))))) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($MALFUNC $a2 $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) (br $EVAL_return)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env 0)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res $f_args) + (local.set $res $f_args) (br $EVAL_return))) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))) ;; release f/args ($RELEASE $f_args) (br $EVAL_return)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; release previous environment if not the current EVAL env @@ -249,17 +249,17 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) ;; claim the AST before releasing the list containing it - (set_local $ast ($MEM_VAL0_ptr $f)) + (local.set $ast ($MEM_VAL0_ptr $f)) (drop ($INC_REF $ast)) ;; if we have already been here via TCO, release previous ;; ast ;; PEND_A_LV (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) ;; release f/args ($RELEASE $f_args) @@ -267,7 +267,7 @@ (br $TCO_loop)) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args) (br $EVAL_return))))))))))))))) @@ -290,10 +290,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -304,11 +304,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -321,14 +321,14 @@ $res 0 $repl_env 0 $ms 0) ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -345,18 +345,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step6_file.wam b/wasm/step6_file.wam index e3029b03be..e5b56a644c 100644 --- a/wasm/step6_file.wam +++ b/wasm/step6_file.wam @@ -12,8 +12,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -23,16 +23,16 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop @@ -42,47 +42,47 @@ (if $skiplast (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -105,67 +105,67 @@ (block $EVAL_return (loop $TCO_loop - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res 0) + (local.set $res 0) (br $EVAL_return))) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (then - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) (br $EVAL_return))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $prev_env $env) ;; save env for later release - (set_local $env ($ENV_NEW $env)) + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) @@ -174,78 +174,78 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then ;; EVAL the rest through second to last - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (set_local $ast ($LAST $ast)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL))) + (local.set $res ($INC_REF (global.get $NIL))) (br $EVAL_return)) (else - (set_local $ast ($MAL_GET_A3 $ast))))) + (local.set $ast ($MAL_GET_A3 $ast))))) (else ($RELEASE $res) - (set_local $ast ($MAL_GET_A2 $ast)))))) + (local.set $ast ($MAL_GET_A2 $ast)))))) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($MALFUNC $a2 $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) (br $EVAL_return)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env 0)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res $f_args) + (local.set $res $f_args) (br $EVAL_return))) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then (if (i32.eq ($VAL0 $f) 0) ;; eval (then - (set_local $res ($EVAL ($MEM_VAL1_ptr $args) - (get_global $repl_env)))) + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) (else - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) ;; release f/args ($RELEASE $f_args) (br $EVAL_return)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; release previous environment if not the current EVAL env @@ -254,17 +254,17 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) ;; claim the AST before releasing the list containing it - (set_local $ast ($MEM_VAL0_ptr $f)) + (local.set $ast ($MEM_VAL0_ptr $f)) (drop ($INC_REF $ast)) ;; if we have already been here via TCO, release previous ;; ast ;; PEND_A_LV (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) ;; release f/args ($RELEASE $f_args) @@ -272,7 +272,7 @@ (br $TCO_loop)) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args) (br $EVAL_return))))))))))))))) @@ -295,10 +295,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -309,11 +309,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -329,14 +329,14 @@ ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -350,31 +350,31 @@ ;; Command line arguments - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) ;; push MAP_LOP stack ;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) - (set_local $i 2) + (local.set $i 2) (block $done (loop $loop (br_if $done (i32.ge_u $i $argc)) - (set_local $val2 ($STRING (get_global $STRING_T) + (local.set $val2 ($STRING (global.get $STRING_T) (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE - (get_global $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -386,12 +386,12 @@ (if (i32.gt_u $argc 1) (then (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (get_global $STRING_T) + "*FILE*" ($STRING (global.get $STRING_T) (i32.load (i32.add $argv 4))))) ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (get_global $error_type) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + ($printf_1 "Error: %s\n" (global.get $error_str)) (return 1)) (else (return 0))))) @@ -401,18 +401,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step7_quote.wam b/wasm/step7_quote.wam index 753f97a8ad..e609a56d4b 100644 --- a/wasm/step7_quote.wam +++ b/wasm/step7_quote.wam @@ -10,8 +10,8 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) (LET $type ($TYPE $ast)) - (AND (OR (i32.eq $type (get_global $LIST_T)) - (i32.eq $type (get_global $VECTOR_T))) + (AND (OR (i32.eq $type (global.get $LIST_T)) + (i32.eq $type (global.get $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) @@ -19,38 +19,38 @@ (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then - (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) ;; ['quote ast] - (set_local $res ($LIST2 $sym $ast)) + (local.set $res ($LIST2 $sym $ast)) ($RELEASE $sym)) (else - (set_local $res ($MEM_VAL1_ptr $ast)) - (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (local.set $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (global.get $SYMBOL_T)) (i32.eqz ($strcmp "unquote" ($to_String $res)))) (then ;; ast[1] - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) (else (if (AND ($is_pair $res) (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) - (get_global $SYMBOL_T)) + (global.get $SYMBOL_T)) (i32.eqz ($strcmp "splice-unquote" ($to_String ($MEM_VAL1_ptr $res))))) (then ;; ['concat, ast[0][1], quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) - (set_local $second + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $second ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list take ownership ($RELEASE $third) ($RELEASE $sym)) (else ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) - (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list takes ownership ($RELEASE $third) ($RELEASE $second) @@ -62,8 +62,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -73,16 +73,16 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop @@ -92,47 +92,47 @@ (if $skiplast (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -155,67 +155,67 @@ (block $EVAL_return (loop $TCO_loop - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res 0) + (local.set $res 0) (br $EVAL_return))) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) ;; APPLY_LIST (if ($EMPTY_Q $ast) (then - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) (br $EVAL_return))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $prev_env $env) ;; save env for later release - (set_local $env ($ENV_NEW $env)) + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) @@ -224,90 +224,90 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then ;; EVAL the rest through second to last - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (set_local $ast ($LAST $ast)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) (then - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) (then - (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) ;; if we have already been here via TCO, release previous ast (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL))) + (local.set $res ($INC_REF (global.get $NIL))) (br $EVAL_return)) (else - (set_local $ast ($MAL_GET_A3 $ast))))) + (local.set $ast ($MAL_GET_A3 $ast))))) (else ($RELEASE $res) - (set_local $ast ($MAL_GET_A2 $ast)))))) + (local.set $ast ($MAL_GET_A2 $ast)))))) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($MALFUNC $a2 $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) (br $EVAL_return)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env 0)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res $f_args) + (local.set $res $f_args) (br $EVAL_return))) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then (if (i32.eq ($VAL0 $f) 0) ;; eval (then - (set_local $res ($EVAL ($MEM_VAL1_ptr $args) - (get_global $repl_env)))) + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) (else - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) ;; release f/args ($RELEASE $f_args) (br $EVAL_return)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; release previous environment if not the current EVAL env @@ -316,17 +316,17 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) ;; claim the AST before releasing the list containing it - (set_local $ast ($MEM_VAL0_ptr $f)) + (local.set $ast ($MEM_VAL0_ptr $f)) (drop ($INC_REF $ast)) ;; if we have already been here via TCO, release previous ;; ast ;; PEND_A_LV (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) ;; release f/args ($RELEASE $f_args) @@ -334,7 +334,7 @@ (br $TCO_loop)) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args) (br $EVAL_return))))))))))))))))))) @@ -357,10 +357,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -371,11 +371,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -391,14 +391,14 @@ ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -412,31 +412,31 @@ ;; Command line arguments - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) ;; push MAP_LOP stack ;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) - (set_local $i 2) + (local.set $i 2) (block $done (loop $loop (br_if $done (i32.ge_u $i $argc)) - (set_local $val2 ($STRING (get_global $STRING_T) + (local.set $val2 ($STRING (global.get $STRING_T) (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE - (get_global $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -448,12 +448,12 @@ (if (i32.gt_u $argc 1) (then (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (get_global $STRING_T) + "*FILE*" ($STRING (global.get $STRING_T) (i32.load (i32.add $argv 4))))) ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (get_global $error_type) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + ($printf_1 "Error: %s\n" (global.get $error_str)) (return 1)) (else (return 0))))) @@ -463,18 +463,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step8_macros.wam b/wasm/step8_macros.wam index 95d0642d8b..ff042d065e 100644 --- a/wasm/step8_macros.wam +++ b/wasm/step8_macros.wam @@ -10,8 +10,8 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) (LET $type ($TYPE $ast)) - (AND (OR (i32.eq $type (get_global $LIST_T)) - (i32.eq $type (get_global $VECTOR_T))) + (AND (OR (i32.eq $type (global.get $LIST_T)) + (i32.eq $type (global.get $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) @@ -19,38 +19,38 @@ (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then - (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) ;; ['quote ast] - (set_local $res ($LIST2 $sym $ast)) + (local.set $res ($LIST2 $sym $ast)) ($RELEASE $sym)) (else - (set_local $res ($MEM_VAL1_ptr $ast)) - (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (local.set $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (global.get $SYMBOL_T)) (i32.eqz ($strcmp "unquote" ($to_String $res)))) (then ;; ast[1] - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) (else (if (AND ($is_pair $res) (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) - (get_global $SYMBOL_T)) + (global.get $SYMBOL_T)) (i32.eqz ($strcmp "splice-unquote" ($to_String ($MEM_VAL1_ptr $res))))) (then ;; ['concat, ast[0][1], quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) - (set_local $second + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $second ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list take ownership ($RELEASE $third) ($RELEASE $sym)) (else ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) - (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list takes ownership ($RELEASE $third) ($RELEASE $second) @@ -65,35 +65,35 @@ (local $mac_env i64) (LET $ast $orig_ast $mac 0) - (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init + (global.set $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init (block $done (loop $loop (br_if $done - (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list (i32.eqz ($VAL0 $ast)) ;; non-empty (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (get_global $SYMBOL_T)))) - (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) - (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) - (br_if $done (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (global.get $SYMBOL_T)))) + (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) + (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env (i32.ne ($TYPE $mac) ;; a macro - (get_global $MACRO_T)))) + (global.get $MACRO_T)))) - (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) ;; PEND_A_LV ;; if ast is not the first ast that was passed in, then add it ;; to the pending release list. (if (i32.ne $ast $orig_ast) (then - (set_global $mac_stack_top - (i32.add (get_global $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + (global.set $mac_stack_top + (i32.add (global.get $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 1024) ;; 256 * 4 ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add - (get_global $mac_stack) - (i32.mul (get_global $mac_stack_top) 4)) + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)) $ast))) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) (br $loop) ) @@ -105,8 +105,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -116,16 +116,16 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop @@ -135,47 +135,47 @@ (if $skiplast (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -191,7 +191,7 @@ (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) (LET $ast $orig_ast $env $orig_env - $orig_mac_stack_top (get_global $mac_stack_top) + $orig_mac_stack_top (global.get $mac_stack_top) $prev_ast 0 $prev_env 0 $res 0 $el 0 $ftype 0 $f_args 0 $f 0 $args 0 $a0 0 $a0sym 0 $a1 0 $a2 0) @@ -199,75 +199,75 @@ (block $EVAL_return (loop $TCO_loop - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res 0) + (local.set $res 0) (br $EVAL_return))) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) ;; APPLY_LIST - (set_local $ast ($MACROEXPAND $ast $env)) + (local.set $ast ($MACROEXPAND $ast $env)) ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) (if ($EMPTY_Q $ast) (then - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) (br $EVAL_return))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $prev_env $env) ;; save env for later release - (set_local $env ($ENV_NEW $env)) + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) @@ -276,107 +276,107 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then ;; EVAL the rest through second to last - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (set_local $ast ($LAST $ast)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) (then - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) (then - (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) ;; if we have already been here via TCO, release previous ast (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - ($SET_TYPE $res (get_global $MACRO_T)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + ($SET_TYPE $res (global.get $MACRO_T)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) (then ;; since we are returning it unevaluated, inc the ref cnt - (set_local $res ($INC_REF ($MACROEXPAND + (local.set $res ($INC_REF ($MACROEXPAND ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) $env)))) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL))) + (local.set $res ($INC_REF (global.get $NIL))) (br $EVAL_return)) (else - (set_local $ast ($MAL_GET_A3 $ast))))) + (local.set $ast ($MAL_GET_A3 $ast))))) (else ($RELEASE $res) - (set_local $ast ($MAL_GET_A2 $ast)))))) + (local.set $ast ($MAL_GET_A2 $ast)))))) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($MALFUNC $a2 $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) (br $EVAL_return)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env 0)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res $f_args) + (local.set $res $f_args) (br $EVAL_return))) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then (if (i32.eq ($VAL0 $f) 0) ;; eval (then - (set_local $res ($EVAL ($MEM_VAL1_ptr $args) - (get_global $repl_env)))) + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) (else - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) ;; release f/args ($RELEASE $f_args) (br $EVAL_return)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; release previous environment if not the current EVAL env @@ -385,17 +385,17 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) ;; claim the AST before releasing the list containing it - (set_local $ast ($MEM_VAL0_ptr $f)) + (local.set $ast ($MEM_VAL0_ptr $f)) (drop ($INC_REF $ast)) ;; if we have already been here via TCO, release previous ;; ast ;; PEND_A_LV (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) ;; release f/args ($RELEASE $f_args) @@ -403,7 +403,7 @@ (br $TCO_loop)) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args) (br $EVAL_return))))))))))))))))))))))) @@ -418,12 +418,12 @@ ;; TODO: needs to happen here so self-hosting doesn't leak (block $done (loop $loop - (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) + (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add - (get_global $mac_stack) - (i32.mul (get_global $mac_stack_top) 4)))) - (set_global $mac_stack_top - (i32.sub (get_global $mac_stack_top) 1)) + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)))) + (global.set $mac_stack_top + (i32.sub (global.get $mac_stack_top) 1)) (br $loop) ) ) @@ -440,10 +440,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -454,11 +454,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -474,14 +474,14 @@ ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -497,31 +497,31 @@ ;; Command line arguments - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) ;; push MAP_LOP stack ;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) - (set_local $i 2) + (local.set $i 2) (block $done (loop $loop (br_if $done (i32.ge_u $i $argc)) - (set_local $val2 ($STRING (get_global $STRING_T) + (local.set $val2 ($STRING (global.get $STRING_T) (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE - (get_global $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -533,12 +533,12 @@ (if (i32.gt_u $argc 1) (then (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (get_global $STRING_T) + "*FILE*" ($STRING (global.get $STRING_T) (i32.load (i32.add $argv 4))))) ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (get_global $error_type) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + ($printf_1 "Error: %s\n" (global.get $error_str)) (return 1)) (else (return 0))))) @@ -548,18 +548,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/step9_try.wam b/wasm/step9_try.wam index 312314b380..31567f1975 100644 --- a/wasm/step9_try.wam +++ b/wasm/step9_try.wam @@ -10,8 +10,8 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) (LET $type ($TYPE $ast)) - (AND (OR (i32.eq $type (get_global $LIST_T)) - (i32.eq $type (get_global $VECTOR_T))) + (AND (OR (i32.eq $type (global.get $LIST_T)) + (i32.eq $type (global.get $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) @@ -19,38 +19,38 @@ (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then - (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) ;; ['quote ast] - (set_local $res ($LIST2 $sym $ast)) + (local.set $res ($LIST2 $sym $ast)) ($RELEASE $sym)) (else - (set_local $res ($MEM_VAL1_ptr $ast)) - (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (local.set $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (global.get $SYMBOL_T)) (i32.eqz ($strcmp "unquote" ($to_String $res)))) (then ;; ast[1] - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) (else (if (AND ($is_pair $res) (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) - (get_global $SYMBOL_T)) + (global.get $SYMBOL_T)) (i32.eqz ($strcmp "splice-unquote" ($to_String ($MEM_VAL1_ptr $res))))) (then ;; ['concat, ast[0][1], quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) - (set_local $second + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $second ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list take ownership ($RELEASE $third) ($RELEASE $sym)) (else ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) - (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list takes ownership ($RELEASE $third) ($RELEASE $second) @@ -65,35 +65,35 @@ (local $mac_env i64) (LET $ast $orig_ast $mac 0) - (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init + (global.set $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init (block $done (loop $loop (br_if $done - (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list (i32.eqz ($VAL0 $ast)) ;; non-empty (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (get_global $SYMBOL_T)))) - (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) - (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) - (br_if $done (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (global.get $SYMBOL_T)))) + (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) + (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env (i32.ne ($TYPE $mac) ;; a macro - (get_global $MACRO_T)))) + (global.get $MACRO_T)))) - (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) ;; PEND_A_LV ;; if ast is not the first ast that was passed in, then add it ;; to the pending release list. (if (i32.ne $ast $orig_ast) (then - (set_global $mac_stack_top - (i32.add (get_global $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + (global.set $mac_stack_top + (i32.add (global.get $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 1024) ;; 256 * 4 ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add - (get_global $mac_stack) - (i32.mul (get_global $mac_stack_top) 4)) + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)) $ast))) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) (br $loop) ) @@ -105,8 +105,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -116,16 +116,16 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop @@ -135,47 +135,47 @@ (if $skiplast (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -191,7 +191,7 @@ (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) (LET $ast $orig_ast $env $orig_env - $orig_mac_stack_top (get_global $mac_stack_top) + $orig_mac_stack_top (global.get $mac_stack_top) $prev_ast 0 $prev_env 0 $res 0 $el 0 $ftype 0 $f_args 0 $f 0 $args 0 $a0 0 $a0sym 0 $a1 0 $a2 0 @@ -200,75 +200,75 @@ (block $EVAL_return (loop $TCO_loop - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res 0) + (local.set $res 0) (br $EVAL_return))) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) ;; APPLY_LIST - (set_local $ast ($MACROEXPAND $ast $env)) + (local.set $ast ($MACROEXPAND $ast $env)) ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) (if ($EMPTY_Q $ast) (then - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) (br $EVAL_return))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $prev_env $env) ;; save env for later release - (set_local $env ($ENV_NEW $env)) + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) @@ -277,54 +277,54 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then ;; EVAL the rest through second to last - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (set_local $ast ($LAST $ast)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) (then - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) (then - (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) ;; if we have already been here via TCO, release previous ast (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - ($SET_TYPE $res (get_global $MACRO_T)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + ($SET_TYPE $res (global.get $MACRO_T)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) (then ;; since we are returning it unevaluated, inc the ref cnt - (set_local $res ($INC_REF ($MACROEXPAND + (local.set $res ($INC_REF ($MACROEXPAND ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) $env)))) (else (if (i32.eqz ($strcmp "try*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) ;; if there is no error, return - (br_if $EVAL_return (i32.eqz (get_global $error_type))) + (br_if $EVAL_return (i32.eqz (global.get $error_type))) ;; if there is an error and res is set, we need to free it ($RELEASE $res) ;; if there is no catch block then return @@ -332,98 +332,98 @@ (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create environment for the catch block eval - (set_local $env ($ENV_NEW $env)) + (local.set $env ($ENV_NEW $env)) ;; set a1 and a2 from the catch block - (set_local $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) - (set_local $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) + (local.set $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) + (local.set $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) ;; create object for string errors - (if (i32.eq (get_global $error_type) 1) + (if (i32.eq (global.get $error_type) 1) (then - (set_local $err ($STRING (get_global $STRING_T) - (get_global $error_str)))) + (local.set $err ($STRING (global.get $STRING_T) + (global.get $error_str)))) (else - (set_local $err (get_global $error_val)))) + (local.set $err (global.get $error_val)))) ;; bind the catch symbol to the error object (drop ($ENV_SET $env $a1 $err)) ;; release our use, env took ownership ($RELEASE $err) ;; unset error for catch eval - (set_global $error_type 0) - (i32.store (get_global $error_str) (CHR "\x00")) + (global.set $error_type 0) + (i32.store (global.get $error_str) (CHR "\x00")) ;; release previous environment if not the current EVAL env (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL))) + (local.set $res ($INC_REF (global.get $NIL))) (br $EVAL_return)) (else - (set_local $ast ($MAL_GET_A3 $ast))))) + (local.set $ast ($MAL_GET_A3 $ast))))) (else ($RELEASE $res) - (set_local $ast ($MAL_GET_A2 $ast)))))) + (local.set $ast ($MAL_GET_A2 $ast)))))) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($MALFUNC $a2 $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) (br $EVAL_return)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env 0)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res $f_args) + (local.set $res $f_args) (br $EVAL_return))) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($MEM_VAL1_ptr $f_args)) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then (if (i32.eq ($VAL0 $f) 0) ;; eval (then - (set_local $res ($EVAL ($MEM_VAL1_ptr $args) - (get_global $repl_env)))) + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) (else - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) ;; release f/args ($RELEASE $f_args) (br $EVAL_return)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; release previous environment if not the current EVAL env @@ -432,17 +432,17 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) ;; claim the AST before releasing the list containing it - (set_local $ast ($MEM_VAL0_ptr $f)) + (local.set $ast ($MEM_VAL0_ptr $f)) (drop ($INC_REF $ast)) ;; if we have already been here via TCO, release previous ;; ast ;; PEND_A_LV (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) ;; release f/args ($RELEASE $f_args) @@ -450,7 +450,7 @@ (br $TCO_loop)) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args) (br $EVAL_return))))))))))))))))))))))))) @@ -465,12 +465,12 @@ ;; TODO: needs to happen here so self-hosting doesn't leak (block $done (loop $loop - (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) + (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add - (get_global $mac_stack) - (i32.mul (get_global $mac_stack_top) 4)))) - (set_global $mac_stack_top - (i32.sub (get_global $mac_stack_top) 1)) + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)))) + (global.set $mac_stack_top + (i32.sub (global.get $mac_stack_top) 1)) (br $loop) ) ) @@ -487,10 +487,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -501,11 +501,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -521,14 +521,14 @@ ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -544,31 +544,31 @@ ;; Command line arguments - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) ;; push MAP_LOP stack ;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) - (set_local $i 2) + (local.set $i 2) (block $done (loop $loop (br_if $done (i32.ge_u $i $argc)) - (set_local $val2 ($STRING (get_global $STRING_T) + (local.set $val2 ($STRING (global.get $STRING_T) (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE - (get_global $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -580,12 +580,12 @@ (if (i32.gt_u $argc 1) (then (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (get_global $STRING_T) + "*FILE*" ($STRING (global.get $STRING_T) (i32.load (i32.add $argv 4))))) ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (get_global $error_type) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + ($printf_1 "Error: %s\n" (global.get $error_str)) (return 1)) (else (return 0))))) @@ -595,18 +595,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/stepA_mal.wam b/wasm/stepA_mal.wam index f1bed3d709..343762006d 100644 --- a/wasm/stepA_mal.wam +++ b/wasm/stepA_mal.wam @@ -10,8 +10,8 @@ ;; EVAL (func $is_pair (param $ast i32) (result i32) (LET $type ($TYPE $ast)) - (AND (OR (i32.eq $type (get_global $LIST_T)) - (i32.eq $type (get_global $VECTOR_T))) + (AND (OR (i32.eq $type (global.get $LIST_T)) + (i32.eq $type (global.get $VECTOR_T))) (i32.ne ($VAL0 $ast) 0)) ) @@ -19,38 +19,38 @@ (LET $res 0 $sym 0 $second 0 $third 0) (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE (then - (set_local $sym ($STRING (get_global $SYMBOL_T) "quote")) + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) ;; ['quote ast] - (set_local $res ($LIST2 $sym $ast)) + (local.set $res ($LIST2 $sym $ast)) ($RELEASE $sym)) (else - (set_local $res ($MEM_VAL1_ptr $ast)) - (if (AND (i32.eq ($TYPE $res) (get_global $SYMBOL_T)) + (local.set $res ($MEM_VAL1_ptr $ast)) + (if (AND (i32.eq ($TYPE $res) (global.get $SYMBOL_T)) (i32.eqz ($strcmp "unquote" ($to_String $res)))) (then ;; ast[1] - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))) (else (if (AND ($is_pair $res) (i32.eq ($TYPE ($MEM_VAL1_ptr $res)) - (get_global $SYMBOL_T)) + (global.get $SYMBOL_T)) (i32.eqz ($strcmp "splice-unquote" ($to_String ($MEM_VAL1_ptr $res))))) (then ;; ['concat, ast[0][1], quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "concat")) - (set_local $second + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $second ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast)))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list take ownership ($RELEASE $third) ($RELEASE $sym)) (else ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] - (set_local $sym ($STRING (get_global $SYMBOL_T) "cons")) - (set_local $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) - (set_local $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) - (set_local $res ($LIST3 $sym $second $third)) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast))) + (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast))) + (local.set $res ($LIST3 $sym $second $third)) ;; release inner quasiquoted since outer list takes ownership ($RELEASE $third) ($RELEASE $second) @@ -65,35 +65,35 @@ (local $mac_env i64) (LET $ast $orig_ast $mac 0) - (set_global $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init + (global.set $mac_stack (STATIC_ARRAY 1024)) ;; 256 * 4, TODO: move to init (block $done (loop $loop (br_if $done - (OR (i32.ne ($TYPE $ast) (get_global $LIST_T)) ;; a list + (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list (i32.eqz ($VAL0 $ast)) ;; non-empty (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (get_global $SYMBOL_T)))) - (set_local $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) - (set_local $mac (i32.wrap/i64 (i64.shr_u $mac_env (i64.const 32)))) - (br_if $done (OR (i32.eqz (i32.wrap/i64 $mac_env)) ;; defined in env + (global.get $SYMBOL_T)))) + (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) + (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env (i32.ne ($TYPE $mac) ;; a macro - (get_global $MACRO_T)))) + (global.get $MACRO_T)))) - (set_local $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) ;; PEND_A_LV ;; if ast is not the first ast that was passed in, then add it ;; to the pending release list. (if (i32.ne $ast $orig_ast) (then - (set_global $mac_stack_top - (i32.add (get_global $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul (get_global $mac_stack_top) 4) 1024) ;; 256 * 4 + (global.set $mac_stack_top + (i32.add (global.get $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 1024) ;; 256 * 4 ($fatal 7 "Exhausted mac_stack!\n")) (i32.store (i32.add - (get_global $mac_stack) - (i32.mul (get_global $mac_stack_top) 4)) + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)) $ast))) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) (br $loop) ) @@ -105,8 +105,8 @@ (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 $ret 0 $empty 0 $current 0) - (if (get_global $error_type) (return 0)) - (set_local $type ($TYPE $ast)) + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) @@ -116,16 +116,16 @@ (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) ;; symbol ;; found/res returned as hi 32/lo 32 of i64 - (set_local $res ($ENV_GET $env $ast)) + (local.set $res ($ENV_GET $env $ast)) (br $done)) ;; list, vector, hashmap ;; MAP_LOOP_START - (set_local $res ($MAP_LOOP_START $type)) + (local.set $res ($MAP_LOOP_START $type)) ;; push MAP_LOOP stack ;;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) (block $done (loop $loop @@ -135,47 +135,47 @@ (if $skiplast (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) (else - (set_local $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (set_local $val2 $res) + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) ;; if error, release the unattached element - (if (get_global $error_type) + (if (global.get $error_type) (then ($RELEASE $res) - (set_local $res 0) + (local.set $res 0) (br $done))) ;; for hash-maps, copy the key (inc ref since we are going ;; to release it below) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) (then - (set_local $val3 $val2) - (set_local $val2 ($MEM_VAL1_ptr $ast)) + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) (drop ($INC_REF $val2)))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $ast ($MEM_VAL0_ptr $ast)) + (local.set $ast ($MEM_VAL0_ptr $ast)) (br $loop) ) ) ;; MAP_LOOP_DONE - (set_local $res $ret) + (local.set $res $ret) ;; EVAL_AST_RETURN: nothing to do (br $done)) ;; default - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) ) $res @@ -191,7 +191,7 @@ (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) (LET $ast $orig_ast $env $orig_env - $orig_mac_stack_top (get_global $mac_stack_top) + $orig_mac_stack_top (global.get $mac_stack_top) $prev_ast 0 $prev_env 0 $res 0 $el 0 $ftype 0 $f_args 0 $f 0 $args 0 $a0 0 $a0sym 0 $a1 0 $a2 0 @@ -200,75 +200,75 @@ (block $EVAL_return (loop $TCO_loop - (set_local $f_args 0) - (set_local $f 0) - (set_local $args 0) + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res 0) + (local.set $res 0) (br $EVAL_return))) ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) ;; APPLY_LIST - (set_local $ast ($MACROEXPAND $ast $env)) + (local.set $ast ($MACROEXPAND $ast $env)) ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) - (if (i32.ne ($TYPE $ast) (get_global $LIST_T)) + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) (then - (set_local $res ($EVAL_AST $ast $env 0)) + (local.set $res ($EVAL_AST $ast $env 0)) (br $EVAL_return))) (if ($EMPTY_Q $ast) (then - (set_local $res ($INC_REF $ast)) + (local.set $res ($INC_REF $ast)) (br $EVAL_return))) - (set_local $a0 ($MEM_VAL1_ptr $ast)) - (set_local $a0sym "") - (if (i32.eq ($TYPE $a0) (get_global $SYMBOL_T)) - (set_local $a0sym ($to_String $a0))) + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) (if (i32.eqz ($strcmp "def!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "let*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) ;; create new environment with outer as current environment - (set_local $prev_env $env) ;; save env for later release - (set_local $env ($ENV_NEW $env)) + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) (block $done (loop $loop (br_if $done (i32.eqz ($VAL0 $a1))) ;; eval current A1 odd element - (set_local $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - (br_if $done (get_global $error_type)) + (br_if $done (global.get $error_type)) ;; set key/value in the let environment - (set_local $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) ;; release our use, ENV_SET took ownership ($RELEASE $res) ;; skip to the next pair of a1 elements - (set_local $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) (br $loop) ) ) @@ -277,54 +277,54 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "do" $a0sym)) (then ;; EVAL the rest through second to last - (set_local $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (set_local $ast ($LAST $ast)) + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) ($RELEASE $ast) ;; we already own it via ast ($RELEASE $el) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "quote" $a0sym)) (then - (set_local $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) (then - (set_local $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) ;; if we have already been here via TCO, release previous ast (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($EVAL $a2 $env)) - ($SET_TYPE $res (get_global $MACRO_T)) - (br_if $EVAL_return (get_global $error_type)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + ($SET_TYPE $res (global.get $MACRO_T)) + (br_if $EVAL_return (global.get $error_type)) ;; set a1 in env to a2 - (set_local $res ($ENV_SET $env $a1 $res)) + (local.set $res ($ENV_SET $env $a1 $res)) (br $EVAL_return)) (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) (then ;; since we are returning it unevaluated, inc the ref cnt - (set_local $res ($INC_REF ($MACROEXPAND + (local.set $res ($INC_REF ($MACROEXPAND ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) $env)))) (else (if (i32.eqz ($strcmp "try*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) ;; if there is no error, return - (br_if $EVAL_return (i32.eqz (get_global $error_type))) + (br_if $EVAL_return (i32.eqz (global.get $error_type))) ;; if there is an error and res is set, we need to free it ($RELEASE $res) ;; if there is no catch block then return @@ -332,98 +332,98 @@ (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create environment for the catch block eval - (set_local $env ($ENV_NEW $env)) + (local.set $env ($ENV_NEW $env)) ;; set a1 and a2 from the catch block - (set_local $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) - (set_local $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) + (local.set $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) + (local.set $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) ;; create object for string errors - (if (i32.eq (get_global $error_type) 1) + (if (i32.eq (global.get $error_type) 1) (then - (set_local $err ($STRING (get_global $STRING_T) - (get_global $error_str)))) + (local.set $err ($STRING (global.get $STRING_T) + (global.get $error_str)))) (else - (set_local $err (get_global $error_val)))) + (local.set $err (global.get $error_val)))) ;; bind the catch symbol to the error object (drop ($ENV_SET $env $a1 $err)) ;; release our use, env took ownership ($RELEASE $err) ;; unset error for catch eval - (set_global $error_type 0) - (i32.store (get_global $error_str) (CHR "\x00")) + (global.set $error_type 0) + (i32.store (global.get $error_str) (CHR "\x00")) ;; release previous environment if not the current EVAL env (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) - (set_local $ast $a2) + (local.set $ast $a2) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "if" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $res ($EVAL $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) - (if (get_global $error_type) + (if (global.get $error_type) (then (nop)) - (else (if (OR (i32.eq $res (get_global $NIL)) - (i32.eq $res (get_global $FALSE))) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) (then ($RELEASE $res) ;; if no false case (A3), return nil (if (i32.lt_u ($COUNT $ast) 4) (then - (set_local $res ($INC_REF (get_global $NIL))) + (local.set $res ($INC_REF (global.get $NIL))) (br $EVAL_return)) (else - (set_local $ast ($MAL_GET_A3 $ast))))) + (local.set $ast ($MAL_GET_A3 $ast))))) (else ($RELEASE $res) - (set_local $ast ($MAL_GET_A2 $ast)))))) + (local.set $ast ($MAL_GET_A2 $ast)))))) (br $TCO_loop)) (else (if (i32.eqz ($strcmp "fn*" $a0sym)) (then - (set_local $a1 ($MAL_GET_A1 $ast)) - (set_local $a2 ($MAL_GET_A2 $ast)) - (set_local $res ($MALFUNC $a2 $a1 $env)) + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) (br $EVAL_return)) (else ;; EVAL_INVOKE - (set_local $res ($EVAL_AST $ast $env 0)) - (set_local $f_args $res) + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) ;; if error, return f/args for release by caller - (if (get_global $error_type) + (if (global.get $error_type) (then - (set_local $res $f_args) + (local.set $res $f_args) (br $EVAL_return))) - (set_local $args ($MEM_VAL0_ptr $f_args)) ;; rest - (set_local $f ($DEREF_META ($MEM_VAL1_ptr $f_args))) ;; value + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($DEREF_META ($MEM_VAL1_ptr $f_args))) ;; value - (set_local $ftype ($TYPE $f)) - (if (i32.eq $ftype (get_global $FUNCTION_T)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) (then (if (i32.eq ($VAL0 $f) 0) ;; eval (then - (set_local $res ($EVAL ($MEM_VAL1_ptr $args) - (get_global $repl_env)))) + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) (else - (set_local $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) ;; release f/args ($RELEASE $f_args) (br $EVAL_return)) - (else (if (i32.eq $ftype (get_global $MALFUNC_T)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) (then ;; save the current environment for release - (set_local $prev_env $env) + (local.set $prev_env $env) ;; create new environment using env and params stored in function - (set_local $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) ($MEM_VAL1_ptr $f) $args)) ;; release previous environment if not the current EVAL env @@ -432,17 +432,17 @@ (if (i32.ne $prev_env $orig_env) (then ($RELEASE $prev_env) - (set_local $prev_env 0))) + (local.set $prev_env 0))) ;; claim the AST before releasing the list containing it - (set_local $ast ($MEM_VAL0_ptr $f)) + (local.set $ast ($MEM_VAL0_ptr $f)) (drop ($INC_REF $ast)) ;; if we have already been here via TCO, release previous ;; ast ;; PEND_A_LV (if $prev_ast ($RELEASE $prev_ast)) - (set_local $prev_ast $ast) + (local.set $prev_ast $ast) ;; release f/args ($RELEASE $f_args) @@ -450,7 +450,7 @@ (br $TCO_loop)) (else ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (set_local $res 0) + (local.set $res 0) ($RELEASE $f_args) (br $EVAL_return))))))))))))))))))))))))) @@ -465,12 +465,12 @@ ;; TODO: needs to happen here so self-hosting doesn't leak (block $done (loop $loop - (br_if $done (i32.le_s (get_global $mac_stack_top) $orig_mac_stack_top)) + (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) ($RELEASE (i32.load (i32.add - (get_global $mac_stack) - (i32.mul (get_global $mac_stack_top) 4)))) - (set_global $mac_stack_top - (i32.sub (get_global $mac_stack_top) 1)) + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)))) + (global.set $mac_stack_top + (i32.sub (global.get $mac_stack_top) 1)) (br $loop) ) ) @@ -487,10 +487,10 @@ (func $RE (param $line i32 $env i32) (result i32) (LET $mv1 0 $res 0) (block $done - (set_local $mv1 ($READ $line)) - (br_if $done (get_global $error_type)) + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) - (set_local $res ($EVAL $mv1 $env)) + (local.set $res ($EVAL $mv1 $env)) ) ;; release memory from MAL_READ @@ -501,11 +501,11 @@ (func $REP (param $line i32 $env i32) (result i32) (LET $mv2 0 $ms 0) (block $done - (set_local $mv2 ($RE $line $env)) - (br_if $done (get_global $error_type)) + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) ;; ($PR_MEMORY -1 -1) - (set_local $ms ($PRINT $mv2)) + (local.set $ms ($PRINT $mv2)) ) ;; release memory from RE @@ -521,14 +521,14 @@ ;; DEBUG ;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (get_global $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (get_global $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (get_global $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (get_global $mem)) -;; ($printf_1 "string_mem: %d\n" (get_global $string_mem)) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - (set_global $repl_env ($ENV_NEW (get_global $NIL))) - (set_local $repl_env (get_global $repl_env)) + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) ;; core.EXT: defined in wasm ($add_core_ns $repl_env) @@ -546,31 +546,31 @@ ($RELEASE ($RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (c (gensym)) `(let* (~c ~(first xs)) (if ~c ~c (or ~@(rest xs)))))))))" $repl_env)) ;; Command line arguments - (set_local $res ($MAP_LOOP_START (get_global $LIST_T))) + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) ;; push MAP_LOP stack ;; empty = current = ret = res - (set_local $ret $res) - (set_local $current $res) - (set_local $empty $res) + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) - (set_local $i 2) + (local.set $i 2) (block $done (loop $loop (br_if $done (i32.ge_u $i $argc)) - (set_local $val2 ($STRING (get_global $STRING_T) + (local.set $val2 ($STRING (global.get $STRING_T) (i32.load (i32.add $argv (i32.mul $i 4))))) ;; MAP_LOOP_UPDATE - (set_local $res ($MAP_LOOP_UPDATE - (get_global $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (get_global $EMPTY_HASHMAP)) + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) ;; if first element, set return to new element - (set_local $ret $res)) + (local.set $ret $res)) ;; update current to point to new element - (set_local $current $res) + (local.set $current $res) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -582,12 +582,12 @@ (if (i32.gt_u $argc 1) (then (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (get_global $STRING_T) + "*FILE*" ($STRING (global.get $STRING_T) (i32.load (i32.add $argv 4))))) ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (get_global $error_type) + (if (global.get $error_type) (then - ($printf_1 "Error: %s\n" (get_global $error_str)) + ($printf_1 "Error: %s\n" (global.get $error_str)) (return 1)) (else (return 0))))) @@ -599,18 +599,18 @@ (loop $repl_loop (br_if $repl_done (i32.eqz ($readline "user> " $line))) (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (set_local $res ($REP $line $repl_env)) - (if (get_global $error_type) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) (then - (if (i32.eq 2 (get_global $error_type)) + (if (i32.eq 2 (global.get $error_type)) (then - (set_local $ms ($pr_str (get_global $error_val) 1)) + (local.set $ms ($pr_str (global.get $error_val) 1)) ($printf_1 "Error: %s\n" ($to_String $ms)) ($RELEASE $ms) - ($RELEASE (get_global $error_val))) + ($RELEASE (global.get $error_val))) (else - ($printf_1 "Error: %s\n" (get_global $error_str)))) - (set_global $error_type 0)) + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) (else ($printf_1 "%s\n" ($to_String $res)))) ($RELEASE $res) diff --git a/wasm/string.wam b/wasm/string.wam index 593ea1c1e0..25b6ed094d 100644 --- a/wasm/string.wam +++ b/wasm/string.wam @@ -9,7 +9,7 @@ (loop $copy (i32.store8 (i32.add $idx $dst) (i32.load8_u (i32.add $idx $src))) - (set_local $idx (i32.add 1 $idx)) + (local.set $idx (i32.add 1 $idx)) (br_if $copy (i32.lt_u $idx $len)) ) ) @@ -19,7 +19,7 @@ (loop $count (if (i32.ne 0 (i32.load8_u $cur)) (then - (set_local $cur (i32.add $cur 1)) + (local.set $cur (i32.add $cur 1)) (br $count))) ) (i32.sub $cur $str) @@ -34,7 +34,7 @@ (if (i32.eq $needle_len 0) (return $haystack)) - (set_local $i 0) + (local.set $i 0) (block $done (loop $loop (if (i32.gt_s $i (i32.sub $len $needle_len)) (br $done)) @@ -43,8 +43,8 @@ (i32.load8_u $needle)) (i32.eqz ($strncmp $haystack $needle $needle_len))) (return $haystack)) - (set_local $haystack (i32.add $haystack 1)) - (set_local $i (i32.add $i 1)) + (local.set $haystack (i32.add $haystack 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -58,17 +58,17 @@ $ch 0) (block $done (loop $loop - (set_local $ch (i32.load8_u (i32.add $str $i))) + (local.set $ch (i32.load8_u (i32.add $str $i))) (if (AND (i32.ne $ch (CHR "-")) (OR (i32.lt_u $ch (CHR "0")) (i32.gt_u $ch (CHR "9")))) (br $done)) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (if (i32.eq $ch (CHR "-")) (then - (set_local $neg 1)) + (local.set $neg 1)) (else - (set_local $acc (i32.add (i32.mul $acc 10) + (local.set $acc (i32.add (i32.mul $acc 10) (i32.sub $ch (CHR "0")))))) (br $loop) ) @@ -85,8 +85,8 @@ (br $done)) (if (i32.ne (i32.load8_u $s1) (i32.load8_u $s2)) (br $done)) - (set_local $s1 (i32.add $s1 1)) - (set_local $s2 (i32.add $s2 1)) + (local.set $s1 (i32.add $s1 1)) + (local.set $s2 (i32.add $s2 1)) (br $loop) ) ) @@ -107,7 +107,7 @@ (if (i32.eqz (i32.load8_u (i32.add $i $s1))) (br $done)) (if (i32.ne (i32.load8_u (i32.add $i $s1)) (i32.load8_u (i32.add $i $s2))) (br $done)) - (set_local $i (i32.add $i 1)) + (local.set $i (i32.add $i 1)) (br $loop) ) ) @@ -140,26 +140,26 @@ (if (i32.eqz $grass) (then ;; check that we aren't expanding in place - (set_local $s 0) + (local.set $s 0) (block $done (loop $loop (if (i32.ge_u $s 3) (br $done)) - (set_local $needle (if (result i32) (i32.eq $s 0) $needle0 + (local.set $needle (if (result i32) (i32.eq $s 0) $needle0 (if (result i32) (i32.eq $s 1) $needle1 $needle2))) - (set_local $replace (if (result i32) (i32.eq $s 0) $replace0 + (local.set $replace (if (result i32) (i32.eq $s 0) $replace0 (if (result i32) (i32.eq $s 1) $replace1 $replace2))) - (set_local $needle_len ($strlen $needle)) - (set_local $replace_len ($strlen $replace)) + (local.set $needle_len ($strlen $needle)) + (local.set $replace_len ($strlen $replace)) (if (i32.gt_u $replace_len $needle_len) ($fatal 7 "REPLACE: invalid expanding in-place call\n")) - (set_local $s (i32.add $s 1)) + (local.set $s (i32.add $s 1)) (br $loop) ) ) - (set_local $grass $haystack) - (set_local $dst_str $grass))) + (local.set $grass $haystack) + (local.set $dst_str $grass))) (block $done1 (loop $loop1 @@ -167,45 +167,45 @@ (br $done1)) ;; Find the earliest match - (set_local $found 0) - (set_local $s 0) + (local.set $found 0) + (local.set $s 0) (block $done2 (loop $loop2 (if (i32.ge_u $s 3) (br $done2)) - (set_local $needle (if (result i32) (i32.eq $s 0) $needle0 + (local.set $needle (if (result i32) (i32.eq $s 0) $needle0 (if (result i32) (i32.eq $s 1) $needle1 $needle2))) - (set_local $replace (if (result i32) (i32.eq $s 0) $replace0 + (local.set $replace (if (result i32) (i32.eq $s 0) $replace0 (if (result i32) (i32.eq $s 1) $replace1 $replace2))) - (set_local $s (i32.add $s 1)) - (set_local $found_tmp ($strstr $src_str $needle)) + (local.set $s (i32.add $s 1)) + (local.set $found_tmp ($strstr $src_str $needle)) (if (i32.eqz $found_tmp) (br $loop2)) (if (OR (i32.eqz $found) (i32.lt_s $found_tmp $found)) (then - (set_local $found $found_tmp) - (set_local $needle_len_s ($strlen $needle)) - (set_local $replace_s $replace) - (set_local $replace_len_s ($strlen $replace)))) + (local.set $found $found_tmp) + (local.set $needle_len_s ($strlen $needle)) + (local.set $replace_s $replace) + (local.set $replace_len_s ($strlen $replace)))) (br $loop2) ) ) (if (i32.eqz $found) (br $done1)) ;; copy before the match ($memmove $dst_str $src_str (i32.add (i32.sub $found $src_str) 1)) - (set_local $dst_str (i32.add $dst_str (i32.sub $found $src_str))) + (local.set $dst_str (i32.add $dst_str (i32.sub $found $src_str))) ;; add the replace string ($memmove $dst_str $replace_s (i32.add $replace_len_s 1)) - (set_local $dst_str (i32.add $dst_str $replace_len_s)) + (local.set $dst_str (i32.add $dst_str $replace_len_s)) ;; Move to after the match - (set_local $src_str (i32.add $found $needle_len_s)) + (local.set $src_str (i32.add $found $needle_len_s)) (br $loop1) ) ) ;; Copy the left-over ($memmove $dst_str $src_str ($strlen $src_str)) - (set_local $dst_str (i32.add $dst_str ($strlen $src_str))) + (local.set $dst_str (i32.add $dst_str ($strlen $src_str))) (i32.store8 $dst_str (CHR "\x00")) (i32.sub $dst_str $grass) diff --git a/wasm/types.wam b/wasm/types.wam index a2d0cd36e3..280fc0eb7a 100644 --- a/wasm/types.wam +++ b/wasm/types.wam @@ -59,27 +59,27 @@ ) (func $TRUE_FALSE (param $val i32) (result i32) - ($INC_REF (if (result i32) $val (get_global $TRUE) (get_global $FALSE))) + ($INC_REF (if (result i32) $val (global.get $TRUE) (global.get $FALSE))) ) (func $THROW_STR_0 (param $fmt i32) - (drop ($sprintf_1 (get_global $error_str) $fmt "")) - (set_global $error_type 1) + (drop ($sprintf_1 (global.get $error_str) $fmt "")) + (global.set $error_type 1) ) (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) - (drop ($sprintf_1 (get_global $error_str) $fmt $v0)) - (set_global $error_type 1) + (drop ($sprintf_1 (global.get $error_str) $fmt $v0)) + (global.set $error_type 1) ) (func $EQUAL_Q (param $a i32 $b i32) (result i32) (LET $ta ($TYPE $a) $tb ($TYPE $b)) - (if (AND (OR (i32.eq $ta (get_global $LIST_T)) - (i32.eq $ta (get_global $VECTOR_T))) - (OR (i32.eq $tb (get_global $LIST_T)) - (i32.eq $tb (get_global $VECTOR_T)))) + (if (AND (OR (i32.eq $ta (global.get $LIST_T)) + (i32.eq $ta (global.get $VECTOR_T))) + (OR (i32.eq $tb (global.get $LIST_T)) + (i32.eq $tb (global.get $VECTOR_T)))) (then ;; EQUAL_Q_SEQ (block $done @@ -88,23 +88,23 @@ (br $done)) (if ($EQUAL_Q ($MEM_VAL1_ptr $a) ($MEM_VAL1_ptr $b)) (then - (set_local $a ($MEM_VAL0_ptr $a)) - (set_local $b ($MEM_VAL0_ptr $b))) + (local.set $a ($MEM_VAL0_ptr $a)) + (local.set $b ($MEM_VAL0_ptr $b))) (else (return 0))) (br $loop) ) ) (return (AND (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)))) - (else (if (AND (i32.eq $ta (get_global $HASHMAP_T)) - (i32.eq $tb (get_global $HASHMAP_T))) + (else (if (AND (i32.eq $ta (global.get $HASHMAP_T)) + (i32.eq $tb (global.get $HASHMAP_T))) ;; EQUAL_Q_HM (then (return 1)) ;; TODO: remove this once strings are interned - (else (if (OR (AND (i32.eq $ta (get_global $STRING_T)) - (i32.eq $tb (get_global $STRING_T))) - (AND (i32.eq $ta (get_global $SYMBOL_T)) - (i32.eq $tb (get_global $SYMBOL_T)))) + (else (if (OR (AND (i32.eq $ta (global.get $STRING_T)) + (i32.eq $tb (global.get $STRING_T))) + (AND (i32.eq $ta (global.get $SYMBOL_T)) + (i32.eq $tb (global.get $SYMBOL_T)))) (then (return (i32.eqz ($strcmp ($to_String $a) ($to_String $b))))) (else (return (AND (i32.eq $ta $tb) @@ -114,9 +114,9 @@ (func $DEREF_META (param $mv i32) (result i32) (loop $loop - (if (i32.eq ($TYPE $mv) (get_global $METADATA_T)) + (if (i32.eq ($TYPE $mv) (global.get $METADATA_T)) (then - (set_local $mv ($MEM_VAL0_ptr $mv)) + (local.set $mv ($MEM_VAL0_ptr $mv)) (br $loop))) ) $mv @@ -127,7 +127,7 @@ (func $to_MalString (param $mv i32) (result i32) ;; TODO: assert mv is a string/keyword/symbol - (i32.add (get_global $string_mem) ($VAL0 $mv)) + (i32.add (global.get $string_mem) ($VAL0 $mv)) ) (func $to_String (param $mv i32) (result i32) @@ -139,7 +139,7 @@ ;; return the MalVal pointer (func $STRING (param $type i32 $str i32) (result i32) (LET $ms ($ALLOC_STRING $str ($strlen $str) 1)) - ($ALLOC_SCALAR $type (i32.sub $ms (get_global $string_mem))) + ($ALLOC_SCALAR $type (i32.sub $ms (global.get $string_mem))) ) ;; Find first duplicate (internet) of mv. If one is found, free up @@ -152,10 +152,10 @@ $tmp 0) (if (AND $existing_ms (i32.lt_s $existing_ms $ms)) (then - (set_local $tmp $mv) - (set_local $res ($ALLOC_SCALAR (get_global $STRING_T) + (local.set $tmp $mv) + (local.set $res ($ALLOC_SCALAR (global.get $STRING_T) (i32.sub $existing_ms - (get_global $string_mem)))) + (global.get $string_mem)))) (i32.store16 $existing_ms (i32.add (i32.load16_u $existing_ms) 1)) ($RELEASE $tmp))) $res @@ -163,7 +163,7 @@ (func $STRING_INIT (param $type i32) (result i32) (LET $ms ($ALLOC_STRING "" 0 0)) - ($ALLOC_SCALAR $type (i32.sub $ms (get_global $string_mem))) + ($ALLOC_SCALAR $type (i32.sub $ms (global.get $string_mem))) ) (func $STRING_FINALIZE (param $mv i32 $size i32) (result i32) @@ -172,13 +172,13 @@ $ms ($to_MalString $mv)) (if $tmp (then - (set_local $mv $tmp)) + (local.set $mv $tmp)) (else ;;; ms->size = sizeof(MalString) + size + 1 (i32.store16 (i32.add $ms 2) (i32.add (i32.add 4 $size) 1)) ;;; string_mem_next = (void *)ms + ms->size - (set_global $string_mem_next + (global.set $string_mem_next (i32.add $ms (i32.load16_u (i32.add $ms 2)))))) $mv ) @@ -187,19 +187,19 @@ ;; numeric functions (func $INTEGER (param $val i32) (result i32) - ($ALLOC_SCALAR (get_global $INTEGER_T) $val) + ($ALLOC_SCALAR (global.get $INTEGER_T) $val) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; sequence functions (func $MAP_LOOP_START (param $type i32) (result i32) - (LET $res (if (result i32) (i32.eq $type (get_global $LIST_T)) - (then (get_global $EMPTY_LIST)) - (else (if (result i32) (i32.eq $type (get_global $VECTOR_T)) - (then (get_global $EMPTY_VECTOR)) - (else (if (result i32) (i32.eq $type (get_global $HASHMAP_T)) - (then (get_global $EMPTY_HASHMAP)) + (LET $res (if (result i32) (i32.eq $type (global.get $LIST_T)) + (then (global.get $EMPTY_LIST)) + (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) + (then (global.get $EMPTY_VECTOR)) + (else (if (result i32) (i32.eq $type (global.get $HASHMAP_T)) + (then (global.get $EMPTY_HASHMAP)) (else ($THROW_STR_1 "read_seq invalid type %d" $type) 0))))))) @@ -215,9 +215,9 @@ ;; sequence took ownership ($RELEASE $empty) ($RELEASE $val2) - (if (i32.eq $type (get_global $HASHMAP_T)) + (if (i32.eq $type (global.get $HASHMAP_T)) ($RELEASE $val3)) - (if (i32.gt_u $current (get_global $EMPTY_HASHMAP)) + (if (i32.gt_u $current (global.get $EMPTY_HASHMAP)) ;; if not first element, set current next to point to new element (i32.store ($VAL0_ptr $current) ($IDX $res))) @@ -229,19 +229,19 @@ ;; if it's already the right type, inc ref cnt and return it (if (i32.eq $type ($TYPE $mv)) (return ($INC_REF $mv))) ;; if it's empty, return the sequence match - (if (i32.le_u $mv (get_global $EMPTY_HASHMAP)) + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) (return ($MAP_LOOP_START $type))) ;; otherwise, copy first element to turn it into correct type ($ALLOC $type ($MEM_VAL0_ptr $mv) ($MEM_VAL1_ptr $mv) 0) ) (func $LIST (param $seq i32 $first i32) (result i32) - ($ALLOC (get_global $LIST_T) $seq $first 0) + ($ALLOC (global.get $LIST_T) $seq $first 0) ) (func $LIST2 (param $first i32 $second i32) (result i32) ;; last element is empty list - (LET $tmp ($LIST (get_global $EMPTY_LIST) $second) + (LET $tmp ($LIST (global.get $EMPTY_LIST) $second) $res ($LIST $tmp $first)) ($RELEASE $tmp) ;; new list takes ownership of previous $res @@ -255,7 +255,7 @@ ) (func $LIST_Q (param $mv i32) (result i32) - (i32.eq ($TYPE $mv) (get_global $LIST_T)) + (i32.eq ($TYPE $mv) (global.get $LIST_T)) ) (func $EMPTY_Q (param $mv i32) (result i32) @@ -267,8 +267,8 @@ (block $done (loop $loop (if (i32.eq ($VAL0 $mv) 0) (br $done)) - (set_local $cnt (i32.add $cnt 1)) - (set_local $mv ($MEM_VAL0_ptr $mv)) + (local.set $cnt (i32.add $cnt 1)) + (local.set $mv ($MEM_VAL0_ptr $mv)) (br $loop) ) ) @@ -280,15 +280,15 @@ ;; TODO: check that actually a list/vector (if (i32.eq ($VAL0 $mv) 0) ;; empty seq, return nil - (return ($INC_REF (get_global $NIL)))) + (return ($INC_REF (global.get $NIL)))) (block $done (loop $loop ;; end, return previous value (if (i32.eq ($VAL0 $mv) 0) (br $done)) ;; current becomes previous entry - (set_local $cur $mv) + (local.set $cur $mv) ;; next entry - (set_local $mv ($MEM_VAL0_ptr $mv)) + (local.set $mv ($MEM_VAL0_ptr $mv)) (br $loop) ) ) @@ -301,7 +301,7 @@ (func $SLICE (param $seq i32) (param $start i32) (param $end i32) (result i64) (LET $idx 0 - $res ($INC_REF (get_global $EMPTY_LIST)) + $res ($INC_REF (global.get $EMPTY_LIST)) $last 0 $tmp $res) ;; advance seq to start @@ -310,8 +310,8 @@ (if (OR (i32.ge_s $idx $start) (i32.eqz ($VAL0 $seq))) (br $done)) - (set_local $seq ($MEM_VAL0_ptr $seq)) - (set_local $idx (i32.add $idx 1)) + (local.set $seq ($MEM_VAL0_ptr $seq)) + (local.set $idx (i32.add $idx 1)) (br $loop) ) ) @@ -323,48 +323,48 @@ (i32.ge_s $idx $end)) (i32.eqz ($VAL0 $seq))) (then - (set_local $res $tmp) + (local.set $res $tmp) (br $done))) ;; allocate new list element with copied value - (set_local $res ($LIST (get_global $EMPTY_LIST) + (local.set $res ($LIST (global.get $EMPTY_LIST) ($MEM_VAL1_ptr $seq))) ;; sequence took ownership - ($RELEASE (get_global $EMPTY_LIST)) + ($RELEASE (global.get $EMPTY_LIST)) (if (i32.eqz $last) (then ;; if first element, set return value to new element - (set_local $tmp $res)) + (local.set $tmp $res)) (else ;; if not the first element, set return value to new element (i32.store ($VAL0_ptr $last) ($IDX $res)))) - (set_local $last $res) ;; update last list element + (local.set $last $res) ;; update last list element ;; advance to next element of seq - (set_local $seq ($MEM_VAL0_ptr $seq)) - (set_local $idx (i32.add $idx 1)) + (local.set $seq ($MEM_VAL0_ptr $seq)) + (local.set $idx (i32.add $idx 1)) (br $loop) ) ) ;; combine last/res as hi 32/low 32 of i64 (i64.or - (i64.shl (i64.extend_u/i32 $last) (i64.const 32)) - (i64.extend_u/i32 $res)) + (i64.shl (i64.extend_i32_u $last) (i64.const 32)) + (i64.extend_i32_u $res)) ) (func $HASHMAP (result i32) ;; just point to static empty hash-map - ($INC_REF (get_global $EMPTY_HASHMAP)) + ($INC_REF (global.get $EMPTY_HASHMAP)) ) (func $ASSOC1 (param $hm i32 $k i32 $v i32) (result i32) - (LET $res ($ALLOC (get_global $HASHMAP_T) $hm $k $v)) + (LET $res ($ALLOC (global.get $HASHMAP_T) $hm $k $v)) ;; we took ownership of previous release ($RELEASE $hm) $res ) (func $ASSOC1_S (param $hm i32 $k i32 $v i32) (result i32) - (LET $kmv ($STRING (get_global $STRING_T) $k) + (LET $kmv ($STRING (global.get $STRING_T) $k) $res ($ASSOC1 $hm $kmv $v)) ;; map took ownership of key ($RELEASE $kmv) @@ -382,36 +382,36 @@ ;;; if (VAL0(hm) == 0) (if (i32.eq ($VAL0 $hm) 0) (then - (set_local $res (get_global $NIL)) + (local.set $res (global.get $NIL)) (br $done))) ;;; test_key_mv = MEM_VAL1(hm) - (set_local $test_key_mv ($MEM_VAL1_ptr $hm)) + (local.set $test_key_mv ($MEM_VAL1_ptr $hm)) ;;; if (strcmp(key, to_String(test_key_mv)) == 0) (if (i32.eq ($strcmp $key ($to_String $test_key_mv)) 0) (then - (set_local $found 1) - (set_local $res ($MEM_VAL2_ptr $hm)) + (local.set $found 1) + (local.set $res ($MEM_VAL2_ptr $hm)) (br $done))) - (set_local $hm ($MEM_VAL0_ptr $hm)) + (local.set $hm ($MEM_VAL0_ptr $hm)) (br $loop) ) ) ;; combine found/res as hi 32/low 32 of i64 - (i64.or (i64.shl (i64.extend_u/i32 $found) (i64.const 32)) - (i64.extend_u/i32 $res)) + (i64.or (i64.shl (i64.extend_i32_u $found) (i64.const 32)) + (i64.extend_i32_u $res)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; function functions (func $FUNCTION (param $index i32) (result i32) - ($ALLOC_SCALAR (get_global $FUNCTION_T) $index) + ($ALLOC_SCALAR (global.get $FUNCTION_T) $index) ) (func $MALFUNC (param $ast i32 $params i32 $env i32) (result i32) - ($ALLOC (get_global $MALFUNC_T) $ast $params $env) + ($ALLOC (global.get $MALFUNC_T) $ast $params $env) ) ) From 53619a6e59630bbef082926f1ddc804b3aac7e52 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 16 Jan 2019 01:12:00 -0600 Subject: [PATCH 0426/1998] wasm: Add warpy wasm_MODE. - Update Dockerfile to install rpython and then use that build and install warpy (nojit). - Support 'warpy' in wasm_MODE. Update wasm/Makefile and wasm/run to support the new mode. --- .travis.yml | 1 + wasm/Dockerfile | 40 ++++++++++++++++++++++++++++++++++++---- wasm/Makefile | 2 +- wasm/run | 2 ++ 4 files changed, 40 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 2cb06e3125..782480ee07 100644 --- a/.travis.yml +++ b/.travis.yml @@ -93,6 +93,7 @@ matrix: - {env: IMPL=vimscript, services: [docker]} - {env: IMPL=wasm wasm_MODE=wace_libc, services: [docker]} - {env: IMPL=wasm wasm_MODE=node, services: [docker]} + - {env: IMPL=wasm wasm_MODE=warpy, services: [docker]} - {env: IMPL=yorick, services: [docker]} script: diff --git a/wasm/Dockerfile b/wasm/Dockerfile index 2a342839be..d533d48339 100644 --- a/wasm/Dockerfile +++ b/wasm/Dockerfile @@ -45,20 +45,52 @@ RUN dpkg --add-architecture i386 && \ apt-get -y install \ git-core cmake g++ lib32gcc-8-dev \ libsdl2-dev:i386 libsdl2-image-dev:i386 \ - libedit-dev:i386 + libedit-dev:i386 freeglut3-dev:i386 lib32gcc-7-dev \ + libreadline-dev:i386 RUN git clone https://github.com/WebAssembly/binaryen/ && \ cd binaryen && \ cmake . && make && \ make install -# TODO: merge up -RUN apt-get -y install freeglut3-dev:i386 lib32gcc-7-dev libreadline-dev:i386 +# +# pypy / rpython +# + +# rpython deps +ENV DEBIAN_FRONTEND=noninteractive +RUN apt-get -y install libffi-dev pkg-config libz-dev \ + libbz2-dev libsqlite3-dev libncurses-dev libexpat1-dev \ + libssl-dev libgdbm-dev tcl-dev + +# install pypy, build and install pypy/rpython, remove prior pypy +RUN apt-get -y install software-properties-common && \ + add-apt-repository ppa:pypy && \ + apt-get -y update && \ + apt-get -y install pypy && \ + mkdir -p /opt/pypy && \ + curl -L https://bitbucket.org/pypy/pypy/downloads/pypy2-v6.0.0-src.tar.bz2 \ + | tar -xjf - -C /opt/pypy/ --strip-components=1 && \ + cd /opt/pypy && make && \ + chmod -R ugo+rw /opt/pypy/rpython/_cache && \ + ln -sf /opt/pypy/rpython/bin/rpython /usr/local/bin/rpython && \ + ln -sf /opt/pypy/pypy-c /usr/local/bin/pypy && \ + rm -rf /tmp/usession* && \ + ln -sf /opt/pypy/pypy/goal/pypy-c /usr/local/bin/pypy && \ + apt-get -y autoremove pypy # # wac/wace # RUN git clone https://github.com/kanaka/wac/ && \ - cd wac && \ + cd wac && \ make USE_SDL= wac wace && \ cp wac wace /usr/bin + +# +# warpy +# +RUN git clone https://github.com/kanaka/warpy/ && \ + cd warpy && \ + make warpy-nojit && \ + cp warpy-nojit /usr/bin/warpy diff --git a/wasm/Makefile b/wasm/Makefile index 0c5e1b1df2..02d4ea1654 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -1,4 +1,4 @@ -MODE ?= $(if $(filter node js wace_fooboot,$(wasm_MODE)),os,libc) +MODE ?= $(if $(filter node js wace_fooboot warpy,$(wasm_MODE)),os,libc) WASM_AS ?= wasm-as WAMP ?= node_modules/.bin/wamp diff --git a/wasm/run b/wasm/run index 90465475ec..0dcce47255 100755 --- a/wasm/run +++ b/wasm/run @@ -3,6 +3,8 @@ STEP=${STEP:-stepA_mal} case "${wasm_MODE}" in node|js) exec ./run.js $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +warpy) + exec warpy --argv --memory-pages 256 $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; wace_fooboot) echo >&2 "wace_fooboot mode not yet supported" ;; wace_libc|*) From c4ce75c08f3b3ee4a5a906ca972d5a9c955b630b Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 16 Jan 2019 01:25:00 -0600 Subject: [PATCH 0427/1998] wasm: fix get_time_ms to return millis. Also, to avoid overflow, subtract 30 years so that the value won't wrap in i32. --- wasm/Dockerfile | 2 +- wasm/platform_os.wam | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/wasm/Dockerfile b/wasm/Dockerfile index d533d48339..9683e2aef2 100644 --- a/wasm/Dockerfile +++ b/wasm/Dockerfile @@ -91,6 +91,6 @@ RUN git clone https://github.com/kanaka/wac/ && \ # warpy # RUN git clone https://github.com/kanaka/warpy/ && \ - cd warpy && \ + cd warpy && \ make warpy-nojit && \ cp warpy-nojit /usr/bin/warpy diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index cb76c7ff93..46624d4047 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -5,7 +5,7 @@ (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) - (import "env" "get_time_ms" (func $lib_get_time_ms (result i32))) + (import "env" "get_time_ms" (func $lib_get_time_ms (result i64))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -39,7 +39,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $get_time_ms (result i32) - ($lib_get_time_ms) + (local $epoch_ms i64 $ms i64) + (local.set $epoch_ms ($lib_get_time_ms)) + ;; subtract 30 years to make sure it fits into i32 without + ;; wrapping or becoming negative + (i32.wrap_i64 (i64.sub $epoch_ms (i64.const 0x38640900))) ) ) From 266391c5505719a49cfff74dcf973754241edea7 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 16 Jan 2019 20:03:37 -0600 Subject: [PATCH 0428/1998] wasm: revert to i32 get_time_ms (subtract 30 years) JS doesn't support i64 types for exports/imports so revert to i32 return type but subtract 30 years to avoid wrapping/negative values. --- wasm/platform_os.wam | 8 ++------ wasm/run.js | 4 +++- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/wasm/platform_os.wam b/wasm/platform_os.wam index 46624d4047..cb76c7ff93 100644 --- a/wasm/platform_os.wam +++ b/wasm/platform_os.wam @@ -5,7 +5,7 @@ (import "env" "fputs" (func $lib_fputs (param i32 i32) (result i32))) (import "env" "readline" (func $lib_readline (param i32 i32 i32) (result i32))) (import "env" "read_file" (func $lib_read_file (param i32 i32) (result i32))) - (import "env" "get_time_ms" (func $lib_get_time_ms (result i64))) + (import "env" "get_time_ms" (func $lib_get_time_ms (result i32))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -39,11 +39,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (func $get_time_ms (result i32) - (local $epoch_ms i64 $ms i64) - (local.set $epoch_ms ($lib_get_time_ms)) - ;; subtract 30 years to make sure it fits into i32 without - ;; wrapping or becoming negative - (i32.wrap_i64 (i64.sub $epoch_ms (i64.const 0x38640900))) + ($lib_get_time_ms) ) ) diff --git a/wasm/run.js b/wasm/run.js index 849483128e..d9877e14ec 100755 --- a/wasm/run.js +++ b/wasm/run.js @@ -95,7 +95,9 @@ async function loadWebAssembly(filename, args) { } function get_time_ms() { - return (new Date()).getTime() + // subtract 30 years to make sure it fits into i32 without + // wrapping or becoming negative + return (new Date()).getTime() - 0x38640900 } // Marshal arguments From 5425eafbbc6e85da159de34df51d28af02de4e61 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 16 Jan 2019 21:01:15 -0600 Subject: [PATCH 0429/1998] wasm: update Dockerfile to force warpy build. --- wasm/Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/wasm/Dockerfile b/wasm/Dockerfile index 9683e2aef2..9913f68d79 100644 --- a/wasm/Dockerfile +++ b/wasm/Dockerfile @@ -91,6 +91,6 @@ RUN git clone https://github.com/kanaka/wac/ && \ # warpy # RUN git clone https://github.com/kanaka/warpy/ && \ - cd warpy && \ + cd warpy && \ make warpy-nojit && \ cp warpy-nojit /usr/bin/warpy From f88802514c4d0fffa601bfdb15f5a4cae16ea963 Mon Sep 17 00:00:00 2001 From: Windfarer Date: Mon, 21 Jan 2019 17:08:05 +0800 Subject: [PATCH 0430/1998] fix function name "tokenize" --- process/guide.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/process/guide.md b/process/guide.md index 3e58b366ec..aba0022f09 100644 --- a/process/guide.md +++ b/process/guide.md @@ -309,11 +309,11 @@ expression support. returns the token at the current position. * Add a function `read_str` in `reader.qx`. This function - will call `tokenizer` and then create a new Reader object instance + will call `tokenize` and then create a new Reader object instance with the tokens. Then it will call `read_form` with the Reader instance. -* Add a function `tokenizer` in `reader.qx`. This function will take +* Add a function `tokenize` in `reader.qx`. This function will take a single string and return an array/list of all the tokens (strings) in it. The following regular expression (PCRE) will match all mal tokens. From 4aa0ebdf471eb0431feca137e5eb9fb4ab475025 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 24 Jan 2019 12:40:36 -0600 Subject: [PATCH 0431/1998] Error on unterminated strings. Add a step1 test to make sure that implementations are properly throwing an error on unclosed strings. Fix 47 implementations and update the guide to note the correct behavior. --- awk/reader.awk | 8 ++++++-- basic/reader.in.bas | 2 +- c/reader.c | 7 +++++-- clojure/src/mal/reader.cljc | 18 ++++++++++-------- crystal/reader.cr | 10 ++++++---- cs/reader.cs | 7 +++++-- d/reader.d | 6 +++++- dart/reader.dart | 5 ++++- factor/lib/reader/reader.factor | 22 +++++++++++++--------- fantom/src/mallib/fan/reader.fan | 6 +++++- go/src/reader/reader.go | 5 ++++- groovy/reader.groovy | 13 +++++++++---- haxe/reader/Reader.hx | 2 +- hy/reader.hy | 5 ++++- io/MalReader.io | 3 ++- java/src/main/java/mal/reader.java | 10 ++++++---- julia/reader.jl | 4 +++- kotlin/src/mal/reader.kt | 10 ++++++---- livescript/reader.ls | 4 +++- logo/reader.lg | 2 +- make/reader.mk | 2 +- matlab/reader.m | 5 ++++- miniMAL/reader.json | 18 ++++++++++-------- nim/reader.nim | 6 ++++-- objc/reader.m | 10 ++++++---- objpascal/reader.pas | 6 ++++-- ocaml/reader.ml | 16 ++++++++++------ php/reader.php | 5 ++++- plpgsql/reader.sql | 4 +++- plsql/reader.sql | 7 +++++-- powershell/reader.psm1 | 4 +++- process/guide.md | 8 +++++--- r/reader.r | 5 ++++- racket/reader.rkt | 4 +++- rexx/reader.rexx | 8 +++++++- rpython/reader.py | 6 ++++-- ruby/reader.rb | 3 ++- scala/reader.scala | 5 ++++- skew/reader.sk | 2 +- swift/reader.swift | 10 +++++++--- swift3/Sources/reader.swift | 2 +- tcl/reader.tcl | 3 ++- tests/step1_read_print.mal | 6 +++--- ts/reader.ts | 5 ++++- vb/reader.vb | 7 +++++-- vhdl/reader.vhdl | 9 +++++++-- wasm/reader.wam | 2 +- yorick/reader.i | 7 +++++-- 48 files changed, 218 insertions(+), 106 deletions(-) diff --git a/awk/reader.awk b/awk/reader.awk index 905ef52d13..a45e6e5679 100644 --- a/awk/reader.awk +++ b/awk/reader.awk @@ -18,7 +18,11 @@ function reader_read_atom(token) case /^:/: return ":" token case /^"/: - return reader_read_string(token) + if (token ~ /"$/) { + return reader_read_string(token) + } else { + return "!\"Expected '\"', got EOF." + } case /^-?[0-9]+$/: return "+" token default: @@ -147,7 +151,7 @@ function reader_read_from(reader, current) function reader_tokenizer(str, reader, len, r) { - for (len = 0; match(str, /^[ \t\r\n,]*(~@|[\[\]{}()'`~^@]|\"(\\[^\r\n]|[^\\"\r\n])*\"|;[^\r\n]*|[^ \t\r\n\[\]{}('"`,;)^~@][^ \t\r\n\[\]{}('"`,;)]*)/, r); ) { + for (len = 0; match(str, /^[ \t\r\n,]*(~@|[\[\]{}()'`~^@]|\"(\\[^\r\n]|[^\\"\r\n])*\"?|;[^\r\n]*|[^ \t\r\n\[\]{}('"`,;)^~@][^ \t\r\n\[\]{}('"`,;)]*)/, r); ) { if (substr(r[1], 1, 1) != ";") { reader[len++] = r[1] } diff --git a/basic/reader.in.bas b/basic/reader.in.bas index ee2e864e8d..2482646195 100644 --- a/basic/reader.in.bas +++ b/basic/reader.in.bas @@ -166,7 +166,7 @@ SUB READ_FORM READ_STRING: REM PRINT "READ_STRING" C=ASC(MID$(T$,LEN(T$),1)) - IF C<>34 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"'":GOTO READ_FORM_RETURN + IF C<>34 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"', got EOF":GOTO READ_FORM_RETURN R$=MID$(T$,2,LEN(T$)-2) S1$=CHR$(92)+CHR$(92):S2$=CHR$(127):GOSUB REPLACE: REM protect backslashes S1$=CHR$(92)+CHR$(34):S2$=CHR$(34):GOSUB REPLACE: REM unescape quotes diff --git a/c/reader.c b/c/reader.c index 2528b3a1d0..45615c5b88 100644 --- a/c/reader.c +++ b/c/reader.c @@ -52,7 +52,7 @@ Reader *tokenize(char *line) { Reader *reader = reader_new(); - regex = g_regex_new ("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)", 0, 0, &err); + regex = g_regex_new ("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)", 0, 0, &err); g_regex_match (regex, line, 0, &matchInfo); if (err != NULL) { @@ -89,7 +89,7 @@ MalVal *read_atom(Reader *reader) { token = reader_next(reader); //g_print("read_atom token: %s\n", token); - regex = g_regex_new ("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"(.*)\"$|:(.*)|(^[^\"]*$)", 0, 0, &err); + regex = g_regex_new ("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"(.*)\"?$|:(.*)|(^[^\"]*$)", 0, 0, &err); g_regex_match (regex, token, 0, &matchInfo); if (g_match_info_fetch_pos(matchInfo, 1, &pos, NULL) && pos != -1) { @@ -109,6 +109,9 @@ MalVal *read_atom(Reader *reader) { atom = &mal_false; } else if (g_match_info_fetch_pos(matchInfo, 6, &pos, NULL) && pos != -1) { //g_print("read_atom string: %s\n", token); + int end = strlen(token)-1; + if (token[end] != '"') { abort("expected '\"', got EOF"); } + token[end] = '\0'; atom = malval_new_string(g_strcompress(g_match_info_fetch(matchInfo, 6))); } else if (g_match_info_fetch_pos(matchInfo, 7, &pos, NULL) && pos != -1) { //g_print("read_atom keyword\n"); diff --git a/clojure/src/mal/reader.cljc b/clojure/src/mal/reader.cljc index 93b2df3b52..9fb1941b01 100644 --- a/clojure/src/mal/reader.cljc +++ b/clojure/src/mal/reader.cljc @@ -17,6 +17,7 @@ (def tok-re #"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\].|[^\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)") (def int-re #"^-?[0-9]+$") +(def badstr-re #"^\"(.*)[^\"]$") (def str-re #"^\"(.*)\"$") (defn tokenize [s] @@ -32,14 +33,15 @@ (defn read-atom [rdr] (let [token (rdr-next rdr)] (cond - (re-seq int-re token) #?(:cljs (js/parseInt token) - :clj (Integer/parseInt token)) - (re-seq str-re token) (unescape (second (re-find str-re token))) - (= \: (get token 0)) (keyword (subs token 1)) - (= "nil" token) nil - (= "true" token) true - (= "false" token) false - :else (symbol token)))) + (re-seq int-re token) #?(:cljs (js/parseInt token) + :clj (Integer/parseInt token)) + (re-seq badstr-re token) (throw-str (str "expected '\"', got EOF")) + (re-seq str-re token) (unescape (second (re-find str-re token))) + (= \: (get token 0)) (keyword (subs token 1)) + (= "nil" token) nil + (= "true" token) true + (= "false" token) false + :else (symbol token)))) (declare read-form) diff --git a/crystal/reader.cr b/crystal/reader.cr index 3fbbd7c97a..5eca482f08 100644 --- a/crystal/reader.cr +++ b/crystal/reader.cr @@ -81,9 +81,11 @@ class Reader when token == "true" then true when token == "false" then false when token == "nil" then nil - when token[0] == '"' then token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", - "\\n" => "\n", - "\\\\" => "\\"}) + when token[0] == '"' + parse_error "expected '\"', got EOF" if token[-1] != '"' + token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", + "\\n" => "\n", + "\\\\" => "\\"}) when token[0] == ':' then "\u029e#{token[1..-1]}" else Mal::Symbol.new token end @@ -121,7 +123,7 @@ class Reader end def tokenize(str) - regex = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/ + regex = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ str.scan(regex).map { |m| m[1] }.reject(&.empty?) end diff --git a/cs/reader.cs b/cs/reader.cs index 60798e37bf..3136b904c6 100644 --- a/cs/reader.cs +++ b/cs/reader.cs @@ -39,7 +39,7 @@ public string next() { public static List tokenize(string str) { List tokens = new List(); - string pattern = @"[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""|;.*|[^\s \[\]{}()'""`~@,;]*)"; + string pattern = @"[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""?|;.*|[^\s \[\]{}()'""`~@,;]*)"; Regex regex = new Regex(pattern); foreach (Match match in regex.Matches(str)) { string token = match.Groups[1].Value; @@ -53,7 +53,7 @@ public static List tokenize(string str) { public static MalVal read_atom(Reader rdr) { string token = rdr.next(); - string pattern = @"(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^("".*"")$|:(.*)|(^[^""]*$)"; + string pattern = @"(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^("".*)|:(.*)|(^[^""]*$)"; Regex regex = new Regex(pattern); Match match = regex.Match(token); //Console.WriteLine("token: ^" + token + "$"); @@ -70,6 +70,9 @@ public static MalVal read_atom(Reader rdr) { return Mal.types.False; } else if (match.Groups[6].Value != String.Empty) { string str = match.Groups[6].Value; + if (str[str.Length-1] != '"') { + throw new ParseError("expected '\"', got EOF"); + } str = str.Substring(1, str.Length-2) .Replace("\\\\", "\u029e") .Replace("\\\"", "\"") diff --git a/d/reader.d b/d/reader.d index 2f6ed44911..19681cb0c4 100644 --- a/d/reader.d +++ b/d/reader.d @@ -44,7 +44,7 @@ class Reader } } -auto tokenize_ctr = ctRegex!(r"[\s,]*(~@|[\[\]{}()'`~^@]|" `"` `(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"` r"`,;)]*)"); +auto tokenize_ctr = ctRegex!(r"[\s,]*(~@|[\[\]{}()'`~^@]|" `"` `(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"` r"`,;)]*)"); string[] tokenize(string str) { @@ -87,6 +87,10 @@ MalType read_atom(Reader reader) case ':': return new MalString("\u029e" ~ token[1..$]); case '"': + if (token[$-1] != '"') + { + throw new Exception("expected '\"', got EOF"); + } return parse_string(token); default: auto captures = matchFirst(token, integer_ctr); diff --git a/dart/reader.dart b/dart/reader.dart index e440ae054b..fc6eb51071 100644 --- a/dart/reader.dart +++ b/dart/reader.dart @@ -1,7 +1,7 @@ import 'types.dart'; final malRegExp = new RegExp( - r"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)"""); + r"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)"""); class Reader { final List tokens; @@ -115,6 +115,9 @@ MalType read_atom(Reader reader) { } if (token[0] == '"') { + if (token[token.length -1 ] != '"') { + throw new ParseException("expected '\"', got EOF"); + } var sanitizedToken = token // remove surrounding quotes .substring(1, token.length - 1) diff --git a/factor/lib/reader/reader.factor b/factor/lib/reader/reader.factor index da72277e00..568eae0f53 100644 --- a/factor/lib/reader/reader.factor +++ b/factor/lib/reader/reader.factor @@ -4,19 +4,23 @@ USING: arrays combinators grouping hashtables kernel lists locals make lib.types math.parser regexp sequences splitting strings ; IN: lib.reader -CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)~^@]+)/ +CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)~^@]+)/ DEFER: read-form : (read-string) ( str -- maltype ) - rest but-last R/ \\./ [ - { - { [ dup >string "\\\\" = ] [ drop "\\" ] } - { [ dup >string "\\n" = ] [ drop "\n" ] } - { [ dup >string "\\\"" = ] [ drop "\"" ] } - [ ] - } cond - ] re-replace-with ; + dup last CHAR: " = [ + rest but-last R/ \\./ [ + { + { [ dup >string "\\\\" = ] [ drop "\\" ] } + { [ dup >string "\\n" = ] [ drop "\n" ] } + { [ dup >string "\\\"" = ] [ drop "\"" ] } + [ ] + } cond + ] re-replace-with + ] [ + "expected '\"', got EOF" throw + ] if ; : (read-atom) ( str -- maltype ) { diff --git a/fantom/src/mallib/fan/reader.fan b/fantom/src/mallib/fan/reader.fan index edf9fe1337..d7a1f9c037 100644 --- a/fantom/src/mallib/fan/reader.fan +++ b/fantom/src/mallib/fan/reader.fan @@ -18,7 +18,7 @@ class Reader { private static Str[] tokenize(Str s) { - r := Regex <|[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)|> + r := Regex <|[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)|> m := r.matcher(s) tokens := Str[,] while (m.find()) @@ -39,10 +39,14 @@ class Reader { token := reader.next intRegex := Regex <|^-?\d+$|> + strRegex := Regex <|^".*"|> + strBadRegex := Regex <|^".*|> if (token == "nil") return MalNil.INSTANCE if (token == "true") return MalTrue.INSTANCE if (token == "false") return MalFalse.INSTANCE if (intRegex.matches(token)) return MalInteger(token.toInt) + if (strRegex.matches(token)) return MalString.make(unescape_str(token[1..-2])) + if (strBadRegex.matches(token)) throw Err("expected '\"', got EOF") if (token[0] == '"') return MalString.make(unescape_str(token[1..-2])) if (token[0] == ':') return MalString.makeKeyword(token[1..-1]) return MalSymbol(token) diff --git a/go/src/reader/reader.go b/go/src/reader/reader.go index dc0f54f46f..e16dca86be 100644 --- a/go/src/reader/reader.go +++ b/go/src/reader/reader.go @@ -42,7 +42,7 @@ func tokenize(str string) []string { results := make([]string, 0, 1) // Work around lack of quoting in backtick re := regexp.MustCompile(`[\s,]*(~@|[\[\]{}()'` + "`" + - `~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"` + "`" + + `~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"` + "`" + `,;)]*)`) for _, group := range re.FindAllStringSubmatch(str, -1) { if (group[1] == "") || (group[1][0] == ';') { @@ -66,6 +66,9 @@ func read_atom(rdr Reader) (MalType, error) { } return i, nil } else if (*token)[0] == '"' { + if (*token)[len(*token)-1] != '"' { + return nil, errors.New("expected '\"', got EOF") + } str := (*token)[1 : len(*token)-1] return strings.Replace( strings.Replace( diff --git a/groovy/reader.groovy b/groovy/reader.groovy index b47f357e50..8b168d1e17 100644 --- a/groovy/reader.groovy +++ b/groovy/reader.groovy @@ -29,7 +29,7 @@ class reader { } def static tokenizer(String str) { - def m = str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/ + def m = str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ def tokens = [] while (m.find()) { String token = m.group(1) @@ -44,7 +44,7 @@ class reader { def static read_atom(Reader rdr) { def token = rdr.next() - def m = token =~ /(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^"(.*)"$|:(.*)|(^[^"]*$)/ + def m = token =~ /(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^"(.*)"$|^"(.*)$|:(.*)|(^[^"]*$)/ if (!m.find()) { throw new MalException("unrecognized token '$token'") } @@ -57,11 +57,16 @@ class reader { } else if (m.group(5) != null) { false } else if (m.group(6) != null) { + if (token[token.length() - 1] != '"') { + throw new MalException("expected '\"', got EOF") + } StringEscapeUtils.unescapeJava(m.group(6)) } else if (m.group(7) != null) { - "\u029e" + m.group(7) + throw new MalException("expected '\"', got EOF") } else if (m.group(8) != null) { - new MalSymbol(m.group(8)) + "\u029e" + m.group(8) + } else if (m.group(9) != null) { + new MalSymbol(m.group(9)) } else { throw new MalException("unrecognized '${m.group(0)}'") } diff --git a/haxe/reader/Reader.hx b/haxe/reader/Reader.hx index d06f8008fe..53d6b5181f 100644 --- a/haxe/reader/Reader.hx +++ b/haxe/reader/Reader.hx @@ -73,7 +73,7 @@ class Reader { "\n"), "\""), "\\")); - case _ if (re_str.match(token)): + case _ if (re_str_bad.match(token)): throw 'expected \'"\', got EOF'; case _: MalSymbol(token); diff --git a/hy/reader.hy b/hy/reader.hy index 4c9bd1d525..0bf9f9c17f 100644 --- a/hy/reader.hy +++ b/hy/reader.hy @@ -17,6 +17,8 @@ (def tok-re (.compile re "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)")) (def int-re (.compile re "-?[0-9]+$")) +(def str-re (.compile re "^\".*\"$")) +(def str-bad-re (.compile re "^\".*$")) (defn tokenize [str] (list-comp @@ -34,7 +36,8 @@ (setv token (.next rdr)) (if (.match re int-re token) (int token) - (= "\"" (get token 0)) (Str (unescape (cut token 1 -1))) + (.match re str-re token) (Str (unescape (cut token 1 -1))) + (.match re str-bad-re token) (raise (Exception (+ "expected '\"', got EOF"))) (= ":" (get token 0)) (Keyword token) (= "nil" token) None (= "true" token) True diff --git a/io/MalReader.io b/io/MalReader.io index b753913706..354ec30b3c 100644 --- a/io/MalReader.io +++ b/io/MalReader.io @@ -16,7 +16,7 @@ MalReader := Object clone do ( ) ) - tokenizerRegex := Regex with("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)") + tokenizerRegex := Regex with("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)") tokenize := method(str, tokenizerRegex matchesIn(str) \ @@ -28,6 +28,7 @@ MalReader := Object clone do ( numberRegex := Regex with("^-?[0-9]+$") read_string := method(token, + (token endsWithSeq("\"")) ifFalse(Exception raise("expected '\"', got EOF")) placeholder := 127 asCharacter token exSlice(1, -1) replaceSeq("\\\\", placeholder) replaceSeq("\\\"", "\"") replaceSeq("\\n", "\n") replaceSeq(placeholder, "\\") ) diff --git a/java/src/main/java/mal/reader.java b/java/src/main/java/mal/reader.java index 7c9d3aa07b..41b9349f91 100644 --- a/java/src/main/java/mal/reader.java +++ b/java/src/main/java/mal/reader.java @@ -35,7 +35,7 @@ public String next() { public static ArrayList tokenize(String str) { ArrayList tokens = new ArrayList(); - Pattern pattern = Pattern.compile("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)"); + Pattern pattern = Pattern.compile("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)"); Matcher matcher = pattern.matcher(str); while (matcher.find()) { String token = matcher.group(1); @@ -51,7 +51,7 @@ public static ArrayList tokenize(String str) { public static MalVal read_atom(Reader rdr) throws ParseError { String token = rdr.next(); - Pattern pattern = Pattern.compile("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"(.*)\"$|:(.*)|(^[^\"]*$)"); + Pattern pattern = Pattern.compile("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"(.*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)"); Matcher matcher = pattern.matcher(token); if (!matcher.find()) { throw new ParseError("unrecognized token '" + token + "'"); @@ -67,9 +67,11 @@ public static MalVal read_atom(Reader rdr) } else if (matcher.group(6) != null) { return new MalString(StringEscapeUtils.unescapeJson(matcher.group(6))); } else if (matcher.group(7) != null) { - return new MalString("\u029e" + matcher.group(7)); + throw new ParseError("expected '\"', got EOF"); } else if (matcher.group(8) != null) { - return new MalSymbol(matcher.group(8)); + return new MalString("\u029e" + matcher.group(8)); + } else if (matcher.group(9) != null) { + return new MalSymbol(matcher.group(9)); } else { throw new ParseError("unrecognized '" + matcher.group(0) + "'"); } diff --git a/julia/reader.jl b/julia/reader.jl index 29b5dc9548..6763bce635 100644 --- a/julia/reader.jl +++ b/julia/reader.jl @@ -26,7 +26,7 @@ end function tokenize(str) - re = r"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\.|[^\\\"])*\"|;.*|[^\s\[\]{}('\"`,;)]*)" + re = r"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;.*|[^\s\[\]{}('\"`,;)]*)" tokens = map((m) -> m.captures[1], eachmatch(re, str)) filter((t) -> t != "" && t[1] != ';', tokens) end @@ -41,6 +41,8 @@ function read_atom(rdr) replace(token[2:end-1], r"\\.", (r) -> get(Dict("\\n"=>"\n", "\\\""=>"\"", "\\\\"=>"\\"), r, r)) + elseif ismatch(r"^\".*$", token) + error("expected '\"', got EOF") elseif token[1] == ':' "\u029e$(token[2:end])" elseif token == "nil" diff --git a/kotlin/src/mal/reader.kt b/kotlin/src/mal/reader.kt index 3b23be5f04..48b258e3ad 100644 --- a/kotlin/src/mal/reader.kt +++ b/kotlin/src/mal/reader.kt @@ -2,8 +2,8 @@ package mal import kotlin.text.Regex -val TOKEN_REGEX = Regex("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\\s\\[\\]{}('\"`,;)]*)") -val ATOM_REGEX = Regex("(^-?[0-9]+$)|(^nil$)|(^true$)|(^false$)|^\"(.*)\"$|:(.*)|(^[^\"]*$)") +val TOKEN_REGEX = Regex("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") +val ATOM_REGEX = Regex("(^-?[0-9]+$)|(^nil$)|(^true$)|(^false$)|^\"(.*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)") class Reader(sequence: Sequence) { val tokens = sequence.iterator() @@ -145,9 +145,11 @@ fun read_atom(reader: Reader): MalType { else m.groups[1]?.value.toString() }) } else if (groups[6]?.value != null) { - MalKeyword(groups[6]?.value as String) + throw MalReaderException("expected '\"', got EOF") } else if (groups[7]?.value != null) { - MalSymbol(groups[7]?.value as String) + MalKeyword(groups[7]?.value as String) + } else if (groups[8]?.value != null) { + MalSymbol(groups[8]?.value as String) } else { throw MalReaderException("Unrecognized token: " + next) } diff --git a/livescript/reader.ls b/livescript/reader.ls index 96aad575ac..0eba293d83 100644 --- a/livescript/reader.ls +++ b/livescript/reader.ls @@ -47,7 +47,7 @@ tokenizer = (str) -> [\s,]* # whitespace or commas ( ~@ # special two-char ~@ | [\[\]{}()'`~^@] # special single char one of []{}'`~^@ - | "(?:\\.| [^\\"])*" # double-quoted string + | "(?:\\.| [^\\"])*"? # double-quoted string | ;.* # any seq of chars starting ; | [^\s\[\]{}('"`,;)]+ # seq of non-special chars: symbols, numbers, ) # "true", "false" and "nil". @@ -112,6 +112,8 @@ read_atom = (reader) -> if token in constants {type: \const, value: reader.next!} else if token[0] == '"' + if not token.endsWith '"' + parse-error "expected '\"', got EOF" {type: \string, value: decode-string reader.next!} else if token.match /^-?\d+$/ {type: \int, value: parseInt reader.next!} diff --git a/logo/reader.lg b/logo/reader.lg index dc4c85171e..049428d0c3 100644 --- a/logo/reader.lg +++ b/logo/reader.lg @@ -84,7 +84,7 @@ while [not emptyp :rest] [ make "w word :w :c make "rest butfirst :rest ] -(throw "error [Expected closing quotes]) +(throw "error [Expected closing quotes, not EOF]) end to read_next_token :s diff --git a/make/reader.mk b/make/reader.mk index 3f620a1171..df635cf859 100755 --- a/make/reader.mk +++ b/make/reader.mk @@ -85,7 +85,7 @@ $(foreach ch,$(word 1,$($(1))),\ $(call __string,$(strip $(call READ_STRING,$(1))))\ $(eval $(if $(filter $(DQUOTE),$(word 1,$($(1)))),\ $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(DQUOTE)' in; $($(1))))),\ + $(call _error,Expected '$(DQUOTE)' in; $($(1))$(COMMA) got EOF))),\ $(if $(filter $(COLON),$(ch)),\ $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ $(call _keyword,$(call READ_KEYWORD,$(1))),\ diff --git a/matlab/reader.m b/matlab/reader.m index 937c9534dd..9bfc72be41 100644 --- a/matlab/reader.m +++ b/matlab/reader.m @@ -2,7 +2,7 @@ classdef reader methods (Static = true) function tokens = tokenize(str) - re = '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"|;[^\n]*|[^\s\[\]{}(''"`,;)]*)'; + re = '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"?|;[^\n]*|[^\s\[\]{}(''"`,;)]*)'; % extract the capture group (to ignore spaces and commas) tokens = cellfun(@(x) x(1), regexp(str, re, 'tokens')); comments = cellfun(@(x) length(x) > 0 && x(1) == ';', tokens); @@ -15,6 +15,9 @@ if not(isempty(regexp(token, '^-?[0-9]+$', 'match'))) atm = str2double(token); elseif strcmp(token(1), '"') + if not(token(end) == '"') + error('expected ''"'', got EOF'); + end atm = token(2:length(token)-1); atm = strrep(atm, '\\', char(255)); atm = strrep(atm, '\"', '"'); diff --git a/miniMAL/reader.json b/miniMAL/reader.json index dafa691f8c..b1de4d98ac 100644 --- a/miniMAL/reader.json +++ b/miniMAL/reader.json @@ -24,7 +24,7 @@ ["re-matches", "re", "strn", ["concat", "acc", "g1"]]]]]], ["def", "tokenize", ["fn", ["strn"], - ["let", ["re-str", ["`", "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\\s\\[\\]{}('\"`,;)]*)"], + ["let", ["re-str", ["`", "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)"], "re", ["RegExp", "re-str", ["`", "g"]]], [".", ["re-matches", "re", "strn", ["`", []]], @@ -37,13 +37,15 @@ ["if", [".", "token", ["`", "match"], ["RegExp", ["`", "^-?[0-9]+$"]]], ["parseInt", "token", 10], ["if", ["=", ["`", "\""], ["get", "token", 0]], - [".", - ["slice", "token", 1, ["-", ["count", "token"], 1]], - ["`", "replace"], ["RegExp", ["`", "\\\\(.)"], ["`", "g"]], - ["fn", ["_", "c"], - ["if", ["=", "c", ["`", "n"]], - ["`", "\n"], - "c"]]], + ["if", ["=", ["`", "\""], ["get", "token", ["-", ["count", "token"], 1]]], + [".", + ["slice", "token", 1, ["-", ["count", "token"], 1]], + ["`", "replace"], ["RegExp", ["`", "\\\\(.)"], ["`", "g"]], + ["fn", ["_", "c"], + ["if", ["=", "c", ["`", "n"]], + ["`", "\n"], + "c"]]], + ["throw", ["`", "expected '\"', got EOF"]]], ["if", ["=", ["`", ":"], ["get", "token", 0]], ["keyword", ["slice", "token", 1]], ["if", ["=", ["`", "nil"], "token"], diff --git a/nim/reader.nim b/nim/reader.nim index 6bc2997fee..7c61dbdde1 100644 --- a/nim/reader.nim +++ b/nim/reader.nim @@ -1,7 +1,7 @@ import re, strutils, sequtils, types let - tokenRE = re"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)""" + tokenRE = re"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)""" intRE = re"-?[0-9]+$" type @@ -61,7 +61,9 @@ proc read_hash_map(r: var Reader): MalType = proc read_atom(r: var Reader): MalType = let t = r.next if t.match(intRE): number t.parseInt - elif t[0] == '"': str t[1 .. '' then - read_atom := TMalString.Create(#127 + RE.Match[7]) + raise Exception.Create('expected ''"'', got EOF') else if RE.Match[8] <> '' then + read_atom := TMalString.Create(#127 + RE.Match[8]) + else if RE.Match[9] <> '' then read_atom := TMalSymbol.Create(Token); end else diff --git a/ocaml/reader.ml b/ocaml/reader.ml index fa009e255a..24cd1e927d 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -18,7 +18,7 @@ let gsub re f str = "" (List.map (function | Str.Delim x -> f x | Str.Text x -> x) (Str.full_split re str)) -let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"\\|;.*\\|[^][ \n{}('\"`,;)]*") +let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*") type reader = { form : Types.mal_type; @@ -43,11 +43,15 @@ let read_atom token = | _ -> (match token.[1] with | '0'..'9' -> T.Int (int_of_string token) | _ -> Types.symbol token)) - | '"' -> T.String (gsub (Str.regexp "\\\\.") - (function - | "\\n" -> "\n" - | x -> String.sub x 1 1) - (String.sub token 1 ((String.length token) - 2))) + | '"' -> (match token.[String.length token - 1] with + | '"' -> T.String (gsub (Str.regexp "\\\\.") + (function + | "\\n" -> "\n" + | x -> String.sub x 1 1) + (String.sub token 1 ((String.length token) - 2))) + | _ -> output_string stderr ("expected '\"', got EOF\n"); + flush stderr; + raise End_of_file) | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) | _ -> Types.symbol token diff --git a/php/reader.php b/php/reader.php index 3408b1ae1f..055dee9b00 100644 --- a/php/reader.php +++ b/php/reader.php @@ -27,7 +27,7 @@ function _real_token($s) { } function tokenize($str) { - $pat = "/[\s,]*(php\/|~@|[\[\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\s\[\]{}('\"`,;)]*)/"; + $pat = "/[\s,]*(php\/|~@|[\[\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\s\[\]{}('\"`,;)]*)/"; preg_match_all($pat, $str, $matches); return array_values(array_filter($matches[1], '_real_token')); } @@ -37,6 +37,9 @@ function read_atom($reader) { if (preg_match("/^-?[0-9]+$/", $token)) { return intval($token, 10); } elseif ($token[0] === "\"") { + if (substr($token, -1) !== "\"") { + throw new Exception("expected '\"', got EOF"); + } $str = substr($token, 1, -1); $str = str_replace('\\\\', chr(0x7f), $str); $str = str_replace('\\"', '"', $str); diff --git a/plpgsql/reader.sql b/plpgsql/reader.sql index cf1d8fdb5c..4210961592 100644 --- a/plpgsql/reader.sql +++ b/plpgsql/reader.sql @@ -5,7 +5,7 @@ CREATE SCHEMA reader; CREATE FUNCTION reader.tokenize(str varchar) RETURNS varchar[] AS $$ DECLARE - re varchar = E'[[:space:] ,]*(~@|[\\[\\]{}()\'`~@]|"(?:[\\\\].|[^\\\\"])*"|;[^\n]*|[^\\s \\[\\]{}()\'"`~@,;]*)'; + re varchar = E'[[:space:] ,]*(~@|[\\[\\]{}()\'`~@]|"(?:[\\\\].|[^\\\\"])*"?|;[^\n]*|[^\\s \\[\\]{}()\'"`~@,;]*)'; BEGIN RETURN ARRAY(SELECT tok FROM (SELECT (regexp_matches(str, re, 'g'))[1] AS tok) AS x @@ -44,6 +44,8 @@ BEGIN str := replace(str, '\n', E'\n'); str := replace(str, chr(CAST(x'7f' AS integer)), E'\\'); result := types._stringv(str); + ELSIF token ~ '^".*' THEN -- unclosed string + RAISE EXCEPTION 'expected ''"'', got EOF'; ELSIF token ~ '^:.*' THEN -- keyword -- keyword result := types._keywordv(substring(token FROM 2 FOR (char_length(token)-1))); diff --git a/plsql/reader.sql b/plsql/reader.sql index b48e7c0906..e5e37cf389 100644 --- a/plsql/reader.sql +++ b/plsql/reader.sql @@ -44,7 +44,7 @@ CREATE OR REPLACE PACKAGE BODY reader AS -- tokenize: -- takes a string and returns a nested table of token strings FUNCTION tokenize(str varchar) RETURN tokens IS - re varchar2(100) := '[[:space:] ,]*(~@|[][{}()''`~@]|"(([\].|[^\"])*)"|;[^' || chr(10) || ']*|[^][[:space:] {}()''"`~@,;]*)'; + re varchar2(100) := '[[:space:] ,]*(~@|[][{}()''`~@]|"(([\].|[^\"])*)"?|;[^' || chr(10) || ']*|[^][[:space:] {}()''"`~@,;]*)'; tok CLOB; toks tokens := tokens(); cnt integer; @@ -90,6 +90,9 @@ BEGIN str := REPLACE(str, '\n', chr(10)); str := REPLACE(str, '\\', chr(92)); result := types.string(M, str); + ELSIF REGEXP_LIKE(token, '^".*') THEN -- unclosed string + raise_application_error(-20003, + 'expected ''"'', got EOF', TRUE); ELSIF REGEXP_LIKE(token, '^:.*') THEN -- keyword -- keyword result := types.keyword(M, SUBSTR(token, 2, LENGTH(token)-1)); @@ -127,7 +130,7 @@ BEGIN token := rdr.peek(); IF token IS NULL THEN raise_application_error(-20003, - 'expected ''' || last || '''', TRUE); + 'expected ''' || last || ''', got EOF', TRUE); END IF; IF token = last THEN EXIT; END IF; items.EXTEND(); diff --git a/powershell/reader.psm1 b/powershell/reader.psm1 index b957ca2055..18d8f48477 100644 --- a/powershell/reader.psm1 +++ b/powershell/reader.psm1 @@ -20,7 +20,7 @@ Class Reader { function tokenize { - $r = [regex]"[\s,]*(~@|[\[\]{}()'``~^@]|`"(?:\\.|[^\\`"])*`"|;.*|[^\s\[\]{}('`"``,;)]*)" + $r = [regex]"[\s,]*(~@|[\[\]{}()'``~^@]|`"(?:\\.|[^\\`"])*`"?|;.*|[^\s\[\]{}('`"``,;)]*)" $r.Matches($args) | Where-Object { $_.Groups.Item(1).Value.Length -gt 0 -and $_.Groups.Item(1).Value[0] -ne ";" } | @@ -38,6 +38,8 @@ function read_atom([Reader] $rdr) { $s = $s -replace "\\n", "`n" $s = $s -replace "$([char]0x29e)", "\" return $s + } elseif ($token -match "^`".*") { + throw "expected '`"', got EOF" } elseif ($token -match ":.*") { return "$([char]0x29e)$($token.substring(1))" } elseif ($token -eq "true") { diff --git a/process/guide.md b/process/guide.md index aba0022f09..49bfb3b574 100644 --- a/process/guide.md +++ b/process/guide.md @@ -318,7 +318,7 @@ expression support. of all the tokens (strings) in it. The following regular expression (PCRE) will match all mal tokens. ``` -[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*) +[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*) ``` * For each match captured within the parenthesis starting at char 6 of the regular expression a new token will be created. @@ -331,9 +331,11 @@ expression support. * ```[\[\]{}()'`~^@]```: Captures any special single character, one of ```[]{}()'`~^@``` (tokenized). - * `"(?:\\.|[^\\"])*"`: Starts capturing at a double-quote and stops at the + * `"(?:\\.|[^\\"])*"?`: Starts capturing at a double-quote and stops at the next double-quote unless it was proceeded by a backslash in which case it - includes it until the next double-quote (tokenized). + includes it until the next double-quote (tokenized). It will also + match unbalanced strings (no ending double-quote) which should be + reported as an error. * `;.*`: Captures any sequence of characters starting with `;` (tokenized). diff --git a/r/reader.r b/r/reader.r index b2729f840e..be163e6306 100644 --- a/r/reader.r +++ b/r/reader.r @@ -21,7 +21,7 @@ Reader.next <- function(rdr) { } tokenize <- function(str) { - re <- "[\\s,]*(~@|[\\[\\]\\{\\}\\(\\)'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\\s\\[\\]\\{\\}\\('\"`,;\\)]*)" + re <- "[\\s,]*(~@|[\\[\\]\\{\\}\\(\\)'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]\\{\\}\\('\"`,;\\)]*)" m <- lapply(regmatches(str, gregexpr(re, str, perl=TRUE)), function(e) sub("^[\\s,]+", "", e, perl=TRUE)) res <- list() @@ -43,6 +43,9 @@ read_atom <- function(rdr) { } else if (re_match("^-?[0-9][0-9.]*$", token)) { as.double(token) } else if (substr(token,1,1) == "\"") { + if (substr(token, nchar(token), nchar(token)) != "\"") { + throw("expected '\"', got EOF") + } gsub("\x7f", "\\\\", gsub("\\\\n", "\n", gsub("\\\\\"", "\"", diff --git a/racket/reader.rkt b/racket/reader.rkt index 1e7f5fa779..93e49ef449 100644 --- a/racket/reader.rkt +++ b/racket/reader.rkt @@ -22,7 +22,7 @@ (define (tokenize str) (filter-not (lambda (s) (or (equal? s "") (equal? (substring s 0 1) ";"))) - (regexp-match* #px"[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)" + (regexp-match* #px"[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)" str #:match-select cadr))) (define (read_atom rdr) @@ -33,6 +33,8 @@ (string->number token)] [(regexp-match #px"^\".*\"$" token) (with-input-from-string token read)] + [(regexp-match #px"^\".*$" token) + (raise "expected '\"', got EOF")] [(regexp-match #px"^:" token) (_keyword (substring token 1))] [(equal? "nil" token) nil] [(equal? "true" token) #t] diff --git a/rexx/reader.rexx b/rexx/reader.rexx index 619e034a89..9443865e4a 100644 --- a/rexx/reader.rexx +++ b/rexx/reader.rexx @@ -114,7 +114,13 @@ read_atom: procedure expose values. tokens. pos /* read_atom() */ when token == "true" then return new_true() when token == "false" then return new_false() when substr(token, 1, 1) == ':' then return new_keyword(parse_keyword(token)) - when substr(token, 1, 1) == '"' then return new_string(parse_string(token)) + when substr(token, 1, 1) == '"' then do + if substr(token, length(token), 1) \== '"' then do + err = "expected '" || end_char || "', got EOF" + return "ERR" + end + return new_string(parse_string(token)) + end otherwise return new_symbol(token) end diff --git a/rpython/reader.py b/rpython/reader.py index 4f5e3b4d8e..b9208be20d 100644 --- a/rpython/reader.py +++ b/rpython/reader.py @@ -28,7 +28,7 @@ def peek(self): return None def tokenize(str): - re_str = "[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"|;.*|[^\s\[\]{}()'\"`@,;]+)" + re_str = "[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)" if IS_RPYTHON: tok_re = re_str else: @@ -47,8 +47,10 @@ def read_atom(reader): ## elif re.match(float_re, token): return int(token) elif token[0] == '"': end = len(token)-1 - if end < 2: + if end == 1: return MalStr(u"") + elif end < 1 or token[end] != '"': + types.throw_str("expected '\"', got EOF") else: s = unicode(token[1:end]) s = types._replace(u'\\\\', u"\u029e", s) diff --git a/ruby/reader.rb b/ruby/reader.rb index 446f7ae5d7..34d9fbe608 100644 --- a/ruby/reader.rb +++ b/ruby/reader.rb @@ -16,7 +16,7 @@ def next def tokenize(str) - re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/ + re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ return str.scan(re).map{|m| m[0]}.select{ |t| t != "" && t[0..0] != ";" } @@ -32,6 +32,7 @@ def read_atom(rdr) when /^-?[0-9]+$/ then token.to_i # integer when /^-?[0-9][0-9.]*$/ then token.to_f # float when /^".*"$/ then parse_str(token) # string + when /^".*$/ then raise "expected '\"', got EOF" when /^:/ then "\u029e" + token[1..-1] # keyword when "nil" then nil when "true" then true diff --git a/scala/reader.scala b/scala/reader.scala index 891e677c03..cbd9ec52e4 100644 --- a/scala/reader.scala +++ b/scala/reader.scala @@ -19,7 +19,7 @@ object reader { } def tokenize(str: String): Array[String] = { - val re = """[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)""".r + val re = """[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)""".r re.findAllMatchIn(str).map{ _.group(1) } .filter{ s => s != "" && s(0) != ';' } .toArray @@ -38,11 +38,14 @@ object reader { val re_int = """^(-?[0-9]+)$""".r val re_flt = """^(-?[0-9][0-9.]*)$""".r val re_str = """^"(.*)"$""".r + val re_str_bad = """^"(.*)$""".r val re_key = """^:(.*)$""".r return token match { case re_int(i) => i.toLong // integer case re_flt(f) => f.toDouble // float case re_str(s) => parse_str(s) // string + case re_str_bad(s) => + throw new Exception("expected '\"', got EOF") case re_key(k) => "\u029e" + k // keyword case "nil" => null case "true" => true diff --git a/skew/reader.sk b/skew/reader.sk index 0aa723ba27..f383fdb9cd 100644 --- a/skew/reader.sk +++ b/skew/reader.sk @@ -17,7 +17,7 @@ class Reader { } def tokenize(str string) List { - var re = RegExp.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\\s\\[\\]{}('\"`,;)]*)", "g") + var re = RegExp.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)", "g") var tokens List = [] var match string while (match = re.exec(str)[1]) != "" { diff --git a/swift/reader.swift b/swift/reader.swift index 195cfe36b4..9e4cadf75e 100644 --- a/swift/reader.swift +++ b/swift/reader.swift @@ -14,7 +14,7 @@ private let token_pattern = "|" + "[\\[\\]{}()`'~^@]" + // Punctuation: Any one of []{}()`'~^@ "|" + - "\"(?:\\\\.|[^\\\\\"])*\"" + // Quoted string: characters other than \ or ", or any escaped characters + "\"(?:\\\\.|[^\\\\\"])*\"?" + // Quoted string: characters other than \ or ", or any escaped characters "|" + ";.*" + // Comment: semicolon followed by anything "|" + @@ -36,6 +36,8 @@ private let atom_pattern = "|" + "(^\".*\"$)" + // String "|" + + "(^\".*$)" + // Invalid/unclosed string + "|" + "(:.*)" + // Keyword "|" + "(^[^\"]*$)" // Symbol @@ -112,9 +114,11 @@ private func read_atom(token: String) throws -> MalVal { return make_false() } else if have_match(match, at_index: 7) { // String return make_string(unescape(token)) - } else if have_match(match, at_index: 8) { // Keyword + } else if have_match(match, at_index: 8) { // Invalid/unclosed string + try throw_error("expected '\"', got EOF") + } else if have_match(match, at_index: 9) { // Keyword return make_keyword(token[token.startIndex.successor() ..< token.endIndex]) - } else if have_match(match, at_index: 9) { // Symbol + } else if have_match(match, at_index: 10) { // Symbol return make_symbol(token) } } diff --git a/swift3/Sources/reader.swift b/swift3/Sources/reader.swift index 66cef2d3a2..f729dd6c8b 100644 --- a/swift3/Sources/reader.swift +++ b/swift3/Sources/reader.swift @@ -74,7 +74,7 @@ func read_string(_ rdr: Reader) throws -> MalVal { if rdr.str[cidx] == "\"" { break } cidx = rdr.pos } - if rdr.pos > rdr.str.endIndex { + if rdr.str[rdr.str.index(before: rdr.pos)] != "\"" { throw MalError.Reader(msg: "Expected '\"', got EOF") } let matchStr = rdr.str.substring(with: diff --git a/tcl/reader.tcl b/tcl/reader.tcl index b5b4a6f297..ee7a7ec4f5 100644 --- a/tcl/reader.tcl +++ b/tcl/reader.tcl @@ -18,7 +18,7 @@ oo::class create Reader { } proc tokenize str { - set re {[\s,]*(~@|[\[\]\{\}()'`~^@]|\"(?:\\.|[^\\\"])*\"|;.*|[^\s\[\]\{\}('\"`~^@,;)]*)} + set re {[\s,]*(~@|[\[\]\{\}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;.*|[^\s\[\]\{\}('\"`~^@,;)]*)} set tokens {} foreach {_ capture} [regexp -line -all -inline $re $str] { if {[string length $capture] > 0 && [string range $capture 0 0] != ";"} { @@ -84,6 +84,7 @@ proc read_atom {reader} { ^false$ { return $::mal_false } ^: { return [keyword_new [parse_keyword $token]] } ^\".*\"$ { return [string_new [parse_string $token]] } + ^\".*$ { error "expected '\"', got EOF" } default { return [symbol_new $token] } } } diff --git a/tests/step1_read_print.mal b/tests/step1_read_print.mal index 266b016033..a40e9dba19 100644 --- a/tests/step1_read_print.mal +++ b/tests/step1_read_print.mal @@ -82,11 +82,11 @@ false ;;; These should throw some error with no return value "abc -;/.+ +;/.*(EOF|end of input|unbalanced).* (1 "abc -;/.+ +;/.*(EOF|end of input|unbalanced).* (1 "abc" -;/.+ +;/.*(EOF|end of input|unbalanced).* ;; Testing read of quoting '1 diff --git a/ts/reader.ts b/ts/reader.ts index 6a900ab09f..107823e8db 100644 --- a/ts/reader.ts +++ b/ts/reader.ts @@ -23,7 +23,7 @@ export function readStr(input: string): MalType { } function tokenizer(input: string): string[] { - const regexp = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g; + const regexp = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; const tokens: string[] = []; while (true) { const matches = regexp.exec(input); @@ -123,6 +123,9 @@ function readAtom(reader: Reader): MalType { return new MalNumber(v); } if (token[0] === '"') { + if (token.slice(-1) !== '"') { + throw new Error("expected '\"', got EOF"); + } const v = token.slice(1, token.length - 1) .replace(/\\(.)/g, (_, c: string) => c == 'n' ? '\n' : c) return new MalString(v); diff --git a/vb/reader.vb b/vb/reader.vb index 89b2c64e1b..b0a56fac91 100644 --- a/vb/reader.vb +++ b/vb/reader.vb @@ -48,7 +48,7 @@ Namespace Mal Shared Function tokenize(str As String) As List(Of String) Dim tokens As New List(Of String) - Dim pattern As String = "[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""|;.*|[^\s \[\]{}()'""`~@,;]*)" + Dim pattern As String = "[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""?|;.*|[^\s \[\]{}()'""`~@,;]*)" Dim regex As New Regex(pattern) For Each match As Match In regex.Matches(str) Dim token As String = match.Groups(1).Value @@ -64,7 +64,7 @@ Namespace Mal Shared Function read_atom(rdr As Reader) As MalVal Dim token As String = rdr.get_next() - Dim pattern As String = "(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^("".*"")$|^:(.*)|(^[^""]*$)" + Dim pattern As String = "(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^("".*)|^:(.*)|(^[^""]*$)" Dim regex As Regex = New Regex(pattern) Dim match As Match = regex.Match(token) 'Console.WriteLine("token: ^" + token + "$") @@ -81,6 +81,9 @@ Namespace Mal return Mal.types.MalFalse Else If match.Groups(6).Value <> String.Empty Then Dim str As String = match.Groups(6).Value + If str(str.Length-1) <> """" Then + throw New ParseError("expected '""', got EOF") + End If return New Mal.types.MalString( str.Substring(1, str.Length-2) _ .Replace("\\", ChrW(&H029e)) _ diff --git a/vhdl/reader.vhdl b/vhdl/reader.vhdl index b19788411a..d4f7e2b02e 100644 --- a/vhdl/reader.vhdl +++ b/vhdl/reader.vhdl @@ -191,7 +191,7 @@ package body reader is deallocate(s); end procedure unescape_string_token; - procedure read_atom(r: inout reader_class; result: out mal_val_ptr) is + procedure read_atom(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is variable token, s: line; variable num: integer; variable ch: character; @@ -221,6 +221,11 @@ package body reader is s(1 to s'length) := token(2 to token'length); new_keyword(s, result); when '"' => + if token(token'length) /= '"' then + new_string("expected '""', got EOF", err); + result := null; + return; + end if; unescape_string_token(token, s); new_string(s, result); when others => @@ -328,7 +333,7 @@ package body reader is when ']' => new_string("unexcepted ']'", err); when '{' => read_sequence(mal_hashmap, "}", r, result, err); when '}' => new_string("unexcepted '}'", err); - when others => read_atom(r, result); + when others => read_atom(r, result, err); end case; end procedure read_form; diff --git a/wasm/reader.wam b/wasm/reader.wam index 0a46736535..548cacf85d 100644 --- a/wasm/reader.wam +++ b/wasm/reader.wam @@ -253,7 +253,7 @@ (local.set $slen ($strlen (i32.add $tok 1))) (if (i32.ne (i32.load8_u (i32.add $tok $slen)) (CHR "\"")) (then - ($THROW_STR_0 "expected '\"'") + ($THROW_STR_0 "expected '\"', got EOF") (return 0)) (else ;; unescape backslashes, quotes, and newlines diff --git a/yorick/reader.i b/yorick/reader.i index 6da51d4041..571192e202 100644 --- a/yorick/reader.i +++ b/yorick/reader.i @@ -1,7 +1,7 @@ #include "yeti_regex.i" require, "types.i" -TOKENIZER_REGEXP = regcomp("[[:space:],]*(~@|[][{}()'`~@]|\"([\\].|[^\\\"])*\"|;.*|[^][[:space:]{}()'\"`~@,;]*)", newline=1) +TOKENIZER_REGEXP = regcomp("[[:space:],]*(~@|[][{}()'`~@]|\"([\\].|[^\\\"])*\"?|;.*|[^][[:space:]{}()'\"`~@,;]*)", newline=1) func tokenize(str) { @@ -45,6 +45,8 @@ func reader_next(rdr) } NUMBER_REGEXP = regcomp("^-?[0-9]+$") +STR_REGEXP = regcomp("^\".*\"$") +STR_BAD_REGEXP = regcomp("^\".*$") func unescape(s) { @@ -62,7 +64,8 @@ func read_atom(rdr) else if (token == "true") return MAL_TRUE else if (token == "false") return MAL_FALSE else if (regmatch(NUMBER_REGEXP, token)) return MalNumber(val=tonum(token)) - else if (strpart(token, 1:1) == "\"") return MalString(val=unescape(token)) + else if (regmatch(STR_REGEXP, token)) return MalString(val=unescape(token)) + else if (regmatch(STR_BAD_REGEXP, token)) return MalError(message=("expected '\"', got EOF")) else if (strpart(token, 1:1) == ":") return MalKeyword(val=strpart(token, 2:)) else return MalSymbol(val=token) } From 08f92c5ae9f477019849195e6937b591d3d3f6d5 Mon Sep 17 00:00:00 2001 From: Andrea Crotti Date: Sun, 27 Jan 2019 18:21:57 +0000 Subject: [PATCH 0432/1998] upgrade clojure and tools.reader --- clojure/project.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/clojure/project.clj b/clojure/project.clj index 5bb5f960d0..a675e2cc1e 100644 --- a/clojure/project.clj +++ b/clojure/project.clj @@ -1,8 +1,8 @@ (defproject mal "0.0.1-SNAPSHOT" :description "Make-A-Lisp" - :dependencies [[org.clojure/clojure "1.9.0"] - [org.clojure/tools.reader "0.8.3"] + :dependencies [[org.clojure/clojure "1.10.0"] + [org.clojure/tools.reader "1.3.2"] [net.n01se/clojure-jna "1.0.0"]] ;; To run a step with correct readline behavior: From 18f0ec21509231d6aa72af39149c28bd07ade057 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 10:27:41 -0600 Subject: [PATCH 0433/1998] Runtest should fail on bad test data. Fix interop tests. The interop tests weren't updated when regex support was added to runtest for matching output data. This was causing a bunch of implementations to silently fail while testing interop. Fix runtest.py to fail on bad test data and fix 21 implementations with the old style output matches. --- bash/tests/stepA_mal.mal | 2 +- clojure/tests/stepA_mal.mal | 4 ++-- coffee/tests/stepA_mal.mal | 2 +- elisp/tests/stepA_mal.mal | 2 +- fantom/tests/stepA_mal.mal | 2 +- forth/tests/stepA_mal.mal | 16 ++++++++-------- gnu-smalltalk/tests/stepA_mal.mal | 2 +- io/tests/stepA_mal.mal | 2 +- js/tests/stepA_mal.mal | 4 ++-- logo/tests/stepA_mal.mal | 2 +- lua/tests/stepA_mal.mal | 2 +- make/tests/stepA_mal.mal | 2 +- perl/tests/stepA_mal.mal | 2 +- perl6/tests/stepA_mal.mal | 2 +- php/tests/stepA_mal.mal | 2 +- python/tests/stepA_mal.mal | 2 +- rexx/tests/stepA_mal.mal | 2 +- ruby/tests/stepA_mal.mal | 2 +- runtest.py | 3 +-- scheme/tests/stepA_mal.mal | 5 +++-- tcl/tests/stepA_mal.mal | 2 +- yorick/tests/stepA_mal.mal | 2 +- 22 files changed, 33 insertions(+), 33 deletions(-) diff --git a/bash/tests/stepA_mal.mal b/bash/tests/stepA_mal.mal index bf3eabdb23..c121efa9bd 100644 --- a/bash/tests/stepA_mal.mal +++ b/bash/tests/stepA_mal.mal @@ -4,7 +4,7 @@ ;=>"7" (sh* "echo >&2 hello") -; hello +;/hello ;=>"" (sh* "foo=8; echo ${foo}") diff --git a/clojure/tests/stepA_mal.mal b/clojure/tests/stepA_mal.mal index 4c7ec359f8..d77c8a24d3 100644 --- a/clojure/tests/stepA_mal.mal +++ b/clojure/tests/stepA_mal.mal @@ -13,10 +13,10 @@ ;=>{"abc" 123} (if clj (clj* "(prn \"foo\")") (js* "console.log('\"foo\"')")) -; "foo" +;/"foo" ;=>nil -(if clj (clj* "(for [x [1 2 3]] (+ 1 x))") '(2 3 4)) +(if clj (clj* "(apply list (for [x [1 2 3]] (+ 1 x)))") '(2 3 4)) ;=>(2 3 4) (if cljs (js* "[1,2,3].map(function(x) {return 1+x})") [2 3 4]) ;=>[2 3 4] diff --git a/coffee/tests/stepA_mal.mal b/coffee/tests/stepA_mal.mal index f785292d48..86699978dd 100644 --- a/coffee/tests/stepA_mal.mal +++ b/coffee/tests/stepA_mal.mal @@ -10,7 +10,7 @@ ;=>(7 8 9) (js* "console.log('hello');") -; hello +;/hello ;=>nil (js* "foo=8;") diff --git a/elisp/tests/stepA_mal.mal b/elisp/tests/stepA_mal.mal index 8f6e9a3b73..c655af6aa7 100644 --- a/elisp/tests/stepA_mal.mal +++ b/elisp/tests/stepA_mal.mal @@ -13,7 +13,7 @@ ;=>(1 2 3) (elisp-eval "(progn (princ \"Hello World!\n\") nil)") -; Hello World! +;/Hello World! ;=>nil (elisp-eval "(setq emacs-version-re (rx (+ digit) \".\" digit \".\" digit))") diff --git a/fantom/tests/stepA_mal.mal b/fantom/tests/stepA_mal.mal index a8c37d819d..29739c3ebb 100644 --- a/fantom/tests/stepA_mal.mal +++ b/fantom/tests/stepA_mal.mal @@ -19,7 +19,7 @@ ;=>{"abc" 789} (fantom-eval "echo(\"hello\")") -; hello +;/hello ;=>nil (fantom-eval "[\"a\",\"b\",\"c\"].join(\" \") { \"X${it}Y\" }") diff --git a/forth/tests/stepA_mal.mal b/forth/tests/stepA_mal.mal index c4a0e75613..3d8db0565b 100644 --- a/forth/tests/stepA_mal.mal +++ b/forth/tests/stepA_mal.mal @@ -6,7 +6,7 @@ (. "greetings" 'MalString.) ;=>"greetings" (. "hello" 'type 'cr 'mal-nil) -; hello +;/hello ;=>nil ;; Interop on non-literals @@ -31,11 +31,11 @@ ;=>7 (def! prn-chars (fn* (start count) (if (> count 0) (do (prn (. start 1 'MalString.)) (prn-chars (+ start 1) (- count 1)))))) (let* (msg (string-parts "sketchy")) (prn-chars (first msg) (first (rest msg)))) -; "s" -; "k" -; "e" -; "t" -; "c" -; "h" -; "y" +;/"s" +;/"k" +;/"e" +;/"t" +;/"c" +;/"h" +;/"y" ;=>nil diff --git a/gnu-smalltalk/tests/stepA_mal.mal b/gnu-smalltalk/tests/stepA_mal.mal index 32221a4580..f8ff39f8f6 100644 --- a/gnu-smalltalk/tests/stepA_mal.mal +++ b/gnu-smalltalk/tests/stepA_mal.mal @@ -8,4 +8,4 @@ ;=>"a b c" (gst-eval "'Hello World!' displayNl") -; Hello World! +;/Hello World! diff --git a/io/tests/stepA_mal.mal b/io/tests/stepA_mal.mal index 4a07a602ef..5b0f5dcdd3 100644 --- a/io/tests/stepA_mal.mal +++ b/io/tests/stepA_mal.mal @@ -19,7 +19,7 @@ ;=>{"abc" 789} (io-eval "\"hello\" println") -; hello +;/hello ;=>"hello" (io-eval "Lobby foo := 8") diff --git a/js/tests/stepA_mal.mal b/js/tests/stepA_mal.mal index 4502bfff26..54127682d9 100644 --- a/js/tests/stepA_mal.mal +++ b/js/tests/stepA_mal.mal @@ -10,7 +10,7 @@ ;=>(7 8 9) (js-eval "console.log('hello');") -; hello +;/hello ;=>nil (js-eval "foo=8;") @@ -27,7 +27,7 @@ ;=>60 (. "console.log" "abc" 123 '(4 5 6) {"kk" "vv"} (= 1 1) nil) -; abc 123 \[ 4, 5, 6 \] \{ kk: 'vv' \} true null +;/abc 123 \[ 4, 5, 6 \] \{ kk: 'vv' \} true null ;=>nil (js-eval "myobj = { v: 10, myfunc: function(a,b,c) { return a * b * c * this.v; } }") diff --git a/logo/tests/stepA_mal.mal b/logo/tests/stepA_mal.mal index 904b7db3bf..9175626d1f 100644 --- a/logo/tests/stepA_mal.mal +++ b/logo/tests/stepA_mal.mal @@ -16,7 +16,7 @@ ;=>false (logo-eval "print [hello world]") -; hello world +;/hello world ;=>nil (logo-eval "make \"foo 8") diff --git a/lua/tests/stepA_mal.mal b/lua/tests/stepA_mal.mal index b52a902ae3..70a142315d 100644 --- a/lua/tests/stepA_mal.mal +++ b/lua/tests/stepA_mal.mal @@ -24,7 +24,7 @@ ;=>{"abc" 789} (lua-eval "print('hello')") -; hello +;/hello ;=>nil (lua-eval "(function() foo = 8 end)()") diff --git a/make/tests/stepA_mal.mal b/make/tests/stepA_mal.mal index 768a9293c1..ed5551cacf 100644 --- a/make/tests/stepA_mal.mal +++ b/make/tests/stepA_mal.mal @@ -4,7 +4,7 @@ ;=>"7" (make* "$(info foo)") -; foo +;/foo ;=>"" (make* "$(eval foo := 8)") diff --git a/perl/tests/stepA_mal.mal b/perl/tests/stepA_mal.mal index 1335be4021..7f5abe79b7 100644 --- a/perl/tests/stepA_mal.mal +++ b/perl/tests/stepA_mal.mal @@ -18,5 +18,5 @@ ;; Testing eval of print statement (pl* "print 'hello\n';") -; hello +;/hello ;=>1 diff --git a/perl6/tests/stepA_mal.mal b/perl6/tests/stepA_mal.mal index a1b4a38a72..0a586b4c20 100644 --- a/perl6/tests/stepA_mal.mal +++ b/perl6/tests/stepA_mal.mal @@ -34,7 +34,7 @@ ;=>nil (perl6-eval "say 'hello' ") -; hello +;/hello ;=>true (perl6-eval "sub { my $foo = 8 }()") diff --git a/php/tests/stepA_mal.mal b/php/tests/stepA_mal.mal index 80d9a0bdec..de459cdbcf 100644 --- a/php/tests/stepA_mal.mal +++ b/php/tests/stepA_mal.mal @@ -13,7 +13,7 @@ ;=>{"abc" 789} (php* "print \"hello\n\";") -; hello +;/hello ;=>nil (php* "global $foo; $foo=8;") diff --git a/python/tests/stepA_mal.mal b/python/tests/stepA_mal.mal index dfe05106e9..79851922a7 100644 --- a/python/tests/stepA_mal.mal +++ b/python/tests/stepA_mal.mal @@ -14,7 +14,7 @@ ;; Testing Python statements (py!* "print('hello')") -; hello +;/hello ;=>nil (py!* "foo = 19 % 4") diff --git a/rexx/tests/stepA_mal.mal b/rexx/tests/stepA_mal.mal index cc05df486b..21a3f86050 100644 --- a/rexx/tests/stepA_mal.mal +++ b/rexx/tests/stepA_mal.mal @@ -13,7 +13,7 @@ ;=>"FE" (rexx-eval "say 'hello' 12.34 upper('rexx')" nil) -; hello 12.34 REXX +;/hello 12.34 REXX ;=>nil (rexx-eval "foo = 8" "foo + 3") diff --git a/ruby/tests/stepA_mal.mal b/ruby/tests/stepA_mal.mal index 2d7efb8147..79cca1984b 100644 --- a/ruby/tests/stepA_mal.mal +++ b/ruby/tests/stepA_mal.mal @@ -13,7 +13,7 @@ ;=>{"abc" 789} (rb* "print 'hello\n'") -; hello +;/hello ;=>nil (rb* "$foo=8;") diff --git a/runtest.py b/runtest.py index 8953a10756..f8779c754b 100755 --- a/runtest.py +++ b/runtest.py @@ -204,8 +204,7 @@ def next(self): return True continue elif line[0:1] == ";": # unexpected comment - log("Test data error at line %d:\n%s" % (self.line_num, line)) - return None + raise Exception("Test data error at line %d:\n%s" % (self.line_num, line)) self.form = line # the line is a form to send # Now find the output and return value diff --git a/scheme/tests/stepA_mal.mal b/scheme/tests/stepA_mal.mal index 85eb6f06ad..4ba3b9fab0 100644 --- a/scheme/tests/stepA_mal.mal +++ b/scheme/tests/stepA_mal.mal @@ -3,8 +3,9 @@ (scm-eval "(+ 1 1)") ;=>2 -(scm-eval "(begin (display \"Hello World!\") (newline))") -; "Hello World!" +(scm-eval "(begin (display \"Hello World!\") (newline) 7)") +;/Hello World! +;=>7 (scm-eval "(string->list \"MAL\")") ;=>("M" "A" "L") diff --git a/tcl/tests/stepA_mal.mal b/tcl/tests/stepA_mal.mal index 57bdd18378..a53ddab71d 100644 --- a/tcl/tests/stepA_mal.mal +++ b/tcl/tests/stepA_mal.mal @@ -13,7 +13,7 @@ ;=>"a b c d e f g" (tcl* "puts \"hello [expr {5 + 6}] world\"") -; hello 11 world +;/hello 11 world ;=>"" (tcl* "set ::foo 8") diff --git a/yorick/tests/stepA_mal.mal b/yorick/tests/stepA_mal.mal index 8c2229a12d..76bc44ea18 100644 --- a/yorick/tests/stepA_mal.mal +++ b/yorick/tests/stepA_mal.mal @@ -16,7 +16,7 @@ ;=>(7 8 9) (yorick-eval "write, format=\"%s-%d\\x0A\", \"hello\", 1234; return nil;") -; hello-1234 +;/hello-1234 ;=>nil (yorick-eval "extern my_global_var; my_global_var = 8; return nil;") From fdcb98b148693a0a4ce01b3988d46718cc99c79e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 11:52:14 -0600 Subject: [PATCH 0434/1998] clojure: tools.reader dep no longer necessary. --- clojure/project.clj | 1 - 1 file changed, 1 deletion(-) diff --git a/clojure/project.clj b/clojure/project.clj index a675e2cc1e..8f5c61b5a8 100644 --- a/clojure/project.clj +++ b/clojure/project.clj @@ -2,7 +2,6 @@ :description "Make-A-Lisp" :dependencies [[org.clojure/clojure "1.10.0"] - [org.clojure/tools.reader "1.3.2"] [net.n01se/clojure-jna "1.0.0"]] ;; To run a step with correct readline behavior: From a68c26aff8f72532f9105c9752426ff61be122ac Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 13:31:28 -0600 Subject: [PATCH 0435/1998] lua: update to version 5.2 - Update to support the new behavior of varargs and table.pack/unpack in lua 5.2 - Bump up the stack overflow test since lua 5.2 seems to support much larger stacks before overflow. - Fix a latent issue in if forms where false in the 4th position would result in nil returned. Add a new test to catch this in the future. --- lua/Dockerfile | 4 ++-- lua/core.lua | 29 ++++++++++++++++++----------- lua/reader.lua | 2 +- lua/step2_eval.lua | 2 +- lua/step3_env.lua | 2 +- lua/step4_if_fn_do.lua | 6 +++--- lua/step5_tco.lua | 6 +++--- lua/step6_file.lua | 6 +++--- lua/step7_quote.lua | 6 +++--- lua/step8_macros.lua | 8 ++++---- lua/step9_try.lua | 8 ++++---- lua/stepA_mal.lua | 9 +++++---- lua/tests/step5_tco.mal | 2 +- lua/types.lua | 4 +++- tests/step4_if_fn_do.mal | 2 ++ 15 files changed, 54 insertions(+), 42 deletions(-) diff --git a/lua/Dockerfile b/lua/Dockerfile index f7bc915f29..e93a1d0ec0 100644 --- a/lua/Dockerfile +++ b/lua/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:vivid +FROM ubuntu:18.04 MAINTAINER Joel Martin ########################################################## @@ -22,7 +22,7 @@ WORKDIR /mal ########################################################## # Lua -RUN apt-get -y install lua5.1 lua-rex-pcre luarocks +RUN apt-get -y install lua5.2 liblua5.2-dev lua-rex-pcre luarocks RUN luarocks install linenoise RUN luarocks install luasocket diff --git a/lua/core.lua b/lua/core.lua index 8c8d2c54ec..dbbb9cd1f9 100644 --- a/lua/core.lua +++ b/lua/core.lua @@ -13,24 +13,28 @@ local M = {} function pr_str(...) return table.concat( - utils.map(function(e) return _pr_str(e, true) end, arg), " ") + utils.map(function(e) return _pr_str(e, true) end, + table.pack(...)), " ") end function str(...) return table.concat( - utils.map(function(e) return _pr_str(e, false) end, arg), "") + utils.map(function(e) return _pr_str(e, false) end, + table.pack(...)), "") end function prn(...) print(table.concat( - utils.map(function(e) return _pr_str(e, true) end, arg), " ")) + utils.map(function(e) return _pr_str(e, true) end, + table.pack(...)), " ")) io.flush() return Nil end function println(...) print(table.concat( - utils.map(function(e) return _pr_str(e, false) end, arg), " ")) + utils.map(function(e) return _pr_str(e, false) end, + table.pack(...)), " ")) io.flush() return Nil end @@ -55,11 +59,11 @@ end -- hash map functions function assoc(hm, ...) - return types._assoc_BANG(types.copy(hm), unpack(arg)) + return types._assoc_BANG(types.copy(hm), ...) end function dissoc(hm, ...) - return types._dissoc_BANG(types.copy(hm), unpack(arg)) + return types._dissoc_BANG(types.copy(hm), ...) end function get(hm, key) @@ -93,6 +97,7 @@ function cons(a,lst) end function concat(...) + local arg = table.pack(...) local new_lst = {} for i = 1, #arg do for j = 1, #arg[i] do @@ -127,12 +132,13 @@ function rest(a) end function apply(f, ...) + local arg = table.pack(...) if types._malfunc_Q(f) then f = f.fn end local args = concat(types.slice(arg, 1, #arg-1), arg[#arg]) - return f(unpack(args)) + return f(table.unpack(args)) end function map(f, lst) @@ -162,13 +168,14 @@ function swap_BANG(atm,f,...) if types._malfunc_Q(f) then f = f.fn end - local args = List:new(arg) + local args = List:new(table.pack(...)) table.insert(args, 1, atm.val) - atm.val = f(unpack(args)) + atm.val = f(table.unpack(args)) return atm.val end local function conj(obj, ...) + local arg = table.pack(...) local new_obj = types.copy(obj) if types._list_Q(new_obj) then for i, v in ipairs(arg) do @@ -267,9 +274,9 @@ M.ns = { ['/'] = function(a,b) return math.floor(a/b) end, ['time-ms'] = function() return math.floor(socket.gettime() * 1000) end, - list = function(...) return List:new(arg) end, + list = function(...) return List:new(table.pack(...)) end, ['list?'] = function(a) return types._list_Q(a) end, - vector = function(...) return types.Vector:new(arg) end, + vector = function(...) return types.Vector:new(table.pack(...)) end, ['vector?'] = types._vector_Q, ['hash-map'] = types.hash_map, ['map?'] = types._hash_map_Q, diff --git a/lua/reader.lua b/lua/reader.lua index 34e4239a74..9425c6c346 100644 --- a/lua/reader.lua +++ b/lua/reader.lua @@ -87,7 +87,7 @@ end function M.read_hash_map(rdr) local seq = M.read_sequence(rdr, '{', '}') - return types._assoc_BANG(types.HashMap:new(), unpack(seq)) + return types._assoc_BANG(types.HashMap:new(), table.unpack(seq)) end function M.read_form(rdr) diff --git a/lua/step2_eval.lua b/lua/step2_eval.lua index 0b095f2ce2..6c2fbc97c7 100755 --- a/lua/step2_eval.lua +++ b/lua/step2_eval.lua @@ -42,7 +42,7 @@ function EVAL(ast, env) if #ast == 0 then return ast end local args = eval_ast(ast, env) local f = table.remove(args, 1) - return f(unpack(args)) + return f(table.unpack(args)) end -- print diff --git a/lua/step3_env.lua b/lua/step3_env.lua index 24cdfc7459..1e3c0add5d 100755 --- a/lua/step3_env.lua +++ b/lua/step3_env.lua @@ -52,7 +52,7 @@ function EVAL(ast, env) else local args = eval_ast(ast, env) local f = table.remove(args, 1) - return f(unpack(args)) + return f(table.unpack(args)) end end diff --git a/lua/step4_if_fn_do.lua b/lua/step4_if_fn_do.lua index 46302d1b6f..9dae7ba0de 100755 --- a/lua/step4_if_fn_do.lua +++ b/lua/step4_if_fn_do.lua @@ -56,18 +56,18 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then return EVAL(a3, env) else return types.Nil end + if #ast > 3 then return EVAL(a3, env) else return types.Nil end else return EVAL(a2, env) end elseif 'fn*' == a0sym then return function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end else local args = eval_ast(ast, env) local f = table.remove(args, 1) - return f(unpack(args)) + return f(table.unpack(args)) end end diff --git a/lua/step5_tco.lua b/lua/step5_tco.lua index b3d77950fd..9c28e4e739 100755 --- a/lua/step5_tco.lua +++ b/lua/step5_tco.lua @@ -58,13 +58,13 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then ast = a3 else return types.Nil end -- TCO + if #ast > 3 then ast = a3 else return types.Nil end -- TCO else ast = a2 -- TCO end elseif 'fn*' == a0sym then return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end, a2, env, a1) else local args = eval_ast(ast, env) @@ -73,7 +73,7 @@ function EVAL(ast, env) ast = f.ast env = Env:new(f.env, f.params, args) -- TCO else - return f(unpack(args)) + return f(table.unpack(args)) end end end diff --git a/lua/step6_file.lua b/lua/step6_file.lua index 63d0208aa0..4a27a24a52 100755 --- a/lua/step6_file.lua +++ b/lua/step6_file.lua @@ -58,13 +58,13 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then ast = a3 else return types.Nil end -- TCO + if #ast > 3 then ast = a3 else return types.Nil end -- TCO else ast = a2 -- TCO end elseif 'fn*' == a0sym then return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end, a2, env, a1) else local args = eval_ast(ast, env) @@ -73,7 +73,7 @@ function EVAL(ast, env) ast = f.ast env = Env:new(f.env, f.params, args) -- TCO else - return f(unpack(args)) + return f(table.unpack(args)) end end end diff --git a/lua/step7_quote.lua b/lua/step7_quote.lua index e978d681c7..d014cc7353 100755 --- a/lua/step7_quote.lua +++ b/lua/step7_quote.lua @@ -84,13 +84,13 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then ast = a3 else return types.Nil end -- TCO + if #ast > 3 then ast = a3 else return types.Nil end -- TCO else ast = a2 -- TCO end elseif 'fn*' == a0sym then return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end, a2, env, a1) else local args = eval_ast(ast, env) @@ -99,7 +99,7 @@ function EVAL(ast, env) ast = f.ast env = Env:new(f.env, f.params, args) -- TCO else - return f(unpack(args)) + return f(table.unpack(args)) end end end diff --git a/lua/step8_macros.lua b/lua/step8_macros.lua index 800833cca8..33538154f9 100755 --- a/lua/step8_macros.lua +++ b/lua/step8_macros.lua @@ -51,7 +51,7 @@ end function macroexpand(ast, env) while is_macro_call(ast, env) do local mac = env:get(ast[1]) - ast = mac.fn(unpack(ast:slice(2))) + ast = mac.fn(table.unpack(ast:slice(2))) end return ast end @@ -111,13 +111,13 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then ast = a3 else return types.Nil end -- TCO + if #ast > 3 then ast = a3 else return types.Nil end -- TCO else ast = a2 -- TCO end elseif 'fn*' == a0sym then return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end, a2, env, a1) else local args = eval_ast(ast, env) @@ -126,7 +126,7 @@ function EVAL(ast, env) ast = f.ast env = Env:new(f.env, f.params, args) -- TCO else - return f(unpack(args)) + return f(table.unpack(args)) end end end diff --git a/lua/step9_try.lua b/lua/step9_try.lua index a7a1db8f76..2cb5817155 100755 --- a/lua/step9_try.lua +++ b/lua/step9_try.lua @@ -51,7 +51,7 @@ end function macroexpand(ast, env) while is_macro_call(ast, env) do local mac = env:get(ast[1]) - ast = mac.fn(unpack(ast:slice(2))) + ast = mac.fn(table.unpack(ast:slice(2))) end return ast end @@ -129,13 +129,13 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then ast = a3 else return types.Nil end -- TCO + if #ast > 3 then ast = a3 else return types.Nil end -- TCO else ast = a2 -- TCO end elseif 'fn*' == a0sym then return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end, a2, env, a1) else local args = eval_ast(ast, env) @@ -144,7 +144,7 @@ function EVAL(ast, env) ast = f.ast env = Env:new(f.env, f.params, args) -- TCO else - return f(unpack(args)) + return f(table.unpack(args)) end end end diff --git a/lua/stepA_mal.lua b/lua/stepA_mal.lua index 4dc5d571c6..00615560c9 100755 --- a/lua/stepA_mal.lua +++ b/lua/stepA_mal.lua @@ -2,6 +2,7 @@ local table = require('table') +package.path = '../lua/?.lua;' .. package.path local readline = require('readline') local utils = require('utils') local types = require('types') @@ -51,7 +52,7 @@ end function macroexpand(ast, env) while is_macro_call(ast, env) do local mac = env:get(ast[1]) - ast = mac.fn(unpack(ast:slice(2))) + ast = mac.fn(table.unpack(ast:slice(2))) end return ast end @@ -129,13 +130,13 @@ function EVAL(ast, env) elseif 'if' == a0sym then local cond = EVAL(a1, env) if cond == types.Nil or cond == false then - if a3 then ast = a3 else return types.Nil end -- TCO + if #ast > 3 then ast = a3 else return types.Nil end -- TCO else ast = a2 -- TCO end elseif 'fn*' == a0sym then return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, arg)) + return EVAL(a2, Env:new(env, a1, table.pack(...))) end, a2, env, a1) else local args = eval_ast(ast, env) @@ -144,7 +145,7 @@ function EVAL(ast, env) ast = f.ast env = Env:new(f.env, f.params, args) -- TCO else - return f(unpack(args)) + return f(table.unpack(args)) end end end diff --git a/lua/tests/step5_tco.mal b/lua/tests/step5_tco.mal index d20df25db7..087368335f 100644 --- a/lua/tests/step5_tco.mal +++ b/lua/tests/step5_tco.mal @@ -10,6 +10,6 @@ ;=>nil ;;; For implementations without their own TCO this should fail and ;;; leave res1 unchanged -(def! res1 (sum-to 10000)) +(def! res1 (sum-to 100000)) res1 ;=>nil diff --git a/lua/types.lua b/lua/types.lua index 62bc6a2fa9..44daa5196b 100644 --- a/lua/types.lua +++ b/lua/types.lua @@ -161,18 +161,20 @@ function M.HashMap:new(val) return setmetatable(newObj, self) end function M.hash_map(...) - return M._assoc_BANG(M.HashMap:new(), unpack(arg)) + return M._assoc_BANG(M.HashMap:new(), ...) end function M._hash_map_Q(obj) return utils.instanceOf(obj, M.HashMap) end function M._assoc_BANG(hm, ...) + local arg = table.pack(...) for i = 1, #arg, 2 do hm[arg[i]] = arg[i+1] end return hm end function M._dissoc_BANG(hm, ...) + local arg = table.pack(...) for i = 1, #arg do hm[arg[i]] = nil end diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal index 991b44b730..ba71e82811 100644 --- a/tests/step4_if_fn_do.mal +++ b/tests/step4_if_fn_do.mal @@ -29,6 +29,8 @@ ;=>7 (if false 7 8) ;=>8 +(if false 7 false) +;=>false (if true (+ 1 7) (+ 1 8)) ;=>8 (if false (+ 1 7) (+ 1 8)) From 45a714987cad211c5c60bffbe3f10672cf72b71e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 13:44:24 -0600 Subject: [PATCH 0436/1998] README: the tested version of lua is now 5.2. --- README.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 9b5f7a763c..5f4807afb9 100644 --- a/README.md +++ b/README.md @@ -606,8 +606,9 @@ logo stepX_YYY.lg ### Lua -Running the Lua implementation of mal requires lua 5.1 or later, -luarocks and the lua-rex-pcre library installed. +The Lua implementation of mal has been tested with Lua 5.2. The +implementation requires that luarocks and the lua-rex-pcre library +are installed. ``` cd lua From 07734c09319bda0ecc48396a609693fe98b39479 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 16:07:27 -0600 Subject: [PATCH 0437/1998] README: add external implementations section. Move the alternate rust implementations to this section and add a link to HolyC implementation. --- README.md | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 5f4807afb9..8e6076e640 100644 --- a/README.md +++ b/README.md @@ -895,11 +895,6 @@ cd rust cargo run --release --bin stepX_YYY ``` -Alternative out-of-tee Rust implementations: - -* [by Tim Morgan](https://github.com/seven1m/mal-rust). -* [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). - ### Scala ### Install scala and sbt (http://www.scala-sbt.org/0.13/tutorial/Installing-sbt-on-Linux.html): @@ -1239,6 +1234,21 @@ make "docker-build^IMPL" out. These dependencies are downloaded to dot-files in the /mal directory so they will persist between runs. + +## External Implementations + +The following implementations are maintained as separate projects: + +### HolyC + +* [by Alexander Bagnalla](https://github.com/bagnalla/holyc_mal) + +### Rust + +* [by Tim Morgan](https://github.com/seven1m/mal-rust) +* [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). + + ## Projects using mal * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. From 23e43428773e517561133f2d1ea0dc2402e907d4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 17:31:49 -0600 Subject: [PATCH 0438/1998] README: move creator info to first list. The creator information should be more prominent instead of hidden within the build/run instructions. --- README.md | 146 ++++++++++++++---------------------------------------- 1 file changed, 37 insertions(+), 109 deletions(-) diff --git a/README.md b/README.md index 8e6076e640..1e78d85a4f 100644 --- a/README.md +++ b/README.md @@ -8,57 +8,57 @@ Mal is a Clojure inspired Lisp interpreter. Mal is implemented in 74 languages: -* Ada -* GNU awk -* Bash shell +* Ada - *created by [Chris Moore](https://github.com/zmower)* +* GNU awk - *created by [Miutsuru Kariya](https://github.com/kariya-mitsuru)* +* Bash 4 * BASIC (C64 and QBasic) * C -* C++ +* C++ - *created by [Stephen Thirlwall](https://github.com/sdt)* * C# -* ChucK -* Common Lisp +* ChucK - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* Common Lisp - *created by [Iqbal Ansari](https://github.com/iqbalansari)* * Clojure (Clojure and ClojureScript) * CoffeeScript -* Crystal -* D -* Dart -* Elixir -* Elm -* Emacs Lisp -* Erlang +* Crystal - *created by [Linda_pp](https://github.com/rhysd)* +* D - *created by [Dov Murik](https://github.com/dubek)* +* Dart - *created by [Harry Terkelsen](https://github.com/hterkelsen)* +* Elixir - *created by [Martin Ek](https://github.com/ekmartin)* +* Elm - *created by [Jos van Bakel](https://github.com/c0deaddict)* +* Emacs Lisp - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* Erlang - *created by [Nathan Fiedler](https://github.com/nlfiedler)* * ES6 (ECMAScript 6 / ECMAScript 2015) -* F# -* Factor -* Fantom -* Forth +* F# - *created by [Peter Stephens](https://github.com/pstephens)* +* Factor - *created by [Jordan Lewis](https://github.com/jordanlewis)* +* Fantom - *created by [Dov Murik](https://github.com/dubek)* +* Forth - *created by [Chris Houser](https://github.com/chouser)* * Go * Groovy -* GNU Guile -* GNU Smalltalk +* GNU Guile - *created by [Mu Lei](https://github.com/NalaGinrut).* +* GNU Smalltalk - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* * Haskell * Haxe (Neko, Python, C++ and JavaScript) * Hy -* Io +* Io - *created by [Dov Murik](https://github.com/dubek)* * Java * JavaScript ([Online Demo](http://kanaka.github.io/mal)) * Julia -* Kotlin -* LiveScript -* Logo +* Kotlin - *created by [Javier Fernandez-Ivern](https://github.com/ivern)* +* LiveScript - *created by [Jos van Bakel](https://github.com/c0deaddict)* +* Logo - *created by [Dov Murik](https://github.com/dubek)* * Lua * GNU Make * mal itself * Matlab (GNU Octave and MATLAB) * [miniMAL](https://github.com/kanaka/miniMAL) -* NASM -* Nim +* NASM - *created by [Ben Dudson](https://github.com/bendudson)* +* Nim - *created by [Dennis Felsing](https://github.com/def-)* * Object Pascal * Objective C -* OCaml +* OCaml - *created by [Chris Houser](https://github.com/chouser)* * Perl -* Perl 6 +* Perl 6 - *created by [Hinrik Örn Sigurðsson](https://github.com/hinrik)* * PHP -* Picolisp +* Picolisp - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* * PL/pgSQL (Postgres) * PL/SQL (Oracle) * Postscript @@ -67,21 +67,21 @@ Mal is implemented in 74 languages: * RPython * R * Racket -* Rexx +* Rexx - *created by [Dov Murik](https://github.com/dubek)* * Ruby * Rust * Scala -* Scheme (R7RS) -* Skew -* Swift +* Scheme (R7RS) *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* Skew - *created by [Dov Murik](https://github.com/dubek)* +* Swift - *created by [Keith Rollin](https://github.com/keith-rollin)* * Swift 3 -* Tcl -* TypeScript -* VHDL -* Vimscript +* Tcl - *created by [Dov Murik](https://github.com/dubek)* +* TypeScript - *created by [Masahiro Wakame](https://github.com/vvakame)* +* VHDL - *created by [Dov Murik](https://github.com/dubek)* +* Vimscript - *created by [Dov Murik](https://github.com/dubek)* * Visual Basic.NET * WebAssembly (wasm) -* Yorick +* Yorick - *created by [Dov Murik](https://github.com/dubek)* Mal is a learning tool. See the [make-a-lisp process @@ -144,8 +144,6 @@ make DOCKERIZE=1 "repl^IMPL" ### Ada -*The Ada implementation was created by [Chris Moore](https://github.com/zmower)* - The Ada implementation was developed with GNAT 4.9 on debian. It also compiles unchanged on windows if you have windows versions of git, GNAT and (optionally) make. There are no external dependencies @@ -159,8 +157,6 @@ make ### GNU awk -*The GNU awk implementation was created by [Miutsuru kariya](https://github.com/kariya-mitsuru)* - The GNU awk implementation of mal has been tested with GNU awk 4.1.1. ``` @@ -218,8 +214,6 @@ make ### C++ -*The C++ implementation was created by [Stephen Thirlwall (sdt)](https://github.com/sdt)* - The C++ implementation of mal requires g++-4.9 or clang++-3.5 and a readline compatible library to build. See the `cpp/README.md` for more details: @@ -247,8 +241,6 @@ mono ./stepX_YYY.exe ### ChucK -*The ChucK implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* - The ChucK implementation has been tested with ChucK 1.3.5.2. ``` @@ -258,8 +250,6 @@ cd chuck ### Common Lisp -*The Common Lisp implementation was created by [Iqbal Ansari](https://github.com/iqbalansari)* - The implementation has been tested with SBCL, CCL, CMUCL, GNU CLISP, ECL and Allegro CL on Ubuntu 16.04 and Ubuntu 12.04, see the [README](common-lisp/README.org) for more details. Provided you have the @@ -291,8 +281,6 @@ coffee ./stepX_YYY ### Crystal -*The Crystal implementation of mal was created by [Linda_pp](https://github.com/rhysd)* - The Crystal implementation of mal has been tested with Crystal 0.26.1. ``` @@ -305,8 +293,6 @@ make # needed to run tests ### D -*The D implementation was created by [Dov Murik](https://github.com/dubek)* - The D implementation of mal was tested with GDC 4.8. It requires the GNU readline library. @@ -318,8 +304,6 @@ make ### Dart -*The Dart implementation was created by [Harry Terkelsen](https://github.com/hterkelsen)* - The Dart implementation has been tested with Dart 1.20. ``` @@ -329,8 +313,6 @@ dart ./stepX_YYY ### Emacs Lisp -*The Emacs Lisp implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* - The Emacs Lisp implementation of mal has been tested with Emacs 24.3 and 24.5. While there is very basic readline editing (`` and `C-d` work, `C-c` cancels the process), it is recommended to use @@ -345,8 +327,6 @@ rlwrap emacs -Q --batch --load stepX_YYY.el ### Elixir -*The Elixir implementation was created by [Martin Ek (ekmartin)](https://github.com/ekmartin)* - The Elixir implementation of mal has been tested with Elixir 1.0.5. ``` @@ -358,8 +338,6 @@ iex -S mix stepX_YYY ### Elm -*The Elm implementation was created by [Jos van Bakel](https://github.com/c0deaddict)* - The Elm implementation of mal has been tested with Elm 0.18.0 ``` @@ -370,8 +348,6 @@ STEP=stepX_YYY ./run ### Erlang -*The Erlang implementation was created by [Nathan Fiedler (nlfiedler)](https://github.com/nlfiedler)* - The Erlang implementation of mal requires [Erlang/OTP R17](http://www.erlang.org/download.html) and [rebar](https://github.com/rebar/rebar) to build. @@ -398,8 +374,6 @@ node build/stepX_YYY.js ### F# ### -*The F# implementation was created by [Peter Stephens (pstephens)](https://github.com/pstephens)* - The F# implementation of mal has been tested on Linux using the Mono F# compiler (fsharpc) and the Mono runtime (version 3.12.1). The mono C# compiler (mcs) is also necessary to compile the readline dependency. All are @@ -413,8 +387,6 @@ mono ./stepX_YYY.exe ### Factor -*The Factor implementation was created by [Jordan Lewis (jordanlewis)](https://github.com/jordanlewis)* - The Factor implementation of mal has been tested with Factor 0.97 ([factorcode.org](http://factorcode.org)). @@ -425,8 +397,6 @@ FACTOR_ROOTS=. factor -run=stepX_YYY ### Fantom -*The Fantom implementation was created by [Dov Murik](https://github.com/dubek)* - The Fantom implementation of mal has been tested with Fantom 1.0.70. ``` @@ -437,8 +407,6 @@ STEP=stepX_YYY ./run ### Forth -*The Forth implementation was created by [Chris Houser (chouser)](https://github.com/chouser)* - ``` cd forth gforth stepX_YYY.fs @@ -469,8 +437,6 @@ groovy ./stepX_YYY.groovy ### GNU Guile 2.1+ -*The Guile implementation was created by [Mu Lei (NalaGinrut)](https://github.com/NalaGinrut).* - ``` cd guile guile -L ./ stepX_YYY.scm @@ -478,8 +444,6 @@ guile -L ./ stepX_YYY.scm ### GNU Smalltalk -*The Smalltalk implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* - The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. ``` @@ -531,8 +495,6 @@ cd hy ### Io -*The Io implementation was created by [Dov Murik](https://github.com/dubek)* - The Io implementation of mal has been tested with Io version 20110905. ``` @@ -571,8 +533,6 @@ julia stepX_YYY.jl ### Kotlin -*The Kotlin implementation was created by [Javier Fernandez-Ivern](https://github.com/ivern)* - The Kotlin implementation of mal has been tested with Kotlin 1.0. ``` @@ -583,8 +543,6 @@ java -jar stepX_YYY.jar ### LiveScript -*The LiveScript implementation was created by [Jos van Bakel](https://github.com/c0deaddict)* - The LiveScript implementation of mal has been tested with LiveScript 1.5. ``` @@ -595,8 +553,6 @@ node_modules/.bin/lsc stepX_YYY.ls ### Logo -*The Logo implementation was created by [Dov Murik](https://github.com/dubek)* - The Logo implementation of mal has been tested with UCBLogo 6.0. ``` @@ -637,8 +593,6 @@ make -f stepX_YYY.mk ### NASM -*The NASM implementation was created by [Ben Dudson](https://github.com/bendudson)* - The NASM implementation of mal is written for x86-64 Linux, and has been tested with Linux 3.16.0-4-amd64 and NASM version 2.11.05. @@ -650,8 +604,6 @@ make ### Nim 0.17.0 -*The Nim implementation was created by [Dennis Felsing (def-)](https://github.com/def-)* - The Nim implementation of mal has been tested with Nim 0.17.0. ``` @@ -687,8 +639,6 @@ make ### OCaml 4.01.0 -*The OCaml implementation was created by [Chris Houser (chouser)](https://github.com/chouser)* - ``` cd ocaml make @@ -738,8 +688,6 @@ perl stepX_YYY.pl ### Perl 6 -*The Perl 6 implementation was created by [Hinrik Örn Sigurðsson](https://github.com/hinrik)* - The Perl 6 implementation was tested on Rakudo Perl 6 2016.04. ``` @@ -759,8 +707,6 @@ php stepX_YYY.php ### Picolisp -*The Picolisp implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* - The Picolisp implementation requires libreadline and Picolisp 3.1.11 or later. @@ -868,8 +814,6 @@ cd racket ### Rexx -*The Rexx implementation was created by [Dov Murik](https://github.com/dubek)* - The Rexx implementation of mal has been tested with Regina Rexx 3.6. ``` @@ -909,8 +853,6 @@ scala -classpath target/scala*/classes stepX_YYY ### Scheme (R7RS) ### -*The Scheme implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)* - The Scheme implementation of mal has been tested with Chibi-Scheme 0.7.3, Kawa 2.4, Gauche 0.9.5, CHICKEN 4.11.0, Sagittarius 0.8.3, Cyclone 0.6.3 (Git version) and Foment 0.4 (Git version). You should @@ -942,8 +884,6 @@ scheme_MODE=foment ./run ### Skew ### -*The Skew implementation was created by [Dov Murik](https://github.com/dubek)* - The Skew implementation of mal has been tested with Skew 0.7.42. ``` @@ -955,8 +895,6 @@ node stepX_YYY.js ### Swift -*The Swift implementation was created by [Keith Rollin](https://github.com/keith-rollin)* - The Swift implementation of mal requires the Swift 2.0 compiler (XCode 7.0) to build. Older versions will not work due to changes in the language and standard library. @@ -980,8 +918,6 @@ make ### Tcl 8.6 -*The Tcl implementation was created by [Dov Murik](https://github.com/dubek)* - The Tcl implementation of mal requires Tcl 8.6 to run. For readline line editing support, install tclreadline. @@ -992,8 +928,6 @@ tclsh ./stepX_YYY.tcl ### TypeScript -*The TypeScript implementation was created by [vvakame](https://github.com/vvakame)* - The TypeScript implementation of mal requires the TypeScript 2.2 compiler. It has been tested with Node.js v6. @@ -1005,8 +939,6 @@ node ./stepX_YYY.js ### VHDL -*The VHDL implementation was created by [Dov Murik](https://github.com/dubek)* - The VHDL implementation of mal has been tested with GHDL 0.29. ``` @@ -1017,8 +949,6 @@ make ### Vimscript -*The Vimscript implementation was created by [Dov Murik](https://github.com/dubek)* - The Vimscript implementation of mal requires Vim 8.0 to run. ``` @@ -1053,8 +983,6 @@ wace ./stepX_YYY.wasm ### Yorick -*The Yorick implementation was created by [Dov Murik](https://github.com/dubek)* - The Yorick implementation of mal was tested on Yorick 2.2.04. ``` From f98792ade04c5ce9e93efec458ee7c318cf08c50 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 28 Jan 2019 17:43:04 -0600 Subject: [PATCH 0439/1998] README: bold language names to make clearer. --- README.md | 148 +++++++++++++++++++++++++++--------------------------- 1 file changed, 74 insertions(+), 74 deletions(-) diff --git a/README.md b/README.md index 1e78d85a4f..109080e321 100644 --- a/README.md +++ b/README.md @@ -8,80 +8,80 @@ Mal is a Clojure inspired Lisp interpreter. Mal is implemented in 74 languages: -* Ada - *created by [Chris Moore](https://github.com/zmower)* -* GNU awk - *created by [Miutsuru Kariya](https://github.com/kariya-mitsuru)* -* Bash 4 -* BASIC (C64 and QBasic) -* C -* C++ - *created by [Stephen Thirlwall](https://github.com/sdt)* -* C# -* ChucK - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* Common Lisp - *created by [Iqbal Ansari](https://github.com/iqbalansari)* -* Clojure (Clojure and ClojureScript) -* CoffeeScript -* Crystal - *created by [Linda_pp](https://github.com/rhysd)* -* D - *created by [Dov Murik](https://github.com/dubek)* -* Dart - *created by [Harry Terkelsen](https://github.com/hterkelsen)* -* Elixir - *created by [Martin Ek](https://github.com/ekmartin)* -* Elm - *created by [Jos van Bakel](https://github.com/c0deaddict)* -* Emacs Lisp - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* Erlang - *created by [Nathan Fiedler](https://github.com/nlfiedler)* -* ES6 (ECMAScript 6 / ECMAScript 2015) -* F# - *created by [Peter Stephens](https://github.com/pstephens)* -* Factor - *created by [Jordan Lewis](https://github.com/jordanlewis)* -* Fantom - *created by [Dov Murik](https://github.com/dubek)* -* Forth - *created by [Chris Houser](https://github.com/chouser)* -* Go -* Groovy -* GNU Guile - *created by [Mu Lei](https://github.com/NalaGinrut).* -* GNU Smalltalk - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* Haskell -* Haxe (Neko, Python, C++ and JavaScript) -* Hy -* Io - *created by [Dov Murik](https://github.com/dubek)* -* Java -* JavaScript ([Online Demo](http://kanaka.github.io/mal)) -* Julia -* Kotlin - *created by [Javier Fernandez-Ivern](https://github.com/ivern)* -* LiveScript - *created by [Jos van Bakel](https://github.com/c0deaddict)* -* Logo - *created by [Dov Murik](https://github.com/dubek)* -* Lua -* GNU Make -* mal itself -* Matlab (GNU Octave and MATLAB) -* [miniMAL](https://github.com/kanaka/miniMAL) -* NASM - *created by [Ben Dudson](https://github.com/bendudson)* -* Nim - *created by [Dennis Felsing](https://github.com/def-)* -* Object Pascal -* Objective C -* OCaml - *created by [Chris Houser](https://github.com/chouser)* -* Perl -* Perl 6 - *created by [Hinrik Örn Sigurðsson](https://github.com/hinrik)* -* PHP -* Picolisp - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* PL/pgSQL (Postgres) -* PL/SQL (Oracle) -* Postscript -* PowerShell -* Python (2.X and 3.X) -* RPython -* R -* Racket -* Rexx - *created by [Dov Murik](https://github.com/dubek)* -* Ruby -* Rust -* Scala -* Scheme (R7RS) *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* Skew - *created by [Dov Murik](https://github.com/dubek)* -* Swift - *created by [Keith Rollin](https://github.com/keith-rollin)* -* Swift 3 -* Tcl - *created by [Dov Murik](https://github.com/dubek)* -* TypeScript - *created by [Masahiro Wakame](https://github.com/vvakame)* -* VHDL - *created by [Dov Murik](https://github.com/dubek)* -* Vimscript - *created by [Dov Murik](https://github.com/dubek)* -* Visual Basic.NET -* WebAssembly (wasm) -* Yorick - *created by [Dov Murik](https://github.com/dubek)* +* **Ada** - *created by [Chris Moore](https://github.com/zmower)* +* **GNU awk** - *created by [Miutsuru Kariya](https://github.com/kariya-mitsuru)* +* **Bash 4** +* **BASIC** (C64 and QBasic) +* **C** +* **C++** - *created by [Stephen Thirlwall](https://github.com/sdt)* +* **C#** +* **ChucK** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* **Common Lisp** - *created by [Iqbal Ansari](https://github.com/iqbalansari)* +* **Clojure** (Clojure and ClojureScript) +* **CoffeeScript** +* **Crystal** - *created by [Linda_pp](https://github.com/rhysd)* +* **D** - *created by [Dov Murik](https://github.com/dubek)* +* **Dart** - *created by [Harry Terkelsen](https://github.com/hterkelsen)* +* **Elixir** - *created by [Martin Ek](https://github.com/ekmartin)* +* **Elm** - *created by [Jos van Bakel](https://github.com/c0deaddict)* +* **Emacs Lisp** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* **Erlang** - *created by [Nathan Fiedler](https://github.com/nlfiedler)* +* **ES6** (ECMAScript 6 / ECMAScript 2015) +* **F#** - *created by [Peter Stephens](https://github.com/pstephens)* +* **Factor** - *created by [Jordan Lewis](https://github.com/jordanlewis)* +* **Fantom** - *created by [Dov Murik](https://github.com/dubek)* +* **Forth** - *created by [Chris Houser](https://github.com/chouser)* +* **Go** +* **Groovy** +* **GNU Guile** - *created by [Mu Lei](https://github.com/NalaGinrut).* +* **GNU Smalltalk** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* **Haskell** +* **Haxe** (Neko, Python, C++ and JavaScript) +* **Hy** +* **Io** - *created by [Dov Murik](https://github.com/dubek)* +* **Java** +* **JavaScript** ([Online Demo](http://kanaka.github.io/mal)) +* **Julia** +* **Kotlin** - *created by [Javier Fernandez-Ivern](https://github.com/ivern)* +* **LiveScript** - *created by [Jos van Bakel](https://github.com/c0deaddict)* +* **Logo** - *created by [Dov Murik](https://github.com/dubek)* +* **Lua** +* **GNU Make** +* **mal itself** +* **Matlab** (GNU Octave and MATLAB) +* **[miniMAL](https://github.com/kanaka/miniMAL)** +* **NASM** - *created by [Ben Dudson](https://github.com/bendudson)* +* **Nim** - *created by [Dennis Felsing](https://github.com/def-)* +* **Object Pascal** +* **Objective C** +* **OCaml** - *created by [Chris Houser](https://github.com/chouser)* +* **Perl** +* **Perl 6** - *created by [Hinrik Örn Sigurðsson](https://github.com/hinrik)* +* **PHP** +* **Picolisp** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* **PL/pgSQL** (Postgres) +* **PL/SQL** (Oracle) +* **Postscript** +* **PowerShell** +* **Python** (2.X and 3.X) +* **RPython** +* **R** +* **Racket** +* **Rexx** - *created by [Dov Murik](https://github.com/dubek)* +* **Ruby** +* **Rust** +* **Scala** +* **Scheme (R7RS)** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* +* **Skew** - *created by [Dov Murik](https://github.com/dubek)* +* **Swift** - *created by [Keith Rollin](https://github.com/keith-rollin)* +* **Swift 3** +* **Tcl** - *created by [Dov Murik](https://github.com/dubek)* +* **TypeScript** - *created by [Masahiro Wakame](https://github.com/vvakame)* +* **VHDL** - *created by [Dov Murik](https://github.com/dubek)* +* **Vimscript** - *created by [Dov Murik](https://github.com/dubek)* +* **Visual Basic.NET** +* **WebAssembly** (wasm) +* **Yorick** - *created by [Dov Murik](https://github.com/dubek)* Mal is a learning tool. See the [make-a-lisp process From 78c71a51adec8691c2d4fea6f913d5432eacb5fb Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Mon, 10 Oct 2016 19:05:19 +0200 Subject: [PATCH 0440/1998] In step1, test non-numbers starting with a dash. --- tests/step1_read_print.mal | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/step1_read_print.mal b/tests/step1_read_print.mal index a40e9dba19..51290a9a76 100644 --- a/tests/step1_read_print.mal +++ b/tests/step1_read_print.mal @@ -21,6 +21,13 @@ abc5 abc-def ;=>abc-def +;; Testing non-numbers starting with a dash. +- +;=>- +-abc +;=>-abc +->> +;=>->> ;; Testing read of lists (+ 1 2) From f29ccc407a895d11a6c21549ff5f45ecb416e9aa Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 30 Jan 2019 11:54:57 -0600 Subject: [PATCH 0441/1998] fsharp, swift3: fix parsing of single '-' Fixes https://github.com/kanaka/mal/pull/338 --- fsharp/tokenizer.fs | 2 +- swift3/Sources/reader.swift | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/fsharp/tokenizer.fs b/fsharp/tokenizer.fs index fb2834ce32..6bfbc74159 100644 --- a/fsharp/tokenizer.fs +++ b/fsharp/tokenizer.fs @@ -102,7 +102,7 @@ module Tokenizer | '@' -> At, n | '"' -> accumulateString n | ':' -> accumulateKeyword n - | '-' when isDigit str.[n] -> accumulateWhile isDigit Number p n + | '-' when n < len && isDigit str.[n] -> accumulateWhile isDigit Number p n | ch when isDigit ch -> accumulateWhile isDigit Number p n | ch when isTokenChar ch -> accumulateWhile isTokenChar Token p n | _ -> raise <| Error.unexpectedChar () diff --git a/swift3/Sources/reader.swift b/swift3/Sources/reader.swift index f729dd6c8b..e4ebd582d7 100644 --- a/swift3/Sources/reader.swift +++ b/swift3/Sources/reader.swift @@ -113,7 +113,7 @@ func read_atom(_ rdr: Reader) throws -> MalVal { throw MalError.Reader(msg: "Empty string passed to read_atom") } switch rdr.str[rdr.pos] { - case "-" where !int_char.contains(rdr.str[rdr.str.index(after: rdr.pos)]): + case "-" where rdr.str.characters.count == 1 || !int_char.contains(rdr.str[rdr.str.index(after: rdr.pos)]): return try read_symbol(rdr) case let c where int_char.contains(c): return read_int(rdr) From e47a5ec437728287c2eef0fce04c16fd0ed8d1a0 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 30 Jan 2019 11:56:01 -0600 Subject: [PATCH 0442/1998] Makefile: mention TEST_OPTS in help. --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 52cf142ec6..31da504b01 100644 --- a/Makefile +++ b/Makefile @@ -32,6 +32,7 @@ all help: @echo 'make MAL_IMPL=IMPL "test^mal..." # use IMPL for self-host tests' @echo 'make REGRESS=1 "test..." # test with previous step tests too' @echo 'make DOCKERIZE=1 ... # to dockerize above rules/targets' + @echo 'make TEST_OPTS="--opt ..." # options to pass to runtest.py' @echo @echo 'Other:' @echo From d57f74df9b354d2dd294bdec6d4342d638e85f8c Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 30 Jan 2019 12:05:34 -0600 Subject: [PATCH 0443/1998] README: mention make help target. --- README.md | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 109080e321..bcfc94a381 100644 --- a/README.md +++ b/README.md @@ -994,6 +994,14 @@ yorick -batch ./stepX_YYY.i ## Running tests +The top level Makefile has a number of useful targets to assist with +implementation development and testing. The `help` target provides +a list of the targets and options: + +``` +make help +``` + ### Functional tests The are over 600 generic functional tests (for all implementations) @@ -1003,9 +1011,6 @@ launches a Mal step implementation and then feeds the tests one at a time to the implementation and compares the output/return value to the expected output/return value. -To simplify the process of running tests, a top level Makefile is -provided with convenient test targets. - * To run all the tests across all implementations (be prepared to wait): ``` From d12bf4787c6f9213fe65c99063f22c2c6bd43ec5 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Mon, 10 Oct 2016 19:06:37 +0200 Subject: [PATCH 0444/1998] In step6, test that eval uses Repl not Env. I have not managed to test this before step7 quotes. --- tests/step7_quote.mal | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index 4f3e3569ba..b4e7d4b997 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -181,3 +181,9 @@ b ;;; TODO: fix this ;;;;=>[1 1 "b" "d" 3] +;; Checking that eval does not use local environments. +;; Test step6, but requires a quote. +(def! a 1) +;=>1 +(let* (a 2) (eval 'a)) +;=>1 From fc7f8a4b008f8796144db6b163cfea4684737e0f Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 3 Feb 2019 14:56:34 +0100 Subject: [PATCH 0445/1998] Move test of eval builtin to step6. Fix nim implementation. The test makes more sense in step6. Thanks to kanaka for the read-string suggestion. Introduction of tail call optimization in step5 was making let* affect the parent environment. This was partially fixed in later steps. Introduction of macros in step8 was breaking the evaluation of an empty list. This was fixed by step 9 but never backported. --- nim/step5_tco.nim | 7 ++++--- nim/step6_file.nim | 7 ++++--- nim/step7_quote.nim | 7 ++++--- nim/step8_macros.nim | 4 ++-- nim/step9_try.nim | 2 +- nim/stepA_mal.nim | 2 +- tests/step6_file.mal | 5 +++++ tests/step7_quote.mal | 6 ------ 8 files changed, 21 insertions(+), 19 deletions(-) diff --git a/nim/step5_tco.nim b/nim/step5_tco.nim index f192ac612c..9077b095c5 100644 --- a/nim/step5_tco.nim +++ b/nim/step5_tco.nim @@ -2,7 +2,7 @@ import rdstdin, tables, sequtils, types, reader, printer, env, core proc read(str: string): MalType = str.read_str -proc eval(ast: MalType, env: var Env): MalType +proc eval(ast: MalType, env: Env): MalType proc eval_ast(ast: MalType, env: var Env): MalType = case ast.kind @@ -19,8 +19,9 @@ proc eval_ast(ast: MalType, env: var Env): MalType = else: result = ast -proc eval(ast: MalType, env: var Env): MalType = +proc eval(ast: MalType, env: Env): MalType = var ast = ast + var env = env template defaultApply = let el = ast.eval_ast(env) @@ -50,7 +51,7 @@ proc eval(ast: MalType, env: var Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] - var let_env = env + var let_env = initEnv(env) case a1.kind of List, Vector: for i in countup(0, a1.list.high, 2): diff --git a/nim/step6_file.nim b/nim/step6_file.nim index 50155e21dc..7af6e6e1b9 100644 --- a/nim/step6_file.nim +++ b/nim/step6_file.nim @@ -2,7 +2,7 @@ import rdstdin, tables, sequtils, os, types, reader, printer, env, core proc read(str: string): MalType = str.read_str -proc eval(ast: MalType, env: var Env): MalType +proc eval(ast: MalType, env: Env): MalType proc eval_ast(ast: MalType, env: var Env): MalType = case ast.kind @@ -19,8 +19,9 @@ proc eval_ast(ast: MalType, env: var Env): MalType = else: result = ast -proc eval(ast: MalType, env: var Env): MalType = +proc eval(ast: MalType, env: Env): MalType = var ast = ast + var env = env template defaultApply = let el = ast.eval_ast(env) @@ -50,7 +51,7 @@ proc eval(ast: MalType, env: var Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] - var let_env = env + var let_env = initEnv(env) case a1.kind of List, Vector: for i in countup(0, a1.list.high, 2): diff --git a/nim/step7_quote.nim b/nim/step7_quote.nim index 7917849d31..341072c7cc 100644 --- a/nim/step7_quote.nim +++ b/nim/step7_quote.nim @@ -16,7 +16,7 @@ proc quasiquote(ast: MalType): MalType = else: return list(symbol "cons", quasiquote(ast.list[0]), quasiquote(list(ast.list[1 .. ^1]))) -proc eval(ast: MalType, env: var Env): MalType +proc eval(ast: MalType, env: Env): MalType proc eval_ast(ast: MalType, env: var Env): MalType = case ast.kind @@ -33,8 +33,9 @@ proc eval_ast(ast: MalType, env: var Env): MalType = else: result = ast -proc eval(ast: MalType, env: var Env): MalType = +proc eval(ast: MalType, env: Env): MalType = var ast = ast + var env = env template defaultApply = let el = ast.eval_ast(env) @@ -64,7 +65,7 @@ proc eval(ast: MalType, env: var Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] - var let_env = env + var let_env = initEnv(env) case a1.kind of List, Vector: for i in countup(0, a1.list.high, 2): diff --git a/nim/step8_macros.nim b/nim/step8_macros.nim index 0cd6776778..6de153b2a6 100644 --- a/nim/step8_macros.nim +++ b/nim/step8_macros.nim @@ -17,7 +17,7 @@ proc quasiquote(ast: MalType): MalType = return list(symbol "cons", quasiquote(ast.list[0]), quasiquote(list(ast.list[1 .. ^1]))) proc is_macro_call(ast: MalType, env: Env): bool = - ast.kind == List and ast.list[0].kind == Symbol and + ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro proc macroexpand(ast: MalType, env: Env): MalType = @@ -78,7 +78,7 @@ proc eval(ast: MalType, env: Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] - var let_env = env + var let_env = initEnv(env) case a1.kind of List, Vector: for i in countup(0, a1.list.high, 2): diff --git a/nim/step9_try.nim b/nim/step9_try.nim index 864ca91133..314a42c9a2 100644 --- a/nim/step9_try.nim +++ b/nim/step9_try.nim @@ -79,7 +79,7 @@ proc eval(ast: MalType, env: Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] - var let_env = env + var let_env = initEnv(env) case a1.kind of List, Vector: for i in countup(0, a1.list.high, 2): diff --git a/nim/stepA_mal.nim b/nim/stepA_mal.nim index 4932da837a..edfe443544 100644 --- a/nim/stepA_mal.nim +++ b/nim/stepA_mal.nim @@ -79,7 +79,7 @@ proc eval(ast: MalType, env: Env): MalType = let a1 = ast.list[1] a2 = ast.list[2] - var let_env = env + var let_env = initEnv(env) case a1.kind of List, Vector: for i in countup(0, a1.list.high, 2): diff --git a/tests/step6_file.mal b/tests/step6_file.mal index 486725ee4b..c9264da239 100644 --- a/tests/step6_file.mal +++ b/tests/step6_file.mal @@ -125,3 +125,8 @@ mymap (g 3) ;=>81 +;; Checking that eval does not use local environments. +(def! a 1) +;=>1 +(let* (a 2) (eval (read-string "a"))) +;=>1 diff --git a/tests/step7_quote.mal b/tests/step7_quote.mal index b4e7d4b997..4f3e3569ba 100644 --- a/tests/step7_quote.mal +++ b/tests/step7_quote.mal @@ -181,9 +181,3 @@ b ;;; TODO: fix this ;;;;=>[1 1 "b" "d" 3] -;; Checking that eval does not use local environments. -;; Test step6, but requires a quote. -(def! a 1) -;=>1 -(let* (a 2) (eval 'a)) -;=>1 From c5dd7ecba0267e3233e127dde56b675b4b80acef Mon Sep 17 00:00:00 2001 From: Juan de Bruin Date: Thu, 7 Feb 2019 12:04:54 +0200 Subject: [PATCH 0446/1998] Fix typo --- process/guide.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/process/guide.md b/process/guide.md index 49bfb3b574..18c9075d2b 100644 --- a/process/guide.md +++ b/process/guide.md @@ -332,7 +332,7 @@ expression support. ```[]{}()'`~^@``` (tokenized). * `"(?:\\.|[^\\"])*"?`: Starts capturing at a double-quote and stops at the - next double-quote unless it was proceeded by a backslash in which case it + next double-quote unless it was preceded by a backslash in which case it includes it until the next double-quote (tokenized). It will also match unbalanced strings (no ending double-quote) which should be reported as an error. From 5b6498bcf163a12bf222f8f5b984c189fd7feb7f Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 12 Feb 2019 11:10:42 -0800 Subject: [PATCH 0447/1998] README: description section formatting and diagram Number the 3 description sections highlights. Add the step A diagram to the educational highlight. --- README.md | 46 ++++++++++++++++++++++++++++------------------ 1 file changed, 28 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index bcfc94a381..1f2041da3a 100644 --- a/README.md +++ b/README.md @@ -4,9 +4,9 @@ ## Description -Mal is a Clojure inspired Lisp interpreter. +**1. Mal is a Clojure inspired Lisp interpreter** -Mal is implemented in 74 languages: +**2. Mal is implemented in 74 languages** * **Ada** - *created by [Chris Moore](https://github.com/zmower)* * **GNU awk** - *created by [Miutsuru Kariya](https://github.com/kariya-mitsuru)* @@ -84,13 +84,15 @@ Mal is implemented in 74 languages: * **Yorick** - *created by [Dov Murik](https://github.com/dubek)* -Mal is a learning tool. See the [make-a-lisp process -guide](process/guide.md). Each implementation of mal is separated into +**3. Mal is a learning tool** + +Each implementation of mal is separated into 11 incremental, self-contained (and testable) steps that demonstrate core concepts of Lisp. The last step is capable of self-hosting -(running the mal implementation of mal). +(running the mal implementation of mal). See the [make-a-lisp process +guide](process/guide.md). -The mal (make a lisp) steps are: +The make-a-lisp steps are: * [step0_repl](process/guide.md#step0) * [step1_read_print](process/guide.md#step1) @@ -104,29 +106,37 @@ The mal (make a lisp) steps are: * [step9_try](process/guide.md#step9) * [stepA_mal](process/guide.md#stepA) +Each make-a-lisp step has an associated architectural diagram. That elements that new for that step are highlighted in red. Here is the final diagram for [step A](process/guide.md#stepA): + +![stepA_mal architecture](process/stepA_mal.png) + +If you are interesting in creating a mal implementation (or just +interested in using mal for something), please drop by the #mal +channel on freenode. In addition to the [make-a-lisp process +guide](process/guide.md) there is also a [mal/make-a-lisp +FAQ](docs/FAQ.md) where I attempt to answer some common questions. + + +## Presentations Mal was presented publicly for the first time in a lightning talk at Clojure West 2014 (unfortunately there is no video). See examples/clojurewest2014.mal for the presentation that was given at the -conference (yes, the presentation is a mal program). At Midwest.io -2015, Joel Martin gave a presentation on Mal titled "Achievement -Unlocked: A Better Path to Language Learning". +conference (yes, the presentation is a mal program). + +At Midwest.io 2015, Joel Martin gave a presentation on Mal titled +"Achievement Unlocked: A Better Path to Language Learning". [Video](https://www.youtube.com/watch?v=lgyOAiRtZGw), -[Slides](http://kanaka.github.io/midwest.io.mal/). More recently -Joel gave a presentation on "Make Your Own Lisp Interpreter in -10 Incremental Steps" at LambdaConf 2016: +[Slides](http://kanaka.github.io/midwest.io.mal/). + +More recently Joel gave a presentation on "Make Your Own Lisp Interpreter +in 10 Incremental Steps" at LambdaConf 2016: [Part 1](https://www.youtube.com/watch?v=jVhupfthTEk), [Part 2](https://www.youtube.com/watch?v=X5OQBMGpaTU), [Part 3](https://www.youtube.com/watch?v=6mARZzGgX4U), [Part 4](https://www.youtube.com/watch?v=dCO1SYR5kDU), [Slides](http://kanaka.github.io/lambdaconf/). -If you are interesting in creating a mal implementation (or just -interested in using mal for something), please drop by the #mal -channel on freenode. In addition to the [make-a-lisp process -guide](process/guide.md) there is also a [mal/make-a-lisp -FAQ](docs/FAQ.md) where I attempt to answer some common questions. - ## Building/running implementations The simplest way to run any given implementation is to use docker. From 138cbb9c100a706cff594096dca6dd4ec82177a4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 12 Feb 2019 11:13:46 -0800 Subject: [PATCH 0448/1998] README: fix typo --- README.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 1f2041da3a..ab58496559 100644 --- a/README.md +++ b/README.md @@ -106,7 +106,9 @@ The make-a-lisp steps are: * [step9_try](process/guide.md#step9) * [stepA_mal](process/guide.md#stepA) -Each make-a-lisp step has an associated architectural diagram. That elements that new for that step are highlighted in red. Here is the final diagram for [step A](process/guide.md#stepA): +Each make-a-lisp step has an associated architectural diagram. That elements +that are new for that step are highlighted in red. +Here is the final diagram for [step A](process/guide.md#stepA): ![stepA_mal architecture](process/stepA_mal.png) From 2bce8a6901fd51da9ba94866506a7dbc6ebe65a1 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Tue, 19 Feb 2019 08:37:28 +0000 Subject: [PATCH 0449/1998] ruby: Fix exception when handling catchless try* --- ruby/step9_try.rb | 2 +- ruby/stepA_mal.rb | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ruby/step9_try.rb b/ruby/step9_try.rb index 71d16be752..3a00491216 100644 --- a/ruby/step9_try.rb +++ b/ruby/step9_try.rb @@ -111,7 +111,7 @@ def EVAL(ast, env) if a2 && a2[0] == :"catch*" return EVAL(a2[2], Env.new(env, [a2[1]], [exc])) else - raise esc + raise exc end end when :do diff --git a/ruby/stepA_mal.rb b/ruby/stepA_mal.rb index 9071b74e74..2ca2db3cdf 100644 --- a/ruby/stepA_mal.rb +++ b/ruby/stepA_mal.rb @@ -117,7 +117,7 @@ def EVAL(ast, env) if a2 && a2[0] == :"catch*" return EVAL(a2[2], Env.new(env, [a2[1]], [exc])) else - raise esc + raise exc end end when :do From 7cdb44161daa258b709ece74d4ff5d826c92851e Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Feb 2019 10:52:43 -0600 Subject: [PATCH 0450/1998] README: link to Tim Morgan's malcc project. Resolves https://github.com/kanaka/mal/issues/342 --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index ab58496559..98bb11fb4f 100644 --- a/README.md +++ b/README.md @@ -1194,9 +1194,10 @@ The following implementations are maintained as separate projects: * [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). -## Projects using mal +## Other mal Related Projects * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. + * [malcc](https://git.sr.ht/~tim/malcc) - malcc is an incremental compiler implementation for the Mal language. It uses the Tiny C Compiler as the compiler backend and has full support for the Mal language, including macros, tail-call elimination, and even run-time eval. * [frock](https://github.com/chr15m/frock) - Clojure-flavoured PHP. Uses mal/php to run programs. ## License From daafc18dfa07d81be4ad6bb8515d558d628b8cd9 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Feb 2019 10:54:04 -0600 Subject: [PATCH 0451/1998] README: better title "Other mal projects" --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 98bb11fb4f..7372b4522a 100644 --- a/README.md +++ b/README.md @@ -1194,7 +1194,7 @@ The following implementations are maintained as separate projects: * [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). -## Other mal Related Projects +## Other mal Projects * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. * [malcc](https://git.sr.ht/~tim/malcc) - malcc is an incremental compiler implementation for the Mal language. It uses the Tiny C Compiler as the compiler backend and has full support for the Mal language, including macros, tail-call elimination, and even run-time eval. From dad737adbf6a801d2d611708835ff4a6803662d3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Feb 2019 10:58:19 -0600 Subject: [PATCH 0452/1998] README: add Tim Morgan (malcc) github user. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 7372b4522a..de0678f267 100644 --- a/README.md +++ b/README.md @@ -1197,7 +1197,7 @@ The following implementations are maintained as separate projects: ## Other mal Projects * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. - * [malcc](https://git.sr.ht/~tim/malcc) - malcc is an incremental compiler implementation for the Mal language. It uses the Tiny C Compiler as the compiler backend and has full support for the Mal language, including macros, tail-call elimination, and even run-time eval. + * [malcc](https://git.sr.ht/~tim/malcc) (@seven1m) - malcc is an incremental compiler implementation for the Mal language. It uses the Tiny C Compiler as the compiler backend and has full support for the Mal language, including macros, tail-call elimination, and even run-time eval. * [frock](https://github.com/chr15m/frock) - Clojure-flavoured PHP. Uses mal/php to run programs. ## License From 5020037a09528a96974b3bcd859b64ab94bef942 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 19 Feb 2019 20:46:04 +0100 Subject: [PATCH 0453/1998] elisp: Reraise error correctly in try* --- elisp/step9_try.el | 2 +- elisp/stepA_mal.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/step9_try.el b/elisp/step9_try.el index c3b5907aa9..154111bf7e 100644 --- a/elisp/step9_try.el +++ b/elisp/step9_try.el @@ -128,7 +128,7 @@ (mal-string (error-message-string err)))) (env* (mal-env env (list identifier) (list err*)))) (throw 'return (EVAL form env*))) - (apply 'signal err))))) + (signal (car err) (list (cadr err))))))) ((eq a0* 'do) (let* ((a0... (cdr a)) (butlast (butlast a0...)) diff --git a/elisp/stepA_mal.el b/elisp/stepA_mal.el index 9f26edbca0..f0250bad44 100644 --- a/elisp/stepA_mal.el +++ b/elisp/stepA_mal.el @@ -128,7 +128,7 @@ (mal-string (error-message-string err)))) (env* (mal-env env (list identifier) (list err*)))) (throw 'return (EVAL form env*))) - (apply 'signal err))))) + (signal (car err) (list (cadr err))))))) ((eq a0* 'do) (let* ((a0... (cdr a)) (butlast (butlast a0...)) From 948eeb0422f862c01f2304fd0eaf7e8becb43a20 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 19 Feb 2019 20:49:53 +0100 Subject: [PATCH 0454/1998] elisp: Drop unused type definition --- elisp/types.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/elisp/types.el b/elisp/types.el index 6abcbd2ad3..591b7fd27b 100644 --- a/elisp/types.el +++ b/elisp/types.el @@ -37,9 +37,7 @@ (mal-object vector) (mal-object map) -(mal-object env) (mal-object atom) - (mal-object fn) (mal-object func) From a3b3a3cc7cc8384500631ced698047aa3dcbebad Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 19 Feb 2019 20:50:14 +0100 Subject: [PATCH 0455/1998] elisp: Get rid of newline hack in printer --- elisp/printer.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/printer.el b/elisp/printer.el index f00efa799c..48293529c8 100644 --- a/elisp/printer.el +++ b/elisp/printer.el @@ -12,8 +12,8 @@ (number-to-string (mal-value form))) ((eq type 'string) (if print-readably - ;; HACK prin1-to-string does only quotes and backslashes - (replace-regexp-in-string "\n" "\\\\n" (prin1-to-string value)) + (let ((print-escape-newlines t)) + (prin1-to-string value)) value)) ((or (eq type 'symbol) (eq type 'keyword)) (symbol-name value)) From 79c5b02eec9de5c801b27564a1e57a9673210620 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 19 Feb 2019 21:01:16 +0100 Subject: [PATCH 0456/1998] elisp: Disable curved quotes to fix test rig fails --- elisp/run | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/run b/elisp/run index 84a936e50c..405cce4302 100755 --- a/elisp/run +++ b/elisp/run @@ -1,2 +1,2 @@ #!/bin/bash -exec emacs -Q --batch --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" +exec emacs -Q --batch --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" From fabdabe2b608b6a869e577617248153bde0f36b1 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 19 Feb 2019 21:01:42 +0100 Subject: [PATCH 0457/1998] elisp: Relax version RE check --- elisp/tests/stepA_mal.mal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/tests/stepA_mal.mal b/elisp/tests/stepA_mal.mal index c655af6aa7..ec8c701f3c 100644 --- a/elisp/tests/stepA_mal.mal +++ b/elisp/tests/stepA_mal.mal @@ -16,6 +16,6 @@ ;/Hello World! ;=>nil -(elisp-eval "(setq emacs-version-re (rx (+ digit) \".\" digit \".\" digit))") +(elisp-eval "(setq emacs-version-re (rx (+ digit) \".\" digit))") (elisp-eval "(and (string-match-p emacs-version-re emacs-version) t)") ;=>true From b5df0de6f504cdc75f3bdedbe482bda9817958cd Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Tue, 19 Feb 2019 21:10:15 +0100 Subject: [PATCH 0458/1998] elisp: Get rid of load-relative hack --- elisp/core.el | 2 ++ elisp/func.el | 2 ++ elisp/{env.el => mal-env.el} | 2 ++ elisp/printer.el | 2 ++ elisp/reader.el | 2 ++ elisp/run | 2 +- elisp/step1_read_print.el | 11 +++-------- elisp/step2_eval.el | 11 +++-------- elisp/step3_env.el | 13 ++++--------- elisp/step4_if_fn_do.el | 15 +++++---------- elisp/step5_tco.el | 18 +++++++----------- elisp/step6_file.el | 17 ++++++----------- elisp/step7_quote.el | 17 ++++++----------- elisp/step8_macros.el | 17 ++++++----------- elisp/step9_try.el | 17 ++++++----------- elisp/stepA_mal.el | 17 ++++++----------- elisp/types.el | 2 ++ 17 files changed, 65 insertions(+), 102 deletions(-) rename elisp/{env.el => mal-env.el} (97%) diff --git a/elisp/core.el b/elisp/core.el index 7f4beca647..1d97f16396 100644 --- a/elisp/core.el +++ b/elisp/core.el @@ -258,3 +258,5 @@ (elisp-eval . ,(mal-fn (lambda (string) (elisp-to-mal (eval (read (mal-value string))))))) )) + +(provide 'core) diff --git a/elisp/func.el b/elisp/func.el index a7bc2207f0..55b33b6d9f 100644 --- a/elisp/func.el +++ b/elisp/func.el @@ -15,3 +15,5 @@ (defun mal-func-macro-p (mal-func) (aref (aref mal-func 1) 4)) + +(provide 'func) diff --git a/elisp/env.el b/elisp/mal-env.el similarity index 97% rename from elisp/env.el rename to elisp/mal-env.el index 2712dbccf6..e7eea800ab 100644 --- a/elisp/env.el +++ b/elisp/mal-env.el @@ -30,3 +30,5 @@ (if (not value) (error "'%s' not found" key) value))) + +(provide 'mal-env) diff --git a/elisp/printer.el b/elisp/printer.el index 48293529c8..5c08a04ca5 100644 --- a/elisp/printer.el +++ b/elisp/printer.el @@ -54,3 +54,5 @@ (lambda (item) (concat (car item) " " (cdr item))) (nreverse pairs) " "))) (concat "{" items "}")))) + +(provide 'printer) diff --git a/elisp/reader.el b/elisp/reader.el index af68fd1fad..2461bdd59b 100644 --- a/elisp/reader.el +++ b/elisp/reader.el @@ -153,3 +153,5 @@ ;; assume anything else is a symbol (mal-symbol (intern token)))) (signal 'end-of-token-stream nil)))) + +(provide 'reader) diff --git a/elisp/run b/elisp/run index 405cce4302..c68e97bf93 100755 --- a/elisp/run +++ b/elisp/run @@ -1,2 +1,2 @@ #!/bin/bash -exec emacs -Q --batch --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" +exec emacs -Q --batch -L $(dirname $0) --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" diff --git a/elisp/step1_read_print.el b/elisp/step1_read_print.el index af3ff7b09c..1f56733837 100644 --- a/elisp/step1_read_print.el +++ b/elisp/step1_read_print.el @@ -1,11 +1,6 @@ -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "reader.el") -(load-relative "printer.el") +(require 'types) +(require 'reader) +(require 'printer) (defun READ (input) (read-str input)) diff --git a/elisp/step2_eval.el b/elisp/step2_eval.el index b5f07234cc..8ff9510374 100644 --- a/elisp/step2_eval.el +++ b/elisp/step2_eval.el @@ -1,11 +1,6 @@ -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "reader.el") -(load-relative "printer.el") +(require 'types) +(require 'reader) +(require 'printer) (defvar repl-env (make-hash-table :test 'eq)) (puthash '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))) repl-env) diff --git a/elisp/step3_env.el b/elisp/step3_env.el index 1544b1fbfb..05dac6d416 100644 --- a/elisp/step3_env.el +++ b/elisp/step3_env.el @@ -1,12 +1,7 @@ -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "reader.el") -(load-relative "printer.el") +(require 'types) +(require 'mal-env) +(require 'reader) +(require 'printer) (defvar repl-env (mal-env)) (mal-env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) diff --git a/elisp/step4_if_fn_do.el b/elisp/step4_if_fn_do.el index 4eb141b2fe..21df7b8394 100644 --- a/elisp/step4_if_fn_do.el +++ b/elisp/step4_if_fn_do.el @@ -1,15 +1,10 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(require 'types) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/step5_tco.el b/elisp/step5_tco.el index 86babe8df8..31a9d0c2f0 100644 --- a/elisp/step5_tco.el +++ b/elisp/step5_tco.el @@ -1,16 +1,12 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "func.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(setq debug-on-error t) +(require 'types) +(require 'func) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/step6_file.el b/elisp/step6_file.el index ba363d4846..aef72f6c7a 100644 --- a/elisp/step6_file.el +++ b/elisp/step6_file.el @@ -1,16 +1,11 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "func.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(require 'types) +(require 'func) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/step7_quote.el b/elisp/step7_quote.el index aefde0e297..e31aa34775 100644 --- a/elisp/step7_quote.el +++ b/elisp/step7_quote.el @@ -1,16 +1,11 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "func.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(require 'types) +(require 'func) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/step8_macros.el b/elisp/step8_macros.el index ee9f220605..1e0fa3833e 100644 --- a/elisp/step8_macros.el +++ b/elisp/step8_macros.el @@ -1,16 +1,11 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "func.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(require 'types) +(require 'func) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/step9_try.el b/elisp/step9_try.el index 154111bf7e..d157892dc0 100644 --- a/elisp/step9_try.el +++ b/elisp/step9_try.el @@ -1,16 +1,11 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "func.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(require 'types) +(require 'func) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/stepA_mal.el b/elisp/stepA_mal.el index f0250bad44..10445bffd9 100644 --- a/elisp/stepA_mal.el +++ b/elisp/stepA_mal.el @@ -1,16 +1,11 @@ ;; -*- lexical-binding: t; -*- -(defun load-relative (file) - (let* ((current-file (or load-file-name buffer-file-name)) - (current-file-directory (file-name-directory current-file))) - (load (expand-file-name file current-file-directory) nil t))) - -(load-relative "types.el") -(load-relative "env.el") -(load-relative "func.el") -(load-relative "reader.el") -(load-relative "printer.el") -(load-relative "core.el") +(require 'types) +(require 'func) +(require 'mal-env) +(require 'reader) +(require 'printer) +(require 'core) (defvar repl-env (mal-env)) diff --git a/elisp/types.el b/elisp/types.el index 591b7fd27b..e9d914cafc 100644 --- a/elisp/types.el +++ b/elisp/types.el @@ -100,3 +100,5 @@ Defaults to `error'." (define-error 'unterminated-sequence "Unterminated token sequence" 'mal) (define-error 'end-of-token-stream "End of token stream" 'mal) (define-error 'mal-custom "Custom error" 'mal) + +(provide 'types) From c5cd05aee87952117de855527bf5eba22edc5eb3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 19 Feb 2019 15:40:02 -0600 Subject: [PATCH 0459/1998] README: language list to table with anchor links --- README.md | 158 +++++++++++++++++++++++++++--------------------------- 1 file changed, 80 insertions(+), 78 deletions(-) diff --git a/README.md b/README.md index de0678f267..0759b25c9f 100644 --- a/README.md +++ b/README.md @@ -8,80 +8,82 @@ **2. Mal is implemented in 74 languages** -* **Ada** - *created by [Chris Moore](https://github.com/zmower)* -* **GNU awk** - *created by [Miutsuru Kariya](https://github.com/kariya-mitsuru)* -* **Bash 4** -* **BASIC** (C64 and QBasic) -* **C** -* **C++** - *created by [Stephen Thirlwall](https://github.com/sdt)* -* **C#** -* **ChucK** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* **Common Lisp** - *created by [Iqbal Ansari](https://github.com/iqbalansari)* -* **Clojure** (Clojure and ClojureScript) -* **CoffeeScript** -* **Crystal** - *created by [Linda_pp](https://github.com/rhysd)* -* **D** - *created by [Dov Murik](https://github.com/dubek)* -* **Dart** - *created by [Harry Terkelsen](https://github.com/hterkelsen)* -* **Elixir** - *created by [Martin Ek](https://github.com/ekmartin)* -* **Elm** - *created by [Jos van Bakel](https://github.com/c0deaddict)* -* **Emacs Lisp** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* **Erlang** - *created by [Nathan Fiedler](https://github.com/nlfiedler)* -* **ES6** (ECMAScript 6 / ECMAScript 2015) -* **F#** - *created by [Peter Stephens](https://github.com/pstephens)* -* **Factor** - *created by [Jordan Lewis](https://github.com/jordanlewis)* -* **Fantom** - *created by [Dov Murik](https://github.com/dubek)* -* **Forth** - *created by [Chris Houser](https://github.com/chouser)* -* **Go** -* **Groovy** -* **GNU Guile** - *created by [Mu Lei](https://github.com/NalaGinrut).* -* **GNU Smalltalk** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* **Haskell** -* **Haxe** (Neko, Python, C++ and JavaScript) -* **Hy** -* **Io** - *created by [Dov Murik](https://github.com/dubek)* -* **Java** -* **JavaScript** ([Online Demo](http://kanaka.github.io/mal)) -* **Julia** -* **Kotlin** - *created by [Javier Fernandez-Ivern](https://github.com/ivern)* -* **LiveScript** - *created by [Jos van Bakel](https://github.com/c0deaddict)* -* **Logo** - *created by [Dov Murik](https://github.com/dubek)* -* **Lua** -* **GNU Make** -* **mal itself** -* **Matlab** (GNU Octave and MATLAB) -* **[miniMAL](https://github.com/kanaka/miniMAL)** -* **NASM** - *created by [Ben Dudson](https://github.com/bendudson)* -* **Nim** - *created by [Dennis Felsing](https://github.com/def-)* -* **Object Pascal** -* **Objective C** -* **OCaml** - *created by [Chris Houser](https://github.com/chouser)* -* **Perl** -* **Perl 6** - *created by [Hinrik Örn Sigurðsson](https://github.com/hinrik)* -* **PHP** -* **Picolisp** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* **PL/pgSQL** (Postgres) -* **PL/SQL** (Oracle) -* **Postscript** -* **PowerShell** -* **Python** (2.X and 3.X) -* **RPython** -* **R** -* **Racket** -* **Rexx** - *created by [Dov Murik](https://github.com/dubek)* -* **Ruby** -* **Rust** -* **Scala** -* **Scheme (R7RS)** - *created by [Vasilij Schneidermann](https://github.com/wasamasa)* -* **Skew** - *created by [Dov Murik](https://github.com/dubek)* -* **Swift** - *created by [Keith Rollin](https://github.com/keith-rollin)* -* **Swift 3** -* **Tcl** - *created by [Dov Murik](https://github.com/dubek)* -* **TypeScript** - *created by [Masahiro Wakame](https://github.com/vvakame)* -* **VHDL** - *created by [Dov Murik](https://github.com/dubek)* -* **Vimscript** - *created by [Dov Murik](https://github.com/dubek)* -* **Visual Basic.NET** -* **WebAssembly** (wasm) -* **Yorick** - *created by [Dov Murik](https://github.com/dubek)* +| Language | Creator | +| -------- | ------- | +| [Ada](#ada) | [Chris Moore](https://github.com/zmower) | +| [GNU awk](#gnu-awk) | [Miutsuru Kariya](https://github.com/kariya-mitsuru) | +| [Bash 4](#bash-4) | [Joel Martin](https://github.com/kanaka) | +| [BASIC](#basic-c64-and-qbasic) (C64 & QBasic) | [Joel Martin](https://github.com/kanaka) | +| [C](#c) | [Joel Martin](https://github.com/kanaka) | +| [C++](#c-1) | [Stephen Thirlwall](https://github.com/sdt) | +| [C#](#c-2) | [Joel Martin](https://github.com/kanaka) | +| [ChucK](#chuck) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Common Lisp](#common-lisp) | [Iqbal Ansari](https://github.com/iqbalansari) | +| [Clojure](#clojure) (Clojure & ClojureScript) | [Joel Martin](https://github.com/kanaka) | +| [CoffeeScript](#coffeescript) | [Joel Martin](https://github.com/kanaka) | +| [Crystal](#crystal) | [Linda_pp](https://github.com/rhysd) | +| [D](#d) | [Dov Murik](https://github.com/dubek) | +| [Dart](#dart) | [Harry Terkelsen](https://github.com/hterkelsen) | +| [Elixir](#elixir) | [Martin Ek](https://github.com/ekmartin) | +| [Elm](#elm) | [Jos van Bakel](https://github.com/c0deaddict) | +| [Emacs Lisp](#emacs-lisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Erlang](#erlang) | [Nathan Fiedler](https://github.com/nlfiedler) | +| [ES6](#es6-ecmascript-2015) (ECMAScript 2015) | [Joel Martin](https://github.com/kanaka) | +| [F#](#f) | [Peter Stephens](https://github.com/pstephens) | +| [Factor](#factor) | [Jordan Lewis](https://github.com/jordanlewis) | +| [Fantom](#fantom) | [Dov Murik](https://github.com/dubek) | +| [Forth](#forth) | [Chris Houser](https://github.com/chouser) | +| [Go](#go) | [Joel Martin](https://github.com/kanaka) | +| [Groovy](#groovy) | [Joel Martin](https://github.com/kanaka) | +| [GNU Guile](#gnu-guile-21) | [Mu Lei](https://github.com/NalaGinrut) | +| [GNU Smalltalk](#gnu-smalltalk) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Haskell](#haskell) | [Joel Martin](https://github.com/kanaka) | +| [Haxe](#haxe-neko-python-c-and-javascript) (Neko, Python, C++, & JS) | [Joel Martin](https://github.com/kanaka) | +| [Hy](#hy) | [Joel Martin](https://github.com/kanaka) | +| [Io](#io) | [Dov Murik](https://github.com/dubek) | +| [Java](#java-17) | [Joel Martin](https://github.com/kanaka) | +| [JavaScript](#javascriptnode) ([Demo](http://kanaka.github.io/mal)) | [Joel Martin](https://github.com/kanaka) | +| [Julia](#julia) | [Joel Martin](https://github.com/kanaka) | +| [Kotlin](#kotlin) | [Javier Fernandez-Ivern](https://github.com/ivern) | +| [LiveScript](#livescript) | [Jos van Bakel](https://github.com/c0deaddict) | +| [Logo](#logo) | [Dov Murik](https://github.com/dubek) | +| [Lua](#lua) | [Joel Martin](https://github.com/kanaka) | +| [GNU Make](#gnu-make-381) | [Joel Martin](https://github.com/kanaka) | +| [mal itself](#mal) | [Joel Martin](https://github.com/kanaka) | +| [Matlab](#matlab-gnu-octave-and-matlab) (GNU Octave & MATLAB) | [Joel Martin](https://github.com/kanaka) | +| [miniMAL](#minimal) ([Repo](https://github.com/kanaka/miniMAL), [Demo](https://kanaka.github.io/miniMAL/)) | [Joel Martin](https://github.com/kanaka) | +| [NASM](#nasm) | [Ben Dudson](https://github.com/bendudson) | +| [Nim](#nim-0170) | [Dennis Felsing](https://github.com/def-) | +| [Object Pascal](#object-pascal) | [Joel Martin](https://github.com/kanaka) | +| [Objective C](#objective-c) | [Joel Martin](https://github.com/kanaka) | +| [OCaml](#ocaml-4010) | [Chris Houser](https://github.com/chouser) | +| [Perl](#perl-58) | [Joel Martin](https://github.com/kanaka) | +| [Perl 6](#perl-6) | [Hinrik Örn Sigurðsson](https://github.com/hinrik) | +| [PHP](#php-53) | [Joel Martin](https://github.com/kanaka) | +| [Picolisp](#picolisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [PL/pgSQL](#plpgsql-postgres-sql-procedural-language) (Postgres) | [Joel Martin](https://github.com/kanaka) | +| [PL/SQL](#plsql-oracle-sql-procedural-language) (Oracle) | [Joel Martin](https://github.com/kanaka) | +| [Postscript](#postscript-level-23) | [Joel Martin](https://github.com/kanaka) | +| [PowerShell](#powershell) | [Joel Martin](https://github.com/kanaka) | +| [Python](#python-2x-and-3x) (2.X & 3.X) | [Joel Martin](https://github.com/kanaka) | +| [RPython](#rpython) | [Joel Martin](https://github.com/kanaka) | +| [R](#r) | [Joel Martin](https://github.com/kanaka) | +| [Racket](#racket-53) | [Joel Martin](https://github.com/kanaka) | +| [Rexx](#rexx) | [Dov Murik](https://github.com/dubek) | +| [Ruby](#ruby-19) | [Joel Martin](https://github.com/kanaka) | +| [Rust](#rust-100-nightly) | [Joel Martin](https://github.com/kanaka) | +| [Scala](#scala) | [Joel Martin](https://github.com/kanaka) | +| [Scheme (R7RS)](#scheme-r7rs) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Skew](#skew) | [Dov Murik](https://github.com/dubek) | +| [Swift](#swift) | [Keith Rollin](https://github.com/keith-rollin) | +| [Swift 3](#swift-3) | [Joel Martin](https://github.com/kanaka) | +| [Tcl](#tcl-86) | [Dov Murik](https://github.com/dubek) | +| [TypeScript](#typescript) | [Masahiro Wakame](https://github.com/vvakame) | +| [VHDL](#vhdl) | [Dov Murik](https://github.com/dubek) | +| [Vimscript](#vimscript) | [Dov Murik](https://github.com/dubek) | +| [Visual Basic.NET](#visual-basicnet) | [Joel Martin](https://github.com/kanaka) | +| [WebAssembly](#webassembly-wasm) (wasm) | [Joel Martin](https://github.com/kanaka) | +| [Yorick](#yorick) | [Dov Murik](https://github.com/dubek) | **3. Mal is a learning tool** @@ -371,11 +373,11 @@ MAL_STEP=stepX_YYY rebar compile escriptize # build individual step ./stepX_YYY ``` -### ES6 (ECMAScript 6 / ECMAScript 2015) +### ES6 (ECMAScript 2015) -The ES6 implementation uses the [babel](https://babeljs.io) compiler -to generate ES5 compatible JavaScript. The generated code has been -tested with Node 0.12.4. +The ES6 / ECMAScript 2015 implementation uses the +[babel](https://babeljs.io) compiler to generate ES5 compatible +JavaScript. The generated code has been tested with Node 0.12.4. ``` cd es6 From 9993f053eebafb7c6a56f1f9de94ca80ffb5a886 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 20 Feb 2019 07:04:55 +0000 Subject: [PATCH 0460/1998] vhdl: Support catchless try* --- vhdl/step9_try.vhdl | 3 ++- vhdl/stepA_mal.vhdl | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/vhdl/step9_try.vhdl b/vhdl/step9_try.vhdl index 6c811dd499..0e4b2d95c0 100644 --- a/vhdl/step9_try.vhdl +++ b/vhdl/step9_try.vhdl @@ -322,7 +322,8 @@ architecture test of step9_try is new_env(catch_env, env, vars, call_args); EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); else - new_nil(result); + err := sub_err; + return; end if; end if; return; diff --git a/vhdl/stepA_mal.vhdl b/vhdl/stepA_mal.vhdl index d67507bbfe..8ef8ecb87e 100644 --- a/vhdl/stepA_mal.vhdl +++ b/vhdl/stepA_mal.vhdl @@ -322,7 +322,8 @@ architecture test of stepA_mal is new_env(catch_env, env, vars, call_args); EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); else - new_nil(result); + err := sub_err; + return; end if; end if; return; From 625a68473723f6cfe2d300f9e1433a697a82735b Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 20 Feb 2019 07:10:44 +0000 Subject: [PATCH 0461/1998] tcl: Support catchless try* --- tcl/step9_try.tcl | 3 +++ tcl/stepA_mal.tcl | 3 +++ 2 files changed, 6 insertions(+) diff --git a/tcl/step9_try.tcl b/tcl/step9_try.tcl index d6a97d312a..e190f8022f 100644 --- a/tcl/step9_try.tcl +++ b/tcl/step9_try.tcl @@ -143,6 +143,9 @@ proc EVAL {ast env} { return [macroexpand $a1 $env] } "try*" { + if {$a2 == ""} { + return [EVAL $a1 $env] + } set res {} if { [catch { set res [EVAL $a1 $env] } exception] } { set exc_var [obj_val [lindex [obj_val $a2] 1]] diff --git a/tcl/stepA_mal.tcl b/tcl/stepA_mal.tcl index 23dcdb07a4..e6ac6ac315 100644 --- a/tcl/stepA_mal.tcl +++ b/tcl/stepA_mal.tcl @@ -146,6 +146,9 @@ proc EVAL {ast env} { return [string_new [eval [obj_val $a1]]] } "try*" { + if {$a2 == ""} { + return [EVAL $a1 $env] + } set res {} if { [catch { set res [EVAL $a1 $env] } exception] } { set exc_var [obj_val [lindex [obj_val $a2] 1]] From 6d4201755acfafa88ef80260cf2fdba2ea4bf4fd Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 20 Feb 2019 07:14:23 +0000 Subject: [PATCH 0462/1998] skew: Support catchless try* --- skew/step9_try.sk | 3 +++ skew/stepA_mal.sk | 3 +++ 2 files changed, 6 insertions(+) diff --git a/skew/step9_try.sk b/skew/step9_try.sk index 179575e27c..e951631552 100644 --- a/skew/step9_try.sk +++ b/skew/step9_try.sk @@ -96,6 +96,9 @@ def EVAL(ast MalVal, env Env) MalVal { } else if a0sym.val == "macroexpand" { return macroexpand(astList[1], env) } else if a0sym.val == "try*" { + if astList.count < 3 { + return EVAL(astList[1], env) + } var exc MalVal try { return EVAL(astList[1], env) diff --git a/skew/stepA_mal.sk b/skew/stepA_mal.sk index 99d8a39e55..4bfa934e69 100644 --- a/skew/stepA_mal.sk +++ b/skew/stepA_mal.sk @@ -96,6 +96,9 @@ def EVAL(ast MalVal, env Env) MalVal { } else if a0sym.val == "macroexpand" { return macroexpand(astList[1], env) } else if a0sym.val == "try*" { + if astList.count < 3 { + return EVAL(astList[1], env) + } var exc MalVal try { return EVAL(astList[1], env) From a94e352cbb6d870226d439af25cd4df965173dc0 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Wed, 20 Feb 2019 07:21:48 +0000 Subject: [PATCH 0463/1998] fantom: Support catchless try* --- fantom/src/step9_try/fan/main.fan | 2 ++ fantom/src/stepA_mal/fan/main.fan | 2 ++ 2 files changed, 4 insertions(+) diff --git a/fantom/src/step9_try/fan/main.fan b/fantom/src/step9_try/fan/main.fan index 1cede16369..5a7332ccff 100644 --- a/fantom/src/step9_try/fan/main.fan +++ b/fantom/src/step9_try/fan/main.fan @@ -97,6 +97,8 @@ class Main case "macroexpand": return macroexpand(astList[1], env) case "try*": + if (astList.count < 3) + return EVAL(astList[1], env) MalVal exc := MalNil.INSTANCE try return EVAL(astList[1], env) diff --git a/fantom/src/stepA_mal/fan/main.fan b/fantom/src/stepA_mal/fan/main.fan index c42b659657..d1569b3cc5 100644 --- a/fantom/src/stepA_mal/fan/main.fan +++ b/fantom/src/stepA_mal/fan/main.fan @@ -97,6 +97,8 @@ class Main case "macroexpand": return macroexpand(astList[1], env) case "try*": + if (astList.count < 3) + return EVAL(astList[1], env) MalVal exc := MalNil.INSTANCE try return EVAL(astList[1], env) From 2b2ba8fc146ea7b03adf7da7faf39a954fe3977a Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 21 Feb 2019 08:15:18 +0000 Subject: [PATCH 0464/1998] d: Support catchless try* --- d/step9_try.d | 4 ++++ d/stepA_mal.d | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/d/step9_try.d b/d/step9_try.d index 9c378068e1..be04dab20d 100644 --- a/d/step9_try.d +++ b/d/step9_try.d @@ -173,6 +173,10 @@ MalType EVAL(MalType ast, Env env) return macroexpand(aste[1], env); case "try*": + if (aste.length < 3) + { + return EVAL(aste[1], env); + } MalType exc; try { diff --git a/d/stepA_mal.d b/d/stepA_mal.d index 1262d5fddd..234e1600bf 100644 --- a/d/stepA_mal.d +++ b/d/stepA_mal.d @@ -173,6 +173,10 @@ MalType EVAL(MalType ast, Env env) return macroexpand(aste[1], env); case "try*": + if (aste.length < 3) + { + return EVAL(aste[1], env); + } MalType exc; try { From e64dbbd4f485f0af17b0df645b6271c169599742 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 21 Feb 2019 09:14:56 +0000 Subject: [PATCH 0465/1998] logo: Support catchless try* --- logo/step9_try.lg | 8 ++++++-- logo/stepA_mal.lg | 8 ++++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/logo/step9_try.lg b/logo/step9_try.lg index 7639ff47c1..b5e0e7c410 100644 --- a/logo/step9_try.lg +++ b/logo/step9_try.lg @@ -104,10 +104,14 @@ forever [ output _macroexpand nth :ast 1 :env ] [[[symbol try*]] + localmake "a1 nth :ast 1 + if (_count :ast) < 3 [ + output _eval :a1 :env + ] localmake "result nil_new - catch "error [make "result _eval nth :ast 1 :env] + catch "error [make "result _eval :a1 :env] localmake "exception error - ifelse or emptyp :exception ((_count :ast) < 3) [ + ifelse emptyp :exception [ output :result ] [ localmake "e first butfirst :exception diff --git a/logo/stepA_mal.lg b/logo/stepA_mal.lg index 25db73000b..57f3acf925 100644 --- a/logo/stepA_mal.lg +++ b/logo/stepA_mal.lg @@ -104,10 +104,14 @@ forever [ output _macroexpand nth :ast 1 :env ] [[[symbol try*]] + localmake "a1 nth :ast 1 + if (_count :ast) < 3 [ + output _eval :a1 :env + ] localmake "result nil_new - catch "error [make "result _eval nth :ast 1 :env] + catch "error [make "result _eval :a1 :env] localmake "exception error - ifelse or emptyp :exception ((_count :ast) < 3) [ + ifelse emptyp :exception [ output :result ] [ localmake "e first butfirst :exception From 4afc9decd544fd5af56f936b63a6ddaba14ca5a2 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 21 Feb 2019 09:54:08 +0000 Subject: [PATCH 0466/1998] rexx: Support catchless try* --- rexx/step9_try.rexx | 1 + rexx/stepA_mal.rexx | 1 + 2 files changed, 2 insertions(+) diff --git a/rexx/step9_try.rexx b/rexx/step9_try.rexx index 36a1cc3c10..86a6d6e993 100644 --- a/rexx/step9_try.rexx +++ b/rexx/step9_try.rexx @@ -144,6 +144,7 @@ eval: procedure expose values. env. err /* eval(ast) */ when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) when a0sym == "try*" then do res = eval(word(astval, 2), env_idx) + if words(astval) < 3 then return res if res == "ERR" then do if word(err, 1) == "__MAL_EXCEPTION__" then errobj = word(err, 2) diff --git a/rexx/stepA_mal.rexx b/rexx/stepA_mal.rexx index fb01015d8f..a9cdfe426a 100644 --- a/rexx/stepA_mal.rexx +++ b/rexx/stepA_mal.rexx @@ -144,6 +144,7 @@ eval: procedure expose values. env. err /* eval(ast) */ when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) when a0sym == "try*" then do res = eval(word(astval, 2), env_idx) + if words(astval) < 3 then return res if res == "ERR" then do if word(err, 1) == "__MAL_EXCEPTION__" then errobj = word(err, 2) From c738a39f7ecd713f47a605ad31851e3fd44cf422 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 21 Feb 2019 11:06:20 +0000 Subject: [PATCH 0467/1998] awk: Support catchless try* --- awk/step9_try.awk | 12 +++++++++--- awk/stepA_mal.awk | 12 +++++++++--- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/awk/step9_try.awk b/awk/step9_try.awk index 23fee5221f..79e9ed1af2 100644 --- a/awk/step9_try.awk +++ b/awk/step9_try.awk @@ -257,11 +257,17 @@ function EVAL_defmacro(ast, env, idx, sym, ret, len) function EVAL_try(ast, env, catch_body, catch_env, idx, catch, catch_idx, catch_sym, ret, len, str) { idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] + len = types_heap[idx]["len"] + if (len != 2 && len != 3) { types_release(ast) env_release(env) - return "!\"Invalid argument length for 'try*'. Expects exactly 2 arguments, supplied" (len - 1) "." + return "!\"Invalid argument length for 'try*'. Expects 1 or 2 arguments, supplied" (len - 1) "." + } + if (len == 2) { + ret = EVAL(types_addref(types_heap[idx][1]), env) + types_release(ast) + env_release(env) + return ret } catch = types_heap[idx][2] if (catch !~ /^\(/) { diff --git a/awk/stepA_mal.awk b/awk/stepA_mal.awk index 06cebcef27..5661c53fef 100644 --- a/awk/stepA_mal.awk +++ b/awk/stepA_mal.awk @@ -257,11 +257,17 @@ function EVAL_defmacro(ast, env, idx, sym, ret, len) function EVAL_try(ast, env, catch_body, catch_env, idx, catch, catch_idx, catch_sym, ret, len, str) { idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] + len = types_heap[idx]["len"] + if (len != 2 && len != 3) { types_release(ast) env_release(env) - return "!\"Invalid argument length for 'try*'. Expects exactly 2 arguments, supplied" (len - 1) "." + return "!\"Invalid argument length for 'try*'. Expects 1 or 2 arguments, supplied" (len - 1) "." + } + if (len == 2) { + ret = EVAL(types_addref(types_heap[idx][1]), env) + types_release(ast) + env_release(env) + return ret } catch = types_heap[idx][2] if (catch !~ /^\(/) { From afc477fbb8774847baf6dc2e40dbe8b01e178dc4 Mon Sep 17 00:00:00 2001 From: Dov Murik Date: Thu, 21 Feb 2019 11:24:13 +0000 Subject: [PATCH 0468/1998] forth: Support catchless try* --- forth/step9_try.fs | 30 +++++++++++++++++------------- forth/stepA_mal.fs | 30 +++++++++++++++++------------- 2 files changed, 34 insertions(+), 26 deletions(-) diff --git a/forth/step9_try.fs b/forth/step9_try.fs index a5626da86a..982fea1f8f 100644 --- a/forth/step9_try.fs +++ b/forth/step9_try.fs @@ -245,20 +245,24 @@ defspecial macroexpand ( env list[_,form] -- form ) defspecial try* { env list -- val } list MalList/start @ cell+ { arg0 } - pre-try - env arg0 @ ['] eval catch ?dup 0= if - nip - else { errno } - begin pre-try = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object + list MalList/count @ 3 < if + env arg0 @ eval + else + pre-try + env arg0 @ ['] eval catch ?dup 0= if + nip + else { errno } + begin pre-try = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + arg0 cell+ @ ( list[catch*,sym,form] ) + MalList/start @ cell+ { catch0 } + env MalEnv. { catch-env } + catch0 @ exception-object catch-env env/set + catch-env catch0 cell+ @ TCO-eval endif - arg0 cell+ @ ( list[catch*,sym,form] ) - MalList/start @ cell+ { catch0 } - env MalEnv. { catch-env } - catch0 @ exception-object catch-env env/set - catch-env catch0 cell+ @ TCO-eval endif ;; MalSymbol diff --git a/forth/stepA_mal.fs b/forth/stepA_mal.fs index 38dcdb6bd8..619ad18595 100644 --- a/forth/stepA_mal.fs +++ b/forth/stepA_mal.fs @@ -245,20 +245,24 @@ defspecial macroexpand ( env list[_,form] -- form ) defspecial try* { env list -- val } list MalList/start @ cell+ { arg0 } - pre-try - env arg0 @ ['] eval catch ?dup 0= if - nip - else { errno } - begin pre-try = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object + list MalList/count @ 3 < if + env arg0 @ eval + else + pre-try + env arg0 @ ['] eval catch ?dup 0= if + nip + else { errno } + begin pre-try = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + arg0 cell+ @ ( list[catch*,sym,form] ) + MalList/start @ cell+ { catch0 } + env MalEnv. { catch-env } + catch0 @ exception-object catch-env env/set + catch-env catch0 cell+ @ TCO-eval endif - arg0 cell+ @ ( list[catch*,sym,form] ) - MalList/start @ cell+ { catch0 } - env MalEnv. { catch-env } - catch0 @ exception-object catch-env env/set - catch-env catch0 cell+ @ TCO-eval endif ;; defspecial . { env coll -- rtn-list } From c2b12e5bbdcfe2da27fa0ee332f4839d6d808c66 Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 25 Feb 2019 16:37:24 +0100 Subject: [PATCH 0469/1998] elisp: Avoid conflict by loading libs from mal/ --- elisp/Makefile | 4 ++-- elisp/{ => mal}/core.el | 2 +- elisp/{mal-env.el => mal/env.el} | 2 +- elisp/{ => mal}/func.el | 2 +- elisp/{ => mal}/printer.el | 2 +- elisp/{ => mal}/reader.el | 2 +- elisp/{ => mal}/types.el | 2 +- elisp/step1_read_print.el | 6 +++--- elisp/step2_eval.el | 6 +++--- elisp/step3_env.el | 8 ++++---- elisp/step4_if_fn_do.el | 10 +++++----- elisp/step5_tco.el | 12 ++++++------ elisp/step6_file.el | 12 ++++++------ elisp/step7_quote.el | 12 ++++++------ elisp/step8_macros.el | 12 ++++++------ elisp/step9_try.el | 12 ++++++------ elisp/stepA_mal.el | 12 ++++++------ 17 files changed, 59 insertions(+), 59 deletions(-) rename elisp/{ => mal}/core.el (99%) rename elisp/{mal-env.el => mal/env.el} (98%) rename elisp/{ => mal}/func.el (95%) rename elisp/{ => mal}/printer.el (98%) rename elisp/{ => mal}/reader.el (99%) rename elisp/{ => mal}/types.el (99%) diff --git a/elisp/Makefile b/elisp/Makefile index 21b02aaded..f554c38b3d 100644 --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,5 +1,5 @@ -SOURCES_BASE = reader.el printer.el types.el -SOURCES_LISP = env.el func.el core.el stepA_mal.el +SOURCES_BASE = mal/reader.el mal/printer.el mal/types.el +SOURCES_LISP = mal/env.el mal/func.el mal/core.el stepA_mal.el SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) all: diff --git a/elisp/core.el b/elisp/mal/core.el similarity index 99% rename from elisp/core.el rename to elisp/mal/core.el index 1d97f16396..76b6149ded 100644 --- a/elisp/core.el +++ b/elisp/mal/core.el @@ -259,4 +259,4 @@ (elisp-eval . ,(mal-fn (lambda (string) (elisp-to-mal (eval (read (mal-value string))))))) )) -(provide 'core) +(provide 'mal/core) diff --git a/elisp/mal-env.el b/elisp/mal/env.el similarity index 98% rename from elisp/mal-env.el rename to elisp/mal/env.el index e7eea800ab..f03902976c 100644 --- a/elisp/mal-env.el +++ b/elisp/mal/env.el @@ -31,4 +31,4 @@ (error "'%s' not found" key) value))) -(provide 'mal-env) +(provide 'mal/env) diff --git a/elisp/func.el b/elisp/mal/func.el similarity index 95% rename from elisp/func.el rename to elisp/mal/func.el index 55b33b6d9f..d4811bbdae 100644 --- a/elisp/func.el +++ b/elisp/mal/func.el @@ -16,4 +16,4 @@ (defun mal-func-macro-p (mal-func) (aref (aref mal-func 1) 4)) -(provide 'func) +(provide 'mal/func) diff --git a/elisp/printer.el b/elisp/mal/printer.el similarity index 98% rename from elisp/printer.el rename to elisp/mal/printer.el index 5c08a04ca5..ca864526d7 100644 --- a/elisp/printer.el +++ b/elisp/mal/printer.el @@ -55,4 +55,4 @@ (nreverse pairs) " "))) (concat "{" items "}")))) -(provide 'printer) +(provide 'mal/printer) diff --git a/elisp/reader.el b/elisp/mal/reader.el similarity index 99% rename from elisp/reader.el rename to elisp/mal/reader.el index 2461bdd59b..401b32bf90 100644 --- a/elisp/reader.el +++ b/elisp/mal/reader.el @@ -154,4 +154,4 @@ (mal-symbol (intern token)))) (signal 'end-of-token-stream nil)))) -(provide 'reader) +(provide 'mal/reader) diff --git a/elisp/types.el b/elisp/mal/types.el similarity index 99% rename from elisp/types.el rename to elisp/mal/types.el index e9d914cafc..4c88e5a12f 100644 --- a/elisp/types.el +++ b/elisp/mal/types.el @@ -101,4 +101,4 @@ Defaults to `error'." (define-error 'end-of-token-stream "End of token stream" 'mal) (define-error 'mal-custom "Custom error" 'mal) -(provide 'types) +(provide 'mal/types) diff --git a/elisp/step1_read_print.el b/elisp/step1_read_print.el index 1f56733837..0ba44e71b4 100644 --- a/elisp/step1_read_print.el +++ b/elisp/step1_read_print.el @@ -1,6 +1,6 @@ -(require 'types) -(require 'reader) -(require 'printer) +(require 'mal/types) +(require 'mal/reader) +(require 'mal/printer) (defun READ (input) (read-str input)) diff --git a/elisp/step2_eval.el b/elisp/step2_eval.el index 8ff9510374..68b66b539b 100644 --- a/elisp/step2_eval.el +++ b/elisp/step2_eval.el @@ -1,6 +1,6 @@ -(require 'types) -(require 'reader) -(require 'printer) +(require 'mal/types) +(require 'mal/reader) +(require 'mal/printer) (defvar repl-env (make-hash-table :test 'eq)) (puthash '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))) repl-env) diff --git a/elisp/step3_env.el b/elisp/step3_env.el index 05dac6d416..9b2516a458 100644 --- a/elisp/step3_env.el +++ b/elisp/step3_env.el @@ -1,7 +1,7 @@ -(require 'types) -(require 'mal-env) -(require 'reader) -(require 'printer) +(require 'mal/types) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) (defvar repl-env (mal-env)) (mal-env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) diff --git a/elisp/step4_if_fn_do.el b/elisp/step4_if_fn_do.el index 21df7b8394..0bf6a255cf 100644 --- a/elisp/step4_if_fn_do.el +++ b/elisp/step4_if_fn_do.el @@ -1,10 +1,10 @@ ;; -*- lexical-binding: t; -*- -(require 'types) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) diff --git a/elisp/step5_tco.el b/elisp/step5_tco.el index 31a9d0c2f0..e3410305ac 100644 --- a/elisp/step5_tco.el +++ b/elisp/step5_tco.el @@ -1,12 +1,12 @@ ;; -*- lexical-binding: t; -*- (setq debug-on-error t) -(require 'types) -(require 'func) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) diff --git a/elisp/step6_file.el b/elisp/step6_file.el index aef72f6c7a..5a5ebb2a1e 100644 --- a/elisp/step6_file.el +++ b/elisp/step6_file.el @@ -1,11 +1,11 @@ ;; -*- lexical-binding: t; -*- -(require 'types) -(require 'func) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) diff --git a/elisp/step7_quote.el b/elisp/step7_quote.el index e31aa34775..f5dfce60c5 100644 --- a/elisp/step7_quote.el +++ b/elisp/step7_quote.el @@ -1,11 +1,11 @@ ;; -*- lexical-binding: t; -*- -(require 'types) -(require 'func) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) diff --git a/elisp/step8_macros.el b/elisp/step8_macros.el index 1e0fa3833e..d9ed1da364 100644 --- a/elisp/step8_macros.el +++ b/elisp/step8_macros.el @@ -1,11 +1,11 @@ ;; -*- lexical-binding: t; -*- -(require 'types) -(require 'func) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) diff --git a/elisp/step9_try.el b/elisp/step9_try.el index d157892dc0..291651ba6e 100644 --- a/elisp/step9_try.el +++ b/elisp/step9_try.el @@ -1,11 +1,11 @@ ;; -*- lexical-binding: t; -*- -(require 'types) -(require 'func) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) diff --git a/elisp/stepA_mal.el b/elisp/stepA_mal.el index 10445bffd9..5aceea3ab9 100644 --- a/elisp/stepA_mal.el +++ b/elisp/stepA_mal.el @@ -1,11 +1,11 @@ ;; -*- lexical-binding: t; -*- -(require 'types) -(require 'func) -(require 'mal-env) -(require 'reader) -(require 'printer) -(require 'core) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) (defvar repl-env (mal-env)) From 5f15d3413557879ef80653ccdd208c76fd9108ba Mon Sep 17 00:00:00 2001 From: Vasilij Schneidermann Date: Mon, 25 Feb 2019 17:03:22 +0100 Subject: [PATCH 0470/1998] elisp: A list of cadr is its cdr --- elisp/step9_try.el | 2 +- elisp/stepA_mal.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/step9_try.el b/elisp/step9_try.el index 291651ba6e..7dc47a9676 100644 --- a/elisp/step9_try.el +++ b/elisp/step9_try.el @@ -123,7 +123,7 @@ (mal-string (error-message-string err)))) (env* (mal-env env (list identifier) (list err*)))) (throw 'return (EVAL form env*))) - (signal (car err) (list (cadr err))))))) + (signal (car err) (cdr err)))))) ((eq a0* 'do) (let* ((a0... (cdr a)) (butlast (butlast a0...)) diff --git a/elisp/stepA_mal.el b/elisp/stepA_mal.el index 5aceea3ab9..ee6a34b778 100644 --- a/elisp/stepA_mal.el +++ b/elisp/stepA_mal.el @@ -123,7 +123,7 @@ (mal-string (error-message-string err)))) (env* (mal-env env (list identifier) (list err*)))) (throw 'return (EVAL form env*))) - (signal (car err) (list (cadr err))))))) + (signal (car err) (cdr err)))))) ((eq a0* 'do) (let* ((a0... (cdr a)) (butlast (butlast a0...)) From 195977ceee0dd302f613444470ce61a0c60ff2ab Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Feb 2019 17:38:05 -0600 Subject: [PATCH 0471/1998] Ignore step5 excludes during REGRESS too. --- Makefile | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/Makefile b/Makefile index 31da504b01..0cda4bf399 100644 --- a/Makefile +++ b/Makefile @@ -117,16 +117,16 @@ regress_step8 = $(regress_step7) step8 regress_step9 = $(regress_step8) step9 regress_stepA = $(regress_step9) stepA -test_EXCLUDES += test^bash^step5 # never completes at 10,000 -test_EXCLUDES += test^basic^step5 # too slow, and limited to ints of 2^16 -test_EXCLUDES += test^logo^step5 # too slow for 10,000 -test_EXCLUDES += test^make^step5 # no TCO capability (iteration or recursion) -test_EXCLUDES += test^mal^step5 # host impl dependent -test_EXCLUDES += test^matlab^step5 # never completes at 10,000 -test_EXCLUDES += test^plpgsql^step5 # too slow for 10,000 -test_EXCLUDES += test^plsql^step5 # too slow for 10,000 -test_EXCLUDES += test^powershell^step5 # too slow for 10,000 -test_EXCLUDES += $(if $(filter cpp,$(haxe_MODE)),test^haxe^step5,) # cpp finishes 10,000, segfaults at 100,000 +step5_EXCLUDES += bash # never completes at 10,000 +step5_EXCLUDES += basic # too slow, and limited to ints of 2^16 +step5_EXCLUDES += logo # too slow for 10,000 +step5_EXCLUDES += make # no TCO capability (iteration or recursion) +step5_EXCLUDES += mal # host impl dependent +step5_EXCLUDES += matlab # never completes at 10,000 +step5_EXCLUDES += plpgsql # too slow for 10,000 +step5_EXCLUDES += plsql # too slow for 10,000 +step5_EXCLUDES += powershell # too slow for 10,000 +step5_EXCLUDES += $(if $(filter cpp,$(haxe_MODE)),haxe,) # cpp finishes 10,000, segfaults at 100,000 dist_EXCLUDES += mal # TODO: still need to implement dist @@ -265,7 +265,10 @@ opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE # test files will include step 2 tests through tests for the step # being tested. STEP_TEST_FILES = $(strip $(wildcard \ - $(foreach s,$(if $(strip $(REGRESS)),$(regress_$(2)),$(2)),\ + $(foreach s,$(if $(strip $(REGRESS)),\ + $(filter-out $(if $(filter $(1),$(step5_EXCLUDES)),step5,),\ + $(regress_$(2)))\ + ,$(2)),\ $(1)/tests/$($(s))$(EXTENSION) tests/$($(s))$(EXTENSION)))) # DOCKERIZE utility functions @@ -318,11 +321,11 @@ get_runtest_cmd = $(call get_run_prefix,$(1),$(2),$(if $(filter cs fsharp tcl vb get_argvtest_cmd = $(call get_run_prefix,$(1),$(2)) ../run_argv_test.sh # Derived lists -STEPS = $(sort $(filter step%,$(.VARIABLES))) +STEPS = $(sort $(filter-out %_EXCLUDES,$(filter step%,$(.VARIABLES)))) DO_IMPLS = $(filter-out $(SKIP_IMPLS),$(IMPLS)) IMPL_TESTS = $(foreach impl,$(DO_IMPLS),test^$(impl)) STEP_TESTS = $(foreach step,$(STEPS),test^$(step)) -ALL_TESTS = $(filter-out $(test_EXCLUDES),\ +ALL_TESTS = $(filter-out $(foreach e,$(step5_EXCLUDES),test^$(e)^step5),\ $(strip $(sort \ $(foreach impl,$(DO_IMPLS),\ $(foreach step,$(STEPS),test^$(impl)^$(step)))))) From 9e6b2a6d870a98ad74b09a1cbd3de4f3d306cf84 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 26 Feb 2019 17:41:50 -0600 Subject: [PATCH 0472/1998] basic: support catchless try* --- basic/step9_try.in.bas | 9 +++++---- basic/stepA_mal.in.bas | 9 +++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basic/step9_try.in.bas b/basic/step9_try.in.bas index 43ced642e2..26a18d771c 100755 --- a/basic/step9_try.in.bas +++ b/basic/step9_try.in.bas @@ -370,19 +370,20 @@ SUB EVAL EVAL_TRY: REM PRINT "try*" - GOSUB EVAL_GET_A1: REM set A1, A2, and A3 + GOSUB EVAL_GET_A1: REM set A1 GOSUB PUSH_A: REM push/save A A=A1:CALL EVAL: REM eval A1 GOSUB POP_A: REM pop/restore A - REM if there is not error or catch block then return - IF ER=-2 OR Z%(A+1)=0 THEN GOTO EVAL_RETURN + GOSUB EVAL_GET_A2: REM set A1 and A2 + + REM if there is no error or catch block then return + IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN REM create environment for the catch block eval C=E:GOSUB ENV_NEW:E=R - GOSUB EVAL_GET_A2: REM set A1 and A2 A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block REM create object for ER=-1 type raw string errors diff --git a/basic/stepA_mal.in.bas b/basic/stepA_mal.in.bas index e4facc5a55..889a89b09c 100755 --- a/basic/stepA_mal.in.bas +++ b/basic/stepA_mal.in.bas @@ -367,19 +367,20 @@ SUB EVAL EVAL_TRY: REM PRINT "try*" - GOSUB EVAL_GET_A1: REM set A1, A2, and A3 + GOSUB EVAL_GET_A1: REM set A1 GOSUB PUSH_A: REM push/save A A=A1:CALL EVAL: REM eval A1 GOSUB POP_A: REM pop/restore A - REM if there is not error or catch block then return - IF ER=-2 OR Z%(A+1)=0 THEN GOTO EVAL_RETURN + GOSUB EVAL_GET_A2: REM set A1 and A2 + + REM if there is no error or catch block then return + IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN REM create environment for the catch block eval C=E:GOSUB ENV_NEW:E=R - GOSUB EVAL_GET_A2: REM set A1 and A2 A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block REM create object for ER=-1 type raw string errors From 757ebbfbbf93ba96aee66dd956159b8c8ff79831 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 27 Feb 2019 16:39:23 -0600 Subject: [PATCH 0473/1998] crystal, kotlin, mal, scala: Support catchless try* --- crystal/step9_try.cr | 2 +- crystal/stepA_mal.cr | 2 +- kotlin/src/mal/step9_try.kt | 25 +++++++++++++------------ kotlin/src/mal/stepA_mal.kt | 1 + mal/step9_try.mal | 7 ++++--- mal/stepA_mal.mal | 7 ++++--- scala/step9_try.scala | 1 + scala/stepA_mal.scala | 1 + 8 files changed, 26 insertions(+), 20 deletions(-) diff --git a/crystal/step9_try.cr b/crystal/step9_try.cr index 99314c030a..0de286ff81 100755 --- a/crystal/step9_try.cr +++ b/crystal/step9_try.cr @@ -207,7 +207,7 @@ module Mal when "macroexpand" macroexpand(list[1], env) when "try*" - catch_list = list[2].unwrap + catch_list = list.size >= 3 ? list[2].unwrap : Mal::Type.new(nil) return eval(list[1], env) unless catch_list.is_a? Mal::List catch_head = catch_list.first.unwrap diff --git a/crystal/stepA_mal.cr b/crystal/stepA_mal.cr index 03727aff19..bf1a201a0e 100755 --- a/crystal/stepA_mal.cr +++ b/crystal/stepA_mal.cr @@ -214,7 +214,7 @@ module Mal when "macroexpand" macroexpand(list[1], env) when "try*" - catch_list = list[2].unwrap + catch_list = list.size >= 3 ? list[2].unwrap : Mal::Type.new(nil) return eval(list[1], env) unless catch_list.is_a? Mal::List catch_head = catch_list.first.unwrap diff --git a/kotlin/src/mal/step9_try.kt b/kotlin/src/mal/step9_try.kt index ddead51e72..03d44f4e61 100644 --- a/kotlin/src/mal/step9_try.kt +++ b/kotlin/src/mal/step9_try.kt @@ -142,18 +142,19 @@ private fun defmacro(ast: MalList, env: Env): MalType { } private fun try_catch(ast: MalList, env: Env): MalType = - try { - eval(ast.nth(1), env) - } catch (e: Exception) { - val thrown = if (e is MalException) e else MalException(e.message) - val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol - - val catchBody = (ast.nth(2) as MalList).nth(2) - val catchEnv = Env(env) - catchEnv.set(symbol, thrown) - - eval(catchBody, catchEnv) - } + try { + eval(ast.nth(1), env) + } catch (e: Exception) { + if (ast.count() < 3) { throw e } + val thrown = if (e is MalException) e else MalException(e.message) + val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol + + val catchBody = (ast.nth(2) as MalList).nth(2) + val catchEnv = Env(env) + catchEnv.set(symbol, thrown) + + eval(catchBody, catchEnv) + } fun print(result: MalType) = pr_str(result, print_readably = true) diff --git a/kotlin/src/mal/stepA_mal.kt b/kotlin/src/mal/stepA_mal.kt index 062d2fa0b8..5bf73632db 100644 --- a/kotlin/src/mal/stepA_mal.kt +++ b/kotlin/src/mal/stepA_mal.kt @@ -145,6 +145,7 @@ private fun try_catch(ast: MalList, env: Env): MalType = try { eval(ast.nth(1), env) } catch (e: Exception) { + if (ast.count() < 3) { throw e } val thrown = if (e is MalException) e else MalException(e.message) val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol diff --git a/mal/step9_try.mal b/mal/step9_try.mal index 4e52a1b3c6..2975a5043e 100644 --- a/mal/step9_try.mal +++ b/mal/step9_try.mal @@ -110,15 +110,16 @@ (MACROEXPAND a1 env)) (= 'try* a0) - (if (= 'catch* (nth (nth ast 2) 0)) + (if (or (< (count ast) 3) + (not (= 'catch* (nth (nth ast 2) 0)))) + (EVAL (nth ast 1) env) (try* (EVAL (nth ast 1) env) (catch* exc (EVAL (nth (nth ast 2) 2) (new-env env [(nth (nth ast 2)1)] - [exc])))) - (EVAL (nth ast 1) env)) + [exc]))))) (= 'do a0) (let* [el (eval-ast (rest ast) env)] diff --git a/mal/stepA_mal.mal b/mal/stepA_mal.mal index d4e53de505..9f0af0e8ec 100644 --- a/mal/stepA_mal.mal +++ b/mal/stepA_mal.mal @@ -110,15 +110,16 @@ (MACROEXPAND a1 env)) (= 'try* a0) - (if (= 'catch* (nth (nth ast 2) 0)) + (if (or (< (count ast) 3) + (not (= 'catch* (nth (nth ast 2) 0)))) + (EVAL (nth ast 1) env) (try* (EVAL (nth ast 1) env) (catch* exc (EVAL (nth (nth ast 2) 2) (new-env env [(nth (nth ast 2)1)] - [exc])))) - (EVAL (nth ast 1) env)) + [exc]))))) (= 'do a0) (let* [el (eval-ast (rest ast) env)] diff --git a/scala/step9_try.scala b/scala/step9_try.scala index 068a43d65f..cc997bbe62 100644 --- a/scala/step9_try.scala +++ b/scala/step9_try.scala @@ -126,6 +126,7 @@ object step9_try { return EVAL(a1, env) } catch { case t: Throwable => { + if (rest.length == 0) throw t rest(0).asInstanceOf[MalList].value match { case List(Symbol("catch*"), a21, a22) => { val exc: Any = t match { diff --git a/scala/stepA_mal.scala b/scala/stepA_mal.scala index 91a6169c76..a3abbc3ac9 100644 --- a/scala/stepA_mal.scala +++ b/scala/stepA_mal.scala @@ -126,6 +126,7 @@ object stepA_mal { return EVAL(a1, env) } catch { case t: Throwable => { + if (rest.length == 0) throw t rest(0).asInstanceOf[MalList].value match { case List(Symbol("catch*"), a21, a22) => { val exc: Any = t match { From dc191336f8896205ed114c7dfcb31dd97addf2ad Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 27 Feb 2019 17:06:14 -0600 Subject: [PATCH 0474/1998] objpascal, r: Support catchless try*. --- objpascal/step9_try.pas | 2 ++ objpascal/stepA_mal.pas | 2 ++ r/step8_macros.r | 5 ++--- r/step9_try.r | 7 +++---- r/stepA_mal.r | 7 +++---- 5 files changed, 12 insertions(+), 11 deletions(-) diff --git a/objpascal/step9_try.pas b/objpascal/step9_try.pas index 7df833d937..d8c5960f64 100644 --- a/objpascal/step9_try.pas +++ b/objpascal/step9_try.pas @@ -215,6 +215,8 @@ function EVAL(Ast: TMal; Env: TEnv) : TMal; except On E : Exception do begin + if Length(Arr) < 3 then + raise; SetLength(Err, 1); if E.ClassType = TMalException then Err[0] := (E as TMalException).Val diff --git a/objpascal/stepA_mal.pas b/objpascal/stepA_mal.pas index bf5afdfa41..1e8762e3a3 100644 --- a/objpascal/stepA_mal.pas +++ b/objpascal/stepA_mal.pas @@ -215,6 +215,8 @@ function EVAL(Ast: TMal; Env: TEnv) : TMal; except On E : Exception do begin + if Length(Arr) < 3 then + raise; SetLength(Err, 1); if E.ClassType = TMalException then Err[0] := (E as TMalException).Val diff --git a/r/step8_macros.r b/r/step8_macros.r index 012aa7c9bc..d8d3ba192f 100644 --- a/r/step8_macros.r +++ b/r/step8_macros.r @@ -75,9 +75,8 @@ EVAL <- function(ast, env) { repeat { #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } + if (!.list_q(ast)) { return(eval_ast(ast, env)) } + if (length(ast) == 0) { return(ast) } # apply list ast <- macroexpand(ast, env) diff --git a/r/step9_try.r b/r/step9_try.r index 2575baac34..049d660542 100644 --- a/r/step9_try.r +++ b/r/step9_try.r @@ -75,9 +75,8 @@ EVAL <- function(ast, env) { repeat { #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } + if (!.list_q(ast)) { return(eval_ast(ast, env)) } + if (length(ast) == 0) { return(ast) } # apply list ast <- macroexpand(ast, env) @@ -122,7 +121,7 @@ EVAL <- function(ast, env) { new.list(a2[[2]]), new.list(edata$exc)))) } else { - throw(err) + throw(edata$exc) } } else if (a0sym == "do") { eval_ast(slice(ast,2,length(ast)-1), env) diff --git a/r/stepA_mal.r b/r/stepA_mal.r index ecdb89cfbf..edf41de4ae 100644 --- a/r/stepA_mal.r +++ b/r/stepA_mal.r @@ -75,9 +75,8 @@ EVAL <- function(ast, env) { repeat { #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } + if (!.list_q(ast)) { return(eval_ast(ast, env)) } + if (length(ast) == 0) { return(ast) } # apply list ast <- macroexpand(ast, env) @@ -122,7 +121,7 @@ EVAL <- function(ast, env) { new.list(a2[[2]]), new.list(edata$exc)))) } else { - throw(err) + throw(edata$exc) } } else if (a0sym == "do") { eval_ast(slice(ast,2,length(ast)-1), env) From 5d991812844506f3b1fb69822324ae286c8090a4 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 28 Feb 2019 17:36:45 -0600 Subject: [PATCH 0475/1998] cpp, racket: Support catchless try* --- cpp/step9_try.cpp | 7 ++++++- cpp/stepA_mal.cpp | 27 +++++++++++++++++---------- racket/step9_try.rkt | 7 ++++--- racket/stepA_mal.rkt | 7 ++++--- 4 files changed, 31 insertions(+), 17 deletions(-) diff --git a/cpp/step9_try.cpp b/cpp/step9_try.cpp index 62933bdfc5..f3f2ddbac1 100644 --- a/cpp/step9_try.cpp +++ b/cpp/step9_try.cpp @@ -184,8 +184,13 @@ malValuePtr EVAL(malValuePtr ast, malEnvPtr env) } if (special == "try*") { - checkArgsIs("try*", 2, argCount); malValuePtr tryBody = list->item(1); + + if (argCount == 1) { + ast = EVAL(tryBody, env); + continue; // TCO + } + checkArgsIs("try*", 2, argCount); const malList* catchBlock = VALUE_CAST(malList, list->item(2)); checkArgsIs("catch*", 2, catchBlock->count() - 1); diff --git a/cpp/stepA_mal.cpp b/cpp/stepA_mal.cpp index cda56f08cb..87cd3ac5fe 100644 --- a/cpp/stepA_mal.cpp +++ b/cpp/stepA_mal.cpp @@ -185,8 +185,13 @@ malValuePtr EVAL(malValuePtr ast, malEnvPtr env) } if (special == "try*") { - checkArgsIs("try*", 2, argCount); malValuePtr tryBody = list->item(1); + + if (argCount == 1) { + ast = EVAL(tryBody, env); + continue; // TCO + } + checkArgsIs("try*", 2, argCount); const malList* catchBlock = VALUE_CAST(malList, list->item(2)); checkArgsIs("catch*", 2, catchBlock->count() - 1); @@ -336,15 +341,6 @@ static void installMacros(malEnvPtr env) } } -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - static const char* malFunctionTable[] = { "(def! list (fn* (& items) items))", "(def! not (fn* (cond) (if cond false true)))", @@ -365,3 +361,14 @@ static void installFunctions(malEnvPtr env) { rep(function, env); } } + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/racket/step9_try.rkt b/racket/step9_try.rkt index 9cecd2af6f..79f21b63b4 100755 --- a/racket/step9_try.rkt +++ b/racket/step9_try.rkt @@ -79,7 +79,9 @@ [(eq? 'macroexpand a0) (macroexpand (_nth ast 1) env)] [(eq? 'try* a0) - (if (eq? 'catch* (_nth (_nth ast 2) 0)) + (if (or (< (length ast) 3) + (not (eq? 'catch* (_nth (_nth ast 2) 0)))) + (EVAL (_nth ast 1) env) (let ([efn (lambda (exc) (EVAL (_nth (_nth ast 2) 2) (new Env% @@ -90,8 +92,7 @@ ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] [string? (lambda (exc) (efn exc))] [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) - (EVAL (_nth ast 1) env))) - (EVAL (_nth ast 1)))] + (EVAL (_nth ast 1) env))))] [(eq? 'do a0) (eval-ast (drop (drop-right ast 1) 1) env) (EVAL (last ast) env)] diff --git a/racket/stepA_mal.rkt b/racket/stepA_mal.rkt index 813d0eb708..875ef3b45a 100755 --- a/racket/stepA_mal.rkt +++ b/racket/stepA_mal.rkt @@ -79,7 +79,9 @@ [(eq? 'macroexpand a0) (macroexpand (_nth ast 1) env)] [(eq? 'try* a0) - (if (eq? 'catch* (_nth (_nth ast 2) 0)) + (if (or (< (length ast) 3) + (not (eq? 'catch* (_nth (_nth ast 2) 0)))) + (EVAL (_nth ast 1) env) (let ([efn (lambda (exc) (EVAL (_nth (_nth ast 2) 2) (new Env% @@ -90,8 +92,7 @@ ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] [string? (lambda (exc) (efn exc))] [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) - (EVAL (_nth ast 1) env))) - (EVAL (_nth ast 1)))] + (EVAL (_nth ast 1) env))))] [(eq? 'do a0) (eval-ast (drop (drop-right ast 1) 1) env) (EVAL (last ast) env)] From bb1e6df66300c60075fcc6b03c8359ed865ba23d Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 28 Feb 2019 17:36:54 -0600 Subject: [PATCH 0476/1998] elixir, elm, erlang: Support catchless try*. --- elixir/lib/mix/tasks/step9_try.ex | 3 +++ elixir/lib/mix/tasks/stepA_mal.ex | 3 +++ elm/step9_try.elm | 2 ++ elm/stepA_mal.elm | 2 ++ erlang/src/step9_try.erl | 2 ++ erlang/src/stepA_mal.erl | 2 ++ 6 files changed, 14 insertions(+) diff --git a/elixir/lib/mix/tasks/step9_try.ex b/elixir/lib/mix/tasks/step9_try.ex index 036952a647..b1b94c8ef2 100644 --- a/elixir/lib/mix/tasks/step9_try.ex +++ b/elixir/lib/mix/tasks/step9_try.ex @@ -232,6 +232,9 @@ defmodule Mix.Tasks.Step9Try do defp eval_list([{:symbol, "try*"}, try_form, {:list, catch_list, _meta}], env, _) do eval_try(try_form, catch_list, env) end + defp eval_list([{:symbol, "try*"}, try_form], env, _) do + eval(try_form, env) + end defp eval_list([{:symbol, "try*"}, _try_form, _], _env, _) do throw({:error, "try* requires a list as the second parameter"}) end diff --git a/elixir/lib/mix/tasks/stepA_mal.ex b/elixir/lib/mix/tasks/stepA_mal.ex index af7586eb13..c827b06040 100644 --- a/elixir/lib/mix/tasks/stepA_mal.ex +++ b/elixir/lib/mix/tasks/stepA_mal.ex @@ -251,6 +251,9 @@ defmodule Mix.Tasks.StepAMal do defp eval_list([{:symbol, "try*"}, try_form, {:list, catch_list, _meta}], env, _) do eval_try(try_form, catch_list, env) end + defp eval_list([{:symbol, "try*"}, try_form], env, _) do + eval(try_form, env) + end defp eval_list([{:symbol, "try*"}, _try_form, _], _env, _) do throw({:error, "try* requires a list as the second parameter"}) end diff --git a/elm/step9_try.elm b/elm/step9_try.elm index 90e04418ad..44b3180c1d 100644 --- a/elm/step9_try.elm +++ b/elm/step9_try.elm @@ -700,6 +700,8 @@ macroexpand expr = evalTry : List MalExpr -> Eval MalExpr evalTry args = case args of + [ body ] -> + eval body [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> eval body |> Eval.catchError diff --git a/elm/stepA_mal.elm b/elm/stepA_mal.elm index 5b28c60afd..83aed32135 100644 --- a/elm/stepA_mal.elm +++ b/elm/stepA_mal.elm @@ -716,6 +716,8 @@ macroexpand expr = evalTry : List MalExpr -> Eval MalExpr evalTry args = case args of + [ body ] -> + eval body [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> eval body |> Eval.catchError diff --git a/erlang/src/step9_try.erl b/erlang/src/step9_try.erl index 9ca6303cd1..c35da92f47 100644 --- a/erlang/src/step9_try.erl +++ b/erlang/src/step9_try.erl @@ -142,6 +142,8 @@ eval_list({list, [{symbol, "try*"}, A, {list, [{symbol, "catch*"}, B, C], _M1}], env:bind(NewEnv, [B], [Reason]), eval(C, NewEnv) end; +eval_list({list, [{symbol, "try*"}, AST], _Meta}, Env) -> + eval(AST, Env); eval_list({list, [{symbol, "try*"}|_], _Meta}, _Env) -> error("try*/catch* must be of the form (try* A (catch* B C))"); eval_list({list, List, Meta}, Env) -> diff --git a/erlang/src/stepA_mal.erl b/erlang/src/stepA_mal.erl index f848b91503..b60fdf7fcd 100644 --- a/erlang/src/stepA_mal.erl +++ b/erlang/src/stepA_mal.erl @@ -146,6 +146,8 @@ eval_list({list, [{symbol, "try*"}, A, {list, [{symbol, "catch*"}, B, C], _M1}], env:bind(NewEnv, [B], [Reason]), eval(C, NewEnv) end; +eval_list({list, [{symbol, "try*"}, AST], _Meta}, Env) -> + eval(AST, Env); eval_list({list, [{symbol, "try*"}|_], _Meta}, _Env) -> error("try*/catch* must be of the form (try* A (catch* B C))"); eval_list({list, List, Meta}, Env) -> From e005219d76c2ee928caf47328a97947e96293660 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 2 Mar 2019 18:52:03 +0000 Subject: [PATCH 0477/1998] Add catchless try to step 9 and step A (try* A) evaluates A without setting an error handler. --- nasm/step9_try.asm | 19 ++++++++++++++++++- nasm/stepA_mal.asm | 19 ++++++++++++++++++- 2 files changed, 36 insertions(+), 2 deletions(-) diff --git a/nasm/step9_try.asm b/nasm/step9_try.asm index a9657287f1..ea5209a7b0 100644 --- a/nasm/step9_try.asm +++ b/nasm/step9_try.asm @@ -1524,6 +1524,10 @@ eval: ; Check second arg B mov al, BYTE [rsi + Cons.typecdr] + ; If nil (catchless try) + cmp al, content_nil + je .catchless_try + cmp al, content_pointer jne .try_missing_catch @@ -1575,7 +1579,7 @@ eval: ; Now have extracted from (try* A (catch* B C)) ; A in R8 ; B in R10 - ; C in T9 + ; C in R9 push R9 push R10 @@ -1610,7 +1614,20 @@ eval: call error_handler_pop mov rax, r8 jmp .return + +.catchless_try: + ; Evaluate the form in R8 + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + call eval ; Result in RAX + + jmp .return .catch: ; Jumps here on error ; Value thrown in RSI diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index 1a5014f4d1..a326dbeaf0 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -1539,6 +1539,10 @@ eval: ; Check second arg B mov al, BYTE [rsi + Cons.typecdr] + ; If nil (catchless try) + cmp al, content_nil + je .catchless_try + cmp al, content_pointer jne .try_missing_catch @@ -1590,7 +1594,7 @@ eval: ; Now have extracted from (try* A (catch* B C)) ; A in R8 ; B in R10 - ; C in T9 + ; C in R9 push R9 push R10 @@ -1625,7 +1629,20 @@ eval: call error_handler_pop mov rax, r8 jmp .return + +.catchless_try: + ; Evaluate the form in R8 + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + call eval ; Result in RAX + + jmp .return .catch: ; Jumps here on error ; Value thrown in RSI From 022e8339878612ce248a92b2fe1d14cd658323d0 Mon Sep 17 00:00:00 2001 From: Ben Dudson Date: Sat, 2 Mar 2019 21:20:50 +0000 Subject: [PATCH 0478/1998] Push and pop environment in catchless try Need to remember to save and restore R15 with the environment pointer. --- nasm/step9_try.asm | 6 +++++- nasm/stepA_mal.asm | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/nasm/step9_try.asm b/nasm/step9_try.asm index ea5209a7b0..40645702e9 100644 --- a/nasm/step9_try.asm +++ b/nasm/step9_try.asm @@ -1616,7 +1616,9 @@ eval: jmp .return .catchless_try: - ; Evaluate the form in R8 + ;; Evaluate the form in R8 + push r15 ; Environment + mov rsi, r15 call incref_object ; Env released by eval mov rdi, r15 ; Env in RDI @@ -1626,6 +1628,8 @@ eval: call incref_object ; AST released by eval call eval ; Result in RAX + + pop r15 ; Environment jmp .return .catch: diff --git a/nasm/stepA_mal.asm b/nasm/stepA_mal.asm index a326dbeaf0..0bf675b8c6 100644 --- a/nasm/stepA_mal.asm +++ b/nasm/stepA_mal.asm @@ -1631,7 +1631,9 @@ eval: jmp .return .catchless_try: - ; Evaluate the form in R8 + ;; Evaluate the form in R8 + push r15 ; Environment + mov rsi, r15 call incref_object ; Env released by eval mov rdi, r15 ; Env in RDI @@ -1641,6 +1643,8 @@ eval: call incref_object ; AST released by eval call eval ; Result in RAX + + pop r15 ; Environment jmp .return .catch: From bdda2112954715824e26b877da528b2e6b6e6713 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E9=99=86=E9=81=A5?= Date: Tue, 5 Mar 2019 16:40:22 +0800 Subject: [PATCH 0479/1998] add swift4 impliment. --- swift4/Dockerfile | 44 ++++ swift4/Makefile | 40 ++++ swift4/Sources/core.swift | 216 ++++++++++++++++++++ swift4/Sources/env.swift | 50 +++++ swift4/Sources/printer.swift | 58 ++++++ swift4/Sources/reader.swift | 154 ++++++++++++++ swift4/Sources/step0_repl/main.swift | 32 +++ swift4/Sources/step1_read_print/main.swift | 38 ++++ swift4/Sources/step2_eval/main.swift | 85 ++++++++ swift4/Sources/step3_env/main.swift | 101 ++++++++++ swift4/Sources/step4_if_fn_do/main.swift | 115 +++++++++++ swift4/Sources/step5_tco/main.swift | 145 ++++++++++++++ swift4/Sources/step6_file/main.swift | 143 +++++++++++++ swift4/Sources/step7_quote/main.swift | 165 +++++++++++++++ swift4/Sources/step8_macros/main.swift | 196 ++++++++++++++++++ swift4/Sources/step9_try/main.swift | 215 ++++++++++++++++++++ swift4/Sources/stepA_mal/main.swift | 221 +++++++++++++++++++++ swift4/Sources/types.swift | 166 ++++++++++++++++ swift4/run | 2 + 19 files changed, 2186 insertions(+) create mode 100644 swift4/Dockerfile create mode 100644 swift4/Makefile create mode 100644 swift4/Sources/core.swift create mode 100644 swift4/Sources/env.swift create mode 100644 swift4/Sources/printer.swift create mode 100644 swift4/Sources/reader.swift create mode 100644 swift4/Sources/step0_repl/main.swift create mode 100644 swift4/Sources/step1_read_print/main.swift create mode 100644 swift4/Sources/step2_eval/main.swift create mode 100644 swift4/Sources/step3_env/main.swift create mode 100644 swift4/Sources/step4_if_fn_do/main.swift create mode 100644 swift4/Sources/step5_tco/main.swift create mode 100644 swift4/Sources/step6_file/main.swift create mode 100644 swift4/Sources/step7_quote/main.swift create mode 100644 swift4/Sources/step8_macros/main.swift create mode 100644 swift4/Sources/step9_try/main.swift create mode 100644 swift4/Sources/stepA_mal/main.swift create mode 100644 swift4/Sources/types.swift create mode 100755 swift4/run diff --git a/swift4/Dockerfile b/swift4/Dockerfile new file mode 100644 index 0000000000..744f62b17c --- /dev/null +++ b/swift4/Dockerfile @@ -0,0 +1,44 @@ +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Swift +RUN apt-get -y install clang-3.6 cmake pkg-config \ + git ninja-build uuid-dev libicu-dev icu-devtools \ + libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ + swig libpython-dev libncurses5-dev + +# TODO: better way to do this? +RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ +RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang + +ENV SWIFT_PREFIX swift-4.2.3-RELEASE +ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 + +RUN cd /opt && \ + curl -O https://swift.org/builds/swift-4.2.3-release/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ + tar xvzf ${SWIFT_RELEASE}.tar.gz && \ + rm ${SWIFT_RELEASE}.tar.gz + +ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH + + diff --git a/swift4/Makefile b/swift4/Makefile new file mode 100644 index 0000000000..1a16beae7c --- /dev/null +++ b/swift4/Makefile @@ -0,0 +1,40 @@ +ifneq ($(shell which xcrun),) + SWIFT = xcrun -sdk macosx swiftc +else + SWIFT = swiftc +endif + +STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift +STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift + +SOURCES = $(STEP4_DEPS) Sources/stepA_mal/main.swift +SOURCES_LISP = Sources/env.swift Sources/core.swift Sources/stepA_mal/main.swift + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +all: $(STEPS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +step1_read_print step2_eval step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + +step%: Sources/step%/main.swift + $(SWIFT) $+ -o $@ + +clean: + rm -f $(STEPS) mal + +.PHONY: stats tests + +stats: $(SOURCES) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +stats-lisp: $(SOURCES_LISP) + @wc $^ + @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/swift4/Sources/core.swift b/swift4/Sources/core.swift new file mode 100644 index 0000000000..cc9b2a9c4d --- /dev/null +++ b/swift4/Sources/core.swift @@ -0,0 +1,216 @@ +// +// core.swift +// swift4 +// +// Created by LuLouie on 2019/1/10. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { + guard args.count == 2, args[0] is Number, args[1] is Number else { + throw MalError.InvalidArgument + } + return op(args[0] as! Number, args[1] as! Number) +} + +func isEqualList(_ l: [MalData], _ r: [MalData]) -> Bool { + guard l.count == r.count else { + return false + } + for i in l.indices { + if !isEqual(l[i], r[i]) { return false } + } + return true +} + +func isEqualHashMap (_ l: [String: MalData], _ r: [String: MalData]) -> Bool { + guard l.count == r.count else { + return false + } + for key in l.keys { + guard let lValue = l[key], let rValue = r[key] else { return false } + if !isEqual(lValue, rValue) { return false } + } + return true +} + +func isEqual(_ l: MalData, _ r: MalData) -> Bool { + switch (l.dataType, r.dataType) { + case (.Symbol, .Symbol): + return (l as! Symbol).name == (r as! Symbol).name + case (.String, .String), (.Keyword, .Keyword): + return (l as! String) == (r as! String) + case (.Number, .Number): + return (l as! Number) == (r as! Number) + case (.List, .List), (.Vector, .Vector), (.List, .Vector), (. Vector, .List): + return isEqualList(l.listForm, r.listForm) + case (.HashMap, .HashMap): + return isEqualHashMap((l as! [String: MalData]), (r as! [String: MalData])) + case (.Nil, .Nil), (.True, .True), (.False, .False): + return true + default: // atom, function + return false + } +} + +func hashMap(fromList list: [MalData]) throws -> [String: MalData] { + var hashMap: [String: MalData] = [:] + for index in stride(from: 0, to: list.count, by: 2) { + guard list[index] is String, index+1 < list.count else { throw MalError.Error } + hashMap.updateValue(list[index+1], forKey: list[index] as! String) + } + return hashMap +} + +let ns: [String: ([MalData]) throws -> MalData] = + ["+": { try calculate($0, op: +) }, + "-": { try calculate($0, op: -) }, + "*": { try calculate($0, op: *) }, + "/": { try calculate($0, op: /) }, + "<": { args in (args[0] as! Number) < (args[1] as! Number) }, + ">": { args in (args[0] as! Number) > (args[1] as! Number) }, + "<=": { args in (args[0] as! Number) <= (args[1] as! Number) }, + ">=": { args in (args[0] as! Number) >= (args[1] as! Number) }, + + "=": { args in let left = args[0], right = args[1]; return isEqual(left, right) }, + + "pr-str": { $0.map { pr_str($0, print_readably: true)}.joined(separator: " ") }, + "str": { $0.map { pr_str($0, print_readably: false)}.joined(separator: "") }, + "prn": { print($0.map { pr_str($0, print_readably: true)}.joined(separator: " ")); return Nil() }, + "println": { print($0.map { pr_str($0, print_readably: false)}.joined(separator: " ")); return Nil() }, + + "list": { List($0) }, + "list?": { let param = $0[0]; return param is [MalData] }, + "empty?": { $0[0].count == 0 }, + "count": { $0[0].count }, + + "read-string": { try read_str($0[0] as! String) }, + "slurp": { try String(contentsOfFile: $0[0] as! String) }, + + "atom": { Atom($0[0]) }, + "atom?": { $0[0] is Atom }, + "deref": { ($0[0] as? Atom)?.value ?? Nil() }, + "reset!": { args in (args[0] as! Atom).value = args[1]; return args[1] }, + "swap!": { args in + let atom = args[0] as! Atom, fn = args[1] as! Function, + others = args.dropFirst(2).listForm + atom.value = try fn.fn([atom.value] + others) + return atom.value + }, + "cons": { args in [args[0]] + args[1].listForm }, + "concat": { $0.reduce([]) { (result, array ) in result + array.listForm } }, + + "nth": { args in + let list = args[0].listForm, i = args[1] as! Int + guard list.indices.contains(i) else { throw MalError.IndexOutOfBounds } + return list[i] + }, + "first": { $0[0].listForm.first ?? Nil() }, + "rest": { $0[0].listForm.dropFirst().listForm }, + + "throw": { throw MalError.MalException($0[0]) }, + "apply": { args in + let fn = args[0] as! Function + let newArgs = args.dropFirst().dropLast().listForm + args.last!.listForm + return try fn.fn(newArgs) + }, + "map": { args in + let fn = args[0] as! Function + let closure = fn.fn + var result: [MalData] = [] + for element in args[1].listForm { + result.append(try fn.fn([element])) } + return result + }, + + "nil?": { $0[0] is Nil }, + "true?": { $0[0].dataType == .True }, + "false?": { $0[0].dataType == .False }, + "symbol?": { $0[0].dataType == .Symbol }, + "symbol": { Symbol($0[0] as! String) }, + "keyword": { ($0[0].dataType == .Keyword) ? $0[0] : "\u{029E}" + ($0[0] as! String) }, + "keyword?":{ $0[0].dataType == .Keyword }, + "vector": { Vector($0) }, + "vector?": { $0[0].dataType == .Vector }, + "hash-map":{ try hashMap(fromList: $0) }, + "map?": { $0[0].dataType == .HashMap }, + "assoc": { + let map = $0[0] as! [String: MalData] + return map.merging(try hashMap(fromList: $0.dropFirst().listForm)) { (_, new) in new } + }, + "dissoc": { args in + let map = args[0] as! [String: MalData] + return map.filter { (key, _) in !(args.dropFirst().listForm as! [String]).contains(key) } + }, + "get": { + if let map = $0[0] as? [String: MalData] { + return map[$0[1] as! String] ?? Nil() } + return Nil() + }, + "contains?": { ($0[0] as! [String: MalData])[$0[1] as! String] != nil }, + "keys": { + ($0[0] as! [String: MalData]).reduce([]) { result, element in + let (key, _) = element + return result + [key] } + }, + "vals": { + ($0[0] as! [String: MalData]).reduce([]) { result, element in + let (_, value) = element + return result + [value] } + }, + "sequential?": { [.List, .Vector].contains($0[0].dataType) }, + + "readline": { + print($0[0] as! String, terminator: "") + return readLine(strippingNewline: true) ?? Nil() }, + + "meta": { + switch $0[0].dataType { + case .Function: + return ($0[0] as! Function).meta ?? Nil() + default: + return Nil() + }}, + "with-meta": { + switch $0[0].dataType { + case .Function: + return Function(withFunction: $0[0] as! Function, meta: $0[1]) + default: + return $0[0] + }}, + "time-ms": { _ in Int(Date().timeIntervalSince1970 * 1000) }, + "conj": { + if let list = $0[0] as? [MalData] { + return $0.dropFirst().reversed().listForm + list + } else { // vector + return ($0[0] as! Vector) + Vector($0.dropFirst()) + }}, + "string?": { $0[0].dataType == .String }, + "number?": { $0[0].dataType == .Number }, + "fn?": { + if let fn = $0[0] as? Function { + return !fn.isMacro + } else { + return false + }}, + "macro?": { + if let fn = $0[0] as? Function { + return fn.isMacro + } else { + return false + }}, + "seq": { + if $0[0].count == 0 { return Nil() } + switch $0[0].dataType { + case .List: + return $0[0] as! List + case .Vector: + return List($0[0] as! ContiguousArray) + case .String: + return List($0[0] as! String).map { String($0) } + default: + return Nil() + }}, +] diff --git a/swift4/Sources/env.swift b/swift4/Sources/env.swift new file mode 100644 index 0000000000..6b43500508 --- /dev/null +++ b/swift4/Sources/env.swift @@ -0,0 +1,50 @@ +// +// env.swift +// swift4 +// +// Created by LuLouie on 2019/1/7. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +class Env { + let outer: Env? + var data: [String: MalData] = [:] + + init(outer: Env) { + self.outer = outer + } + init() { + outer = nil + } + init(binds: [Symbol], exprs: [MalData], outer: Env) { + self.outer = outer + self.data = [:] + for i in binds.indices { + if binds[i].name == "&" { + data.updateValue(List(exprs[i.. Env? { + if let _ = data[key.name] { + return self + } else { + return outer?.find(key) + } + } + func get(forKey key: Symbol) throws -> MalData { + if let env = find(key), let value = env.data[key.name] { + return value + } else { + throw MalError.SymbolNotFound(key) + } + } +} diff --git a/swift4/Sources/printer.swift b/swift4/Sources/printer.swift new file mode 100644 index 0000000000..c55d4f7c68 --- /dev/null +++ b/swift4/Sources/printer.swift @@ -0,0 +1,58 @@ +// +// printer.swift +// swift4 +// +// Created by LuLouie on 2019/1/7. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func pr_str(_ input: MalData, print_readably: Bool) -> String { + switch input.dataType { + case .Symbol: + let symbol = input as! Symbol + return symbol.name + case .Number: + let number = input as! Number + return String(number) + case .True: + return "true" + case .False: + return "false" + case .Nil: + return "nil" + case .Keyword: + let keyword = input as! String + return keyword.replacingCharacters(in: keyword.startIndex...keyword.startIndex, with: ":") + case .String: + let string = input as! String + if print_readably { + return "\"" + string.replacingOccurrences(of: "\\", with: "\\\\") + .replacingOccurrences(of: "\"", with: "\\\"") + .replacingOccurrences(of: "\n", with: "\\n") + "\"" + } else { + return string + } + case .List: + let list = input as! List + let stringOfElements = list.map { pr_str($0, print_readably: print_readably) }.joined(separator: " ") + return "(" + stringOfElements + ")" + case .Vector: + let vector = input as! Vector + let stringOfElements = vector.map { pr_str($0, print_readably: print_readably) }.joined(separator: " ") + return "[" + stringOfElements + "]" + case .HashMap: + let hashMap = input as! [String: MalData] + let stringOfElements = hashMap.map { (key, value) in + pr_str(key, print_readably: print_readably) + " " + pr_str(value, print_readably: print_readably) + }.joined(separator: " ") + return "{" + stringOfElements + "}" + case .Atom: + return pr_str("(atom \((input as! Atom).value))", print_readably: false) + case .Function: + return "#" + default: + return "error type!" + } +} diff --git a/swift4/Sources/reader.swift b/swift4/Sources/reader.swift new file mode 100644 index 0000000000..08c0e2ba55 --- /dev/null +++ b/swift4/Sources/reader.swift @@ -0,0 +1,154 @@ +// +// reader.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +struct Reader { + let tokens: [String] + var position = 0 + + init(tokens: [String]) { + self.tokens = tokens + } + + mutating func next() -> String? { + guard tokens.indices.contains(position) else { + return nil + } + position += 1 + return tokens[position - 1] + } + + func peak() -> String? { + guard tokens.indices.contains(position) else { + return nil + } + return tokens[position] + } + + mutating func pass() { + guard tokens.indices.contains(position) else { + return + } + position += 1 + } + + mutating func read_form() throws -> MalData { + guard let token = peak() else { throw MalError.Error } + switch token { + case "(", "[", "{": + return try read_list(startWith: token) + case "'", "`", "~", "~@", "@": + let readerMacros = ["'": "quote", + "`": "quasiquote", + "~": "unquote", + "~@": "splice-unquote", + "@": "deref"] + pass() // pass the mark + return try [Symbol(readerMacros[token]!), read_form()] + case "^": + pass() // pass the mark + let meta = try read_form() + return try [Symbol("with-meta"), read_form(), meta] + default: + return try read_atom() + } + } + + + mutating func read_list(startWith leftParen: String) throws -> MalData { + pass() // pass the left paren + defer { + pass() // pass the right paren + } + + var list: [MalData] = [] + while ![")", "]", "}"].contains(peak()) { + guard peak() != nil else { + throw MalError.ParensMismatch + } + list.append(try read_form()) + } + + switch (leftParen, peak()) { + case ("(", ")"): + return list + case ("[", "]"): + return Vector(list) + case ("{", "}"): + var hashMap: [String: MalData] = [:] + for index in stride(from: 0, to: list.count, by: 2) { + guard list[index] is String, index+1 < list.count else { throw MalError.Error } + hashMap.updateValue(list[index+1], forKey: list[index] as! String) + } + return hashMap + default: + throw MalError.ParensMismatch + } + } + + mutating func read_atom() throws -> MalData { + let token = next()! + let regexInt = "^-?[0-9]+$" + let regexString = "\"(?:\\\\.|[^\\\\\"])*\"" + let regexStringUnbalanced = "\"(?:\\\\.|[^\\\\\"])*" + let regexKeyword = "^:" + func match(string: String, regex: String) -> Bool { + return token.range(of: regex, options: .regularExpression, range: token.startIndex.. [String] { + guard let regex = try? NSRegularExpression(pattern: "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)", options: .useUnixLineSeparators) + else { return [] } + let matches = regex.matches(in: input, range: NSMakeRange(0, input.count)) + + return matches.map { match in + String(input[Range(match.range(at: 1), in: input)!]) + }.filter { token in + !token.hasPrefix(";") && !token.isEmpty } +} + + +func read_str(_ input: String) throws -> MalData { + let tokens = tokenizer(input) + guard tokens.count>0 else { + throw MalError.EmptyData + } + var reader = Reader(tokens: tokens) + return try reader.read_form() +} + + + + + diff --git a/swift4/Sources/step0_repl/main.swift b/swift4/Sources/step0_repl/main.swift new file mode 100644 index 0000000000..5a99fa7ab1 --- /dev/null +++ b/swift4/Sources/step0_repl/main.swift @@ -0,0 +1,32 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input:String) -> String { + return input +} + +func EVAL(_ input:String) -> String { + return input +} + +func PRINT(_ input:String) -> String { + return input +} + +@discardableResult func rep(_ input:String) -> String { + return PRINT(EVAL(READ(input))) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + print(rep(input)) + } +} diff --git a/swift4/Sources/step1_read_print/main.swift b/swift4/Sources/step1_read_print/main.swift new file mode 100644 index 0000000000..df23a56181 --- /dev/null +++ b/swift4/Sources/step1_read_print/main.swift @@ -0,0 +1,38 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ input: MalData) throws -> MalData { + return input +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String) throws -> String { + return try PRINT(EVAL(READ(input))) +} + + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step2_eval/main.swift b/swift4/Sources/step2_eval/main.swift new file mode 100644 index 0000000000..de223033e9 --- /dev/null +++ b/swift4/Sources/step2_eval/main.swift @@ -0,0 +1,85 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ ast: MalData, env: [String: MalData]) throws -> MalData { + switch ast.dataType { + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .List: + let list = ast as! [MalData] + if list.isEmpty { return list } + let evaluated = try eval_ast(list, env: env) as! [MalData] + if let function = evaluated[0] as? Function { + return try function.fn(List(evaluated.dropFirst())) + } else { + throw MalError.SymbolNotFound(list[0] as! Symbol) + } + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String) throws -> String{ + func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { + guard args.count == 2, args[0] is Number, args[1] is Number else { throw MalError.InvalidArgument } + return op(args[0] as! Number, args[1] as! Number) + } + + let repl_env = ["+": Function(fn: { args in try calculate(args, op: +) }), + "-": Function(fn: { args in try calculate(args, op: -) }), + "*": Function(fn: { args in try calculate(args, op: *) }), + "/": Function(fn: { args in try calculate(args, op: /) })] + + return try PRINT(EVAL(READ(input), env: repl_env)) +} + +func eval_ast(_ ast: MalData, env: [String: MalData]) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = env[sym.name] { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + + + + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step3_env/main.swift b/swift4/Sources/step3_env/main.swift new file mode 100644 index 0000000000..3ed964e059 --- /dev/null +++ b/swift4/Sources/step3_env/main.swift @@ -0,0 +1,101 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + guard let sym = list[0] as? Symbol else { throw MalError.Error } + + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = (list[1] is Vector) ? List(list[1] as! Vector) : list[1] as! List + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + return try EVAL(expr, env: newEnv) + default: + let evaluated = try eval_ast(list, env: env) as! [MalData] + if let function = evaluated[0] as? Function { + return try function.fn(List(evaluated.dropFirst())) + } else { + throw MalError.SymbolNotFound(list[0] as! Symbol) + } + } + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + +func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { + guard args.count == 2, args[0] is Number, args[1] is Number else { throw MalError.InvalidArgument } + return op(args[0] as! Number, args[1] as! Number) +} +let repl_env = Env() +repl_env.set(Function(fn: { args in try calculate(args, op: +) }), forKey: Symbol("+")) +repl_env.set(Function(fn: { args in try calculate(args, op: -) }), forKey: Symbol("-")) +repl_env.set(Function(fn: { args in try calculate(args, op: *) }), forKey: Symbol("*")) +repl_env.set(Function(fn: { args in try calculate(args, op: /) }), forKey: Symbol("/")) + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step4_if_fn_do/main.swift b/swift4/Sources/step4_if_fn_do/main.swift new file mode 100644 index 0000000000..2ab88a2b61 --- /dev/null +++ b/swift4/Sources/step4_if_fn_do/main.swift @@ -0,0 +1,115 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = (list[1] is Vector) ? List(list[1] as! Vector) : list[1] as! List + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + return try EVAL(expr, env: newEnv) + case "do": + return try list.dropFirst().map { try EVAL($0, env: env) }.last ?? Nil() + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + return list.count>3 ? try EVAL(list[3], env: env) : Nil() + } else { + return try EVAL(list[2], env: env) + } + case "fn*": + let ops = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(fn: ops) + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + if let function = evaluated[0] as? Function { + return try function.fn(List(evaluated.dropFirst())) + } else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +try _ = rep("(def! not (fn* (a) (if a false true)))", env: repl_env) + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step5_tco/main.swift b/swift4/Sources/step5_tco/main.swift new file mode 100644 index 0000000000..b59ba68117 --- /dev/null +++ b/swift4/Sources/step5_tco/main.swift @@ -0,0 +1,145 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue +/* fn 的尾递归优化 +fn 的语法形å¼ï¼š （（fn （a，b）（+ a b ）） 1 2） å½¢å‚ï¼Œå‡½æ•°ä½“ï¼Œå®žå‚ +fn 本æ¥çš„实现。 + 1.生æˆï¼šåˆ¶é€ ä¸€ä¸ªé—­åŒ… + 1.1 闭包的功能：读入实å‚， 建立 å½¢å‚=å®žå‚ çš„çŽ¯å¢ƒï¼Œåœ¨è¿™ä¸ªçŽ¯å¢ƒä¸­ 求值函数体 + 1.2 闭包本身ä¸å¸¦æœ‰çŽ¯å¢ƒï¼Œå½“求值闭包时使用当时的环境 + 2.使用： + 以使用时的环境，使用实å‚调用闭包，闭包的返回值作为返回值。over （一次函数调用） +fn çš„ TCO 实现。 + 1.生æˆ: å½¢å‚ å‡½æ•°ä½“ 闭包（闭包包å«æœ€åˆçš„å½¢å‚和函数体）+ 生æˆfn时的环境 + 2.使用： + å–出 函数体， + 使用求值时的形å‚，以 fn 中的 env 为外层 env 建立环境 （） + 通过循环，在新建的环境中求值函数体 + */ + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +try _ = rep("(def! not (fn* (a) (if a false true)))", env: repl_env) + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step6_file/main.swift b/swift4/Sources/step6_file/main.swift new file mode 100644 index 0000000000..088cd4aa7c --- /dev/null +++ b/swift4/Sources/step6_file/main.swift @@ -0,0 +1,143 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step7_quote/main.swift b/swift4/Sources/step7_quote/main.swift new file mode 100644 index 0000000000..da1fbdeda1 --- /dev/null +++ b/swift4/Sources/step7_quote/main.swift @@ -0,0 +1,165 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func is_pair(_ ast: MalData) -> Bool { // not used + return (ast is [MalData]) && (ast.count != 0) + } + func quasiquote(_ ast: MalData) -> MalData { + let list = ast.listForm + if list.isEmpty { + return [Symbol("quote"), ast] + } + if let sym = list[0] as? Symbol, sym.name == "unquote" { + return list[1] + } + let innerList = list[0].listForm + if !innerList.isEmpty, let sym = innerList[0] as? Symbol, sym.name == "splice-unquote" { + return [Symbol("concat"), innerList[1], quasiquote(list.dropFirst().listForm)] + } + return [Symbol("cons"), quasiquote(list[0]), quasiquote(list.dropFirst().listForm)] + } + + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquote": + ast = quasiquote(list[1]) + continue + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step8_macros/main.swift b/swift4/Sources/step8_macros/main.swift new file mode 100644 index 0000000000..f362d71fe7 --- /dev/null +++ b/swift4/Sources/step8_macros/main.swift @@ -0,0 +1,196 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func is_pair(_ ast: MalData) -> Bool { // not used + return (ast is [MalData]) && (ast.count != 0) + } + func quasiquote(_ ast: MalData) -> MalData { + let list = ast.listForm + if list.isEmpty { + return [Symbol("quote"), ast] + } + if let sym = list[0] as? Symbol, sym.name == "unquote" { + return list[1] + } + let innerList = list[0].listForm + if !innerList.isEmpty, let sym = innerList[0] as? Symbol, sym.name == "splice-unquote" { + return [Symbol("concat"), innerList[1], quasiquote(list.dropFirst().listForm)] + } + return [Symbol("cons"), quasiquote(list[0]), quasiquote(list.dropFirst().listForm)] + } + func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { + func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used + if let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function { + return fn?.isMacro ?? false + } + return false + } + + var ast = anAst + while let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function, + let isMacro = fn?.isMacro, isMacro == true { + ast = try fn!.fn(List(list.dropFirst())) + } + return ast + } + + /// Apply + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + ast = try macroexpand(ast, env: env) + guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "defmacro!": + let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol + let macro = Function(withFunction: fn, isMacro: true) + env.set(macro, forKey: key) + return macro + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquote": + ast = quasiquote(list[1]) + continue + case "macroexpand": + return try macroexpand(list[1], env: env) + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) +try rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", env: repl_env) +try rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } +} diff --git a/swift4/Sources/step9_try/main.swift b/swift4/Sources/step9_try/main.swift new file mode 100644 index 0000000000..0c56215fa7 --- /dev/null +++ b/swift4/Sources/step9_try/main.swift @@ -0,0 +1,215 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func is_pair(_ ast: MalData) -> Bool { // not used + return (ast is [MalData]) && (ast.count != 0) + } + func quasiquote(_ ast: MalData) -> MalData { + let list = ast.listForm + if list.isEmpty { + return [Symbol("quote"), ast] + } + if let sym = list[0] as? Symbol, sym.name == "unquote" { + return list[1] + } + let innerList = list[0].listForm + if !innerList.isEmpty, let sym = innerList[0] as? Symbol, sym.name == "splice-unquote" { + return [Symbol("concat"), innerList[1], quasiquote(list.dropFirst().listForm)] + } + return [Symbol("cons"), quasiquote(list[0]), quasiquote(list.dropFirst().listForm)] + } + func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { + func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used + if let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function { + return fn?.isMacro ?? false + } + return false + } + + var ast = anAst + while let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function, + let isMacro = fn?.isMacro, isMacro == true { + ast = try fn!.fn(List(list.dropFirst())) + } + return ast + } + + /// Apply + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + ast = try macroexpand(ast, env: env) + guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "defmacro!": + let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol + let macro = Function(withFunction: fn, isMacro: true) + env.set(macro, forKey: key) + return macro + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquote": + ast = quasiquote(list[1]) + continue + case "macroexpand": + return try macroexpand(list[1], env: env) +// (try* A (catch* B C)) + case "try*": + do { + return try EVAL(list[1], env: env) + } catch let error as MalError { + if list.count > 2 { + let catchList = list[2] as! [MalData] + let catchEnv = Env(binds: [catchList[1] as! Symbol], exprs:[error.info()] , outer: env) + return try EVAL(catchList[2], env: catchEnv) + } else { + throw error + } + } + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) +try rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", env: repl_env) +try rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch MalError.MalException(let data) { + if let description = data as? String { + print("Exception." + description) + } else if let dic = data as? [String: String], !dic.isEmpty { + print("Exception." + dic.keys.first! + "." + dic.values.first!) + } + } catch let error as MalError { + print((pr_str(error.info(), print_readably: false))) + } + } +} diff --git a/swift4/Sources/stepA_mal/main.swift b/swift4/Sources/stepA_mal/main.swift new file mode 100644 index 0000000000..f0f8e28004 --- /dev/null +++ b/swift4/Sources/stepA_mal/main.swift @@ -0,0 +1,221 @@ +// +// main.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func is_pair(_ ast: MalData) -> Bool { // not used + return (ast is [MalData]) && (ast.count != 0) + } + func quasiquote(_ ast: MalData) -> MalData { + let list = ast.listForm + if list.isEmpty { + return [Symbol("quote"), ast] + } + if let sym = list[0] as? Symbol, sym.name == "unquote" { + return list[1] + } + let innerList = list[0].listForm + if !innerList.isEmpty, let sym = innerList[0] as? Symbol, sym.name == "splice-unquote" { + return [Symbol("concat"), innerList[1], quasiquote(list.dropFirst().listForm)] + } + return [Symbol("cons"), quasiquote(list[0]), quasiquote(list.dropFirst().listForm)] + } + func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { + func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used + if let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function { + return fn?.isMacro ?? false + } + return false + } + + var ast = anAst + while let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function, + let isMacro = fn?.isMacro, isMacro == true { + ast = try fn!.fn(List(list.dropFirst())) + } + return ast + } + + /// Apply + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + ast = try macroexpand(ast, env: env) + guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "defmacro!": + let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol + let macro = Function(withFunction: fn, isMacro: true) + env.set(macro, forKey: key) + return macro + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquote": + ast = quasiquote(list[1]) + continue + case "macroexpand": + return try macroexpand(list[1], env: env) + // (try* A (catch* B C)) + case "try*": + do { + return try EVAL(list[1], env: env) + } catch let error as MalError { + if list.count > 2 { + let catchList = list[2] as! [MalData] + let catchEnv = Env(binds: [catchList[1] as! Symbol], exprs:[error.info()] , outer: env) + return try EVAL(catchList[2], env: catchEnv) + } else { + throw error + } + } + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) +repl_env.set("Swift4", forKey: Symbol("*host-language*")) + + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env: repl_env) +try rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", env: repl_env) +try rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", env: repl_env) +try rep("(def! *gensym-counter* (atom 0))", env: repl_env) +try rep("(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))", env: repl_env) +try rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +try rep("(println (str \"Mal [\" *host-language* \"]\"))", env: repl_env) +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch MalError.MalException(let data) { + if let description = data as? String { + print("Exception." + description) + } else if let dic = data as? [String: String], !dic.isEmpty { + print("Exception." + dic.keys.first! + "." + dic.values.first!) + } + } catch let error as MalError { + print((pr_str(error.info(), print_readably: false))) + } + } +} diff --git a/swift4/Sources/types.swift b/swift4/Sources/types.swift new file mode 100644 index 0000000000..13369a483c --- /dev/null +++ b/swift4/Sources/types.swift @@ -0,0 +1,166 @@ +// +// types.swift +// swift4 +// +// Created by LuLouie on 2019/1/6. +// Copyright © 2019 llvm.xyz. All rights reserved. +// + +import Foundation + +enum MalDataType: String { + case Number, String, List, Vector, HashMap, Symbol, Keyword, Atom, Nil, True, False, Function, Unknown +} + +protocol MalData { + var dataType: MalDataType { get } + + var count: Int { get } + var listForm: [MalData] { get } +} +extension MalData { + var dataType: MalDataType { // not used + return MalDataType(rawValue: String(describing: type(of: self))) ?? MalDataType.Unknown + } + var count: Int { return 0 } + var listForm: [MalData] { return [] } +} + +typealias Number = Int +typealias List = Array +typealias Vector = ContiguousArray +typealias HashMap = Dictionary +//typealias MalClosureThrows = ([MalData]) throws -> MalData +//typealias MalClosure = ([MalData]) -> MalData + +struct Symbol: MalData { + let dataType = MalDataType.Symbol + let name: String + init(_ name: String) { + self.name = name + } +} + +struct Nil: MalData { + let dataType = MalDataType.Nil +} + +class Atom: MalData { + let dataType = MalDataType.Atom + var value: MalData + init(_ value: MalData) { + self.value = value + } +} + +struct Function: MalData { + let dataType = MalDataType.Function + + let ast: MalData? + let params: [Symbol]? + let env: Env? + let fn: (([MalData]) throws -> MalData) + let isMacro: Bool + let meta: MalData? + + init(ast: MalData? = nil, params: [Symbol]? = nil, env: Env? = nil, isMacro: Bool = false, meta: MalData? = nil, + fn: @escaping ([MalData]) throws -> MalData) { + self.ast = ast + self.params = params + self.env = env + self.isMacro = isMacro + self.fn = fn + self.meta = meta + } + init(withFunction function: Function, isMacro: Bool) { + self.ast = function.ast + self.params = function.params + self.env = function.env + self.fn = function.fn + self.meta = function.meta + self.isMacro = isMacro + } + init(withFunction function: Function, meta: MalData) { + self.ast = function.ast + self.params = function.params + self.env = function.env + self.fn = function.fn + self.isMacro = function.isMacro + self.meta = meta + } + +} + +//struct WithMeta: MalData { +// let dataType = MalDataType.WithMeta +// let data: MalData +// let meta: MalData +//} + + +extension String: MalData { + var dataType: MalDataType { + return !self.isEmpty && self[startIndex] == "\u{029E}" ? .Keyword : .String } +} +extension Number: MalData { + var dataType: MalDataType { return .Number } +} +extension Bool : MalData { + var dataType: MalDataType { return self == true ? .True : .False } +} + +extension List : MalData { + var dataType: MalDataType { return .List } + var listForm: [MalData] { return self as! [MalData] } +} +extension Vector: MalData { + var dataType: MalDataType { return .Vector } + var listForm: [MalData] { return List(self) as! [MalData] } +} +extension ArraySlice: MalData { + var dataType: MalDataType { return .List } + var listForm: [MalData] { return List(self) as! [MalData] } +} +extension HashMap: MalData { + var dataType: MalDataType { return .HashMap } + static func hashMap(fromList list: [MalData]) throws -> [String: MalData] { + var hashMap: [String: MalData] = [:] + for index in stride(from: 0, to: list.count, by: 2) { + guard list[index] is String, index+1 < list.count else { throw MalError.Error } + hashMap.updateValue(list[index+1], forKey: list[index] as! String) + } + return hashMap + } +} + +// MARK: Errors +enum MalError: Error { + case ParensMismatch + case QuotationMarkMismatch + case EmptyData + case SymbolNotFound(Symbol) + case InvalidArgument + case Error + case IndexOutOfBounds + case MalException(MalData) + func info() -> MalData { + switch self { + case .ParensMismatch: + return "unbalanced parens" + case .QuotationMarkMismatch: + return "unbalanced quotation mark" + case .EmptyData: + return "empty data" + case .InvalidArgument: + return "invalid argument" + case .SymbolNotFound(let symbol): + return "'\(symbol.name)' not found" + case .IndexOutOfBounds: + return "index out of bounds" + case .MalException(let data): + return data + default: + return "uncaught error!" + } + } +} diff --git a/swift4/run b/swift4/run new file mode 100755 index 0000000000..8ba68a5484 --- /dev/null +++ b/swift4/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" From 573f6d0f7e7b2f7cf47b2a69ab3c60eec13415dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E9=99=86=E9=81=A5?= Date: Tue, 5 Mar 2019 18:27:26 +0800 Subject: [PATCH 0480/1998] Update Makefile --- Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 0cda4bf399..9843ed9c3f 100644 --- a/Makefile +++ b/Makefile @@ -86,7 +86,7 @@ IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d d guile haskell haxe hy io java js julia kotlin livescript logo lua make mal \ matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp plpgsql \ plsql powershell ps python r racket rexx rpython ruby rust scala scheme skew \ - swift swift3 tcl ts vb vhdl vimscript wasm yorick + swift swift3 swift4 tcl ts vb vhdl vimscript wasm yorick EXTENSION = .mal @@ -239,6 +239,7 @@ scheme_STEP_TO_PROG = $(scheme_STEP_TO_PROG_$(scheme_MODE)) skew_STEP_TO_PROG = skew/$($(1)).js swift_STEP_TO_PROG = swift/$($(1)) swift3_STEP_TO_PROG = swift3/$($(1)) +swift4_STEP_TO_PROG = swift4/$($(1)) tcl_STEP_TO_PROG = tcl/$($(1)).tcl ts_STEP_TO_PROG = ts/$($(1)).js vb_STEP_TO_PROG = vb/$($(1)).exe From 34264332a9615b5158f35cddef2cd2a1f8b2f86c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E9=99=86=E9=81=A5?= Date: Wed, 6 Mar 2019 09:02:48 +0800 Subject: [PATCH 0481/1998] remove auto-generated copyright declarations. --- swift4/Sources/core.swift | 7 ------- swift4/Sources/env.swift | 7 ------- swift4/Sources/printer.swift | 7 ------- swift4/Sources/reader.swift | 7 ------- swift4/Sources/step0_repl/main.swift | 7 ------- swift4/Sources/step1_read_print/main.swift | 7 ------- swift4/Sources/step2_eval/main.swift | 7 ------- swift4/Sources/step3_env/main.swift | 7 ------- swift4/Sources/step4_if_fn_do/main.swift | 7 ------- swift4/Sources/step5_tco/main.swift | 7 ------- swift4/Sources/step6_file/main.swift | 7 ------- swift4/Sources/step7_quote/main.swift | 7 ------- swift4/Sources/step8_macros/main.swift | 7 ------- swift4/Sources/step9_try/main.swift | 7 ------- swift4/Sources/stepA_mal/main.swift | 7 ------- swift4/Sources/types.swift | 7 ------- 16 files changed, 112 deletions(-) diff --git a/swift4/Sources/core.swift b/swift4/Sources/core.swift index cc9b2a9c4d..38212988ad 100644 --- a/swift4/Sources/core.swift +++ b/swift4/Sources/core.swift @@ -1,10 +1,3 @@ -// -// core.swift -// swift4 -// -// Created by LuLouie on 2019/1/10. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/env.swift b/swift4/Sources/env.swift index 6b43500508..50b8ca1cd3 100644 --- a/swift4/Sources/env.swift +++ b/swift4/Sources/env.swift @@ -1,10 +1,3 @@ -// -// env.swift -// swift4 -// -// Created by LuLouie on 2019/1/7. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/printer.swift b/swift4/Sources/printer.swift index c55d4f7c68..0ccfc1f93b 100644 --- a/swift4/Sources/printer.swift +++ b/swift4/Sources/printer.swift @@ -1,10 +1,3 @@ -// -// printer.swift -// swift4 -// -// Created by LuLouie on 2019/1/7. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/reader.swift b/swift4/Sources/reader.swift index 08c0e2ba55..44d3041b38 100644 --- a/swift4/Sources/reader.swift +++ b/swift4/Sources/reader.swift @@ -1,10 +1,3 @@ -// -// reader.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step0_repl/main.swift b/swift4/Sources/step0_repl/main.swift index 5a99fa7ab1..ef79a769df 100644 --- a/swift4/Sources/step0_repl/main.swift +++ b/swift4/Sources/step0_repl/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step1_read_print/main.swift b/swift4/Sources/step1_read_print/main.swift index df23a56181..120a820b23 100644 --- a/swift4/Sources/step1_read_print/main.swift +++ b/swift4/Sources/step1_read_print/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step2_eval/main.swift b/swift4/Sources/step2_eval/main.swift index de223033e9..be9680abdd 100644 --- a/swift4/Sources/step2_eval/main.swift +++ b/swift4/Sources/step2_eval/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step3_env/main.swift b/swift4/Sources/step3_env/main.swift index 3ed964e059..582ce41e9f 100644 --- a/swift4/Sources/step3_env/main.swift +++ b/swift4/Sources/step3_env/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step4_if_fn_do/main.swift b/swift4/Sources/step4_if_fn_do/main.swift index 2ab88a2b61..e0a2b2633e 100644 --- a/swift4/Sources/step4_if_fn_do/main.swift +++ b/swift4/Sources/step4_if_fn_do/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step5_tco/main.swift b/swift4/Sources/step5_tco/main.swift index b59ba68117..cb9e99a95c 100644 --- a/swift4/Sources/step5_tco/main.swift +++ b/swift4/Sources/step5_tco/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step6_file/main.swift b/swift4/Sources/step6_file/main.swift index 088cd4aa7c..4d068c0c38 100644 --- a/swift4/Sources/step6_file/main.swift +++ b/swift4/Sources/step6_file/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step7_quote/main.swift b/swift4/Sources/step7_quote/main.swift index da1fbdeda1..e4370353be 100644 --- a/swift4/Sources/step7_quote/main.swift +++ b/swift4/Sources/step7_quote/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step8_macros/main.swift b/swift4/Sources/step8_macros/main.swift index f362d71fe7..b707784d9e 100644 --- a/swift4/Sources/step8_macros/main.swift +++ b/swift4/Sources/step8_macros/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/step9_try/main.swift b/swift4/Sources/step9_try/main.swift index 0c56215fa7..8e0e4beac6 100644 --- a/swift4/Sources/step9_try/main.swift +++ b/swift4/Sources/step9_try/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/stepA_mal/main.swift b/swift4/Sources/stepA_mal/main.swift index f0f8e28004..60524dac50 100644 --- a/swift4/Sources/stepA_mal/main.swift +++ b/swift4/Sources/stepA_mal/main.swift @@ -1,10 +1,3 @@ -// -// main.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation diff --git a/swift4/Sources/types.swift b/swift4/Sources/types.swift index 13369a483c..1706f475f2 100644 --- a/swift4/Sources/types.swift +++ b/swift4/Sources/types.swift @@ -1,10 +1,3 @@ -// -// types.swift -// swift4 -// -// Created by LuLouie on 2019/1/6. -// Copyright © 2019 llvm.xyz. All rights reserved. -// import Foundation From 2c1c26608512ea1ba058338b9eccc9448bcdffff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E9=99=86=E9=81=A5?= Date: Wed, 6 Mar 2019 09:35:31 +0800 Subject: [PATCH 0482/1998] Update readme and .travis.yml to add swift 4. --- .travis.yml | 2 ++ README.md | 14 +++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 782480ee07..77a921a4da 100644 --- a/.travis.yml +++ b/.travis.yml @@ -86,6 +86,8 @@ matrix: - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7.3} - {env: IMPL=swift3, services: [docker]} - {env: IMPL=swift3 NO_DOCKER=1, os: osx, osx_image: xcode8} + - {env: IMPL=swift4, services: [docker]} + - {env: IMPL=swift4 NO_DOCKER=1, os: osx, osx_image: xcode10} - {env: IMPL=tcl, services: [docker]} - {env: IMPL=ts, services: [docker]} - {env: IMPL=vb, services: [docker]} diff --git a/README.md b/README.md index 0759b25c9f..9fc40d3c33 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ **1. Mal is a Clojure inspired Lisp interpreter** -**2. Mal is implemented in 74 languages** +**2. Mal is implemented in 75 languages** | Language | Creator | | -------- | ------- | @@ -77,6 +77,7 @@ | [Skew](#skew) | [Dov Murik](https://github.com/dubek) | | [Swift](#swift) | [Keith Rollin](https://github.com/keith-rollin) | | [Swift 3](#swift-3) | [Joel Martin](https://github.com/kanaka) | +| [Swift 4](#swift-4) | [陆é¥](https://github.com/LispLY) | | [Tcl](#tcl-86) | [Dov Murik](https://github.com/dubek) | | [TypeScript](#typescript) | [Masahiro Wakame](https://github.com/vvakame) | | [VHDL](#vhdl) | [Dov Murik](https://github.com/dubek) | @@ -930,6 +931,17 @@ make ./stepX_YYY ``` +### Swift 4 + +The Swift 4 implementation of mal requires the Swift 4.0 compiler. It +has been tested with Swift 4.2.3 release. + +``` +cd swift4 +make +./stepX_YYY +``` + ### Tcl 8.6 The Tcl implementation of mal requires Tcl 8.6 to run. For readline line From 56847c519cb43b72392bb241845e5ec37db5343d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E9=99=86=E9=81=A5?= Date: Wed, 6 Mar 2019 09:57:19 +0800 Subject: [PATCH 0483/1998] clean-up --- swift4/Sources/step5_tco/main.swift | 2 +- swift4/Sources/step6_file/main.swift | 2 +- swift4/Sources/step7_quote/main.swift | 2 +- swift4/Sources/step8_macros/main.swift | 2 +- swift4/Sources/step9_try/main.swift | 2 +- swift4/Sources/stepA_mal/main.swift | 3 +-- swift4/Sources/types.swift | 8 -------- 7 files changed, 6 insertions(+), 15 deletions(-) diff --git a/swift4/Sources/step5_tco/main.swift b/swift4/Sources/step5_tco/main.swift index cb9e99a95c..710e2e1a62 100644 --- a/swift4/Sources/step5_tco/main.swift +++ b/swift4/Sources/step5_tco/main.swift @@ -47,7 +47,7 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { return try EVAL(list[2], env: newEnv) } return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + default: break } diff --git a/swift4/Sources/step6_file/main.swift b/swift4/Sources/step6_file/main.swift index 4d068c0c38..8ac611b84e 100644 --- a/swift4/Sources/step6_file/main.swift +++ b/swift4/Sources/step6_file/main.swift @@ -47,7 +47,7 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { return try EVAL(list[2], env: newEnv) } return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + default: break } diff --git a/swift4/Sources/step7_quote/main.swift b/swift4/Sources/step7_quote/main.swift index e4370353be..ee8ad12cc3 100644 --- a/swift4/Sources/step7_quote/main.swift +++ b/swift4/Sources/step7_quote/main.swift @@ -59,7 +59,7 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { ast = list[2] } continue - case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + case "fn*": let fn = {(params: [MalData]) -> MalData in let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) return try EVAL(list[2], env: newEnv) diff --git a/swift4/Sources/step8_macros/main.swift b/swift4/Sources/step8_macros/main.swift index b707784d9e..931d6d92c2 100644 --- a/swift4/Sources/step8_macros/main.swift +++ b/swift4/Sources/step8_macros/main.swift @@ -85,7 +85,7 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { ast = list[2] } continue - case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + case "fn*": let fn = {(params: [MalData]) -> MalData in let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) return try EVAL(list[2], env: newEnv) diff --git a/swift4/Sources/step9_try/main.swift b/swift4/Sources/step9_try/main.swift index 8e0e4beac6..5c98419b71 100644 --- a/swift4/Sources/step9_try/main.swift +++ b/swift4/Sources/step9_try/main.swift @@ -85,7 +85,7 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { ast = list[2] } continue - case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + case "fn*": let fn = {(params: [MalData]) -> MalData in let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) return try EVAL(list[2], env: newEnv) diff --git a/swift4/Sources/stepA_mal/main.swift b/swift4/Sources/stepA_mal/main.swift index 60524dac50..157750144f 100644 --- a/swift4/Sources/stepA_mal/main.swift +++ b/swift4/Sources/stepA_mal/main.swift @@ -85,7 +85,7 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { ast = list[2] } continue - case "fn*": // fn 是å¦éœ€è¦å­˜å‚¨ï¼Ÿ + case "fn*": let fn = {(params: [MalData]) -> MalData in let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) return try EVAL(list[2], env: newEnv) @@ -98,7 +98,6 @@ func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { continue case "macroexpand": return try macroexpand(list[1], env: env) - // (try* A (catch* B C)) case "try*": do { return try EVAL(list[1], env: env) diff --git a/swift4/Sources/types.swift b/swift4/Sources/types.swift index 1706f475f2..0686b8dae4 100644 --- a/swift4/Sources/types.swift +++ b/swift4/Sources/types.swift @@ -23,8 +23,6 @@ typealias Number = Int typealias List = Array typealias Vector = ContiguousArray typealias HashMap = Dictionary -//typealias MalClosureThrows = ([MalData]) throws -> MalData -//typealias MalClosure = ([MalData]) -> MalData struct Symbol: MalData { let dataType = MalDataType.Symbol @@ -84,12 +82,6 @@ struct Function: MalData { } -//struct WithMeta: MalData { -// let dataType = MalDataType.WithMeta -// let data: MalData -// let meta: MalData -//} - extension String: MalData { var dataType: MalDataType { From cbbb51b465c06e3529b8efaa86c197f91507e2f2 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Mon, 10 Oct 2016 19:08:59 +0200 Subject: [PATCH 0484/1998] Another Ada implementation. --- Makefile | 3 +- ada2/Makefile | 71 +++++ ada2/atoms.adb | 52 ++++ ada2/atoms.ads | 36 +++ ada2/core.adb | 581 ++++++++++++++++++++++++++++++++++++++ ada2/core.ads | 17 ++ ada2/environments.adb | 166 +++++++++++ ada2/environments.ads | 54 ++++ ada2/lists.adb | 95 +++++++ ada2/lists.ads | 47 +++ ada2/maps.adb | 160 +++++++++++ ada2/maps.ads | 59 ++++ ada2/names.ads | 87 ++++++ ada2/printer.adb | 177 ++++++++++++ ada2/printer.ads | 12 + ada2/reader.adb | 252 +++++++++++++++++ ada2/reader.ads | 12 + ada2/run | 2 + ada2/step0_repl.adb | 64 +++++ ada2/step1_read_print.adb | 75 +++++ ada2/step2_eval.adb | 175 ++++++++++++ ada2/step3_env.adb | 199 +++++++++++++ ada2/step4_if_fn_do.adb | 231 +++++++++++++++ ada2/step5_tco.adb | 234 +++++++++++++++ ada2/step6_file.adb | 260 +++++++++++++++++ ada2/step7_quote.adb | 326 +++++++++++++++++++++ ada2/step8_macros.adb | 383 +++++++++++++++++++++++++ ada2/step9_try.adb | 411 +++++++++++++++++++++++++++ ada2/stepa_mal.adb | 417 +++++++++++++++++++++++++++ ada2/strings.adb | 62 ++++ ada2/strings.ads | 65 +++++ ada2/types.adb | 37 +++ ada2/types.ads | 59 ++++ 33 files changed, 4880 insertions(+), 1 deletion(-) create mode 100644 ada2/Makefile create mode 100644 ada2/atoms.adb create mode 100644 ada2/atoms.ads create mode 100644 ada2/core.adb create mode 100644 ada2/core.ads create mode 100644 ada2/environments.adb create mode 100644 ada2/environments.ads create mode 100644 ada2/lists.adb create mode 100644 ada2/lists.ads create mode 100644 ada2/maps.adb create mode 100644 ada2/maps.ads create mode 100644 ada2/names.ads create mode 100644 ada2/printer.adb create mode 100644 ada2/printer.ads create mode 100644 ada2/reader.adb create mode 100644 ada2/reader.ads create mode 100755 ada2/run create mode 100644 ada2/step0_repl.adb create mode 100644 ada2/step1_read_print.adb create mode 100644 ada2/step2_eval.adb create mode 100644 ada2/step3_env.adb create mode 100644 ada2/step4_if_fn_do.adb create mode 100644 ada2/step5_tco.adb create mode 100644 ada2/step6_file.adb create mode 100644 ada2/step7_quote.adb create mode 100644 ada2/step8_macros.adb create mode 100644 ada2/step9_try.adb create mode 100644 ada2/stepa_mal.adb create mode 100644 ada2/strings.adb create mode 100644 ada2/strings.ads create mode 100644 ada2/types.adb create mode 100644 ada2/types.ads diff --git a/Makefile b/Makefile index 9843ed9c3f..d80bd7d2c6 100644 --- a/Makefile +++ b/Makefile @@ -81,7 +81,7 @@ DOCKERIZE = # Implementation specific settings # -IMPLS = ada awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ +IMPLS = ada ada2 awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ elisp elixir elm erlang es6 factor fantom forth fsharp go groovy gnu-smalltalk \ guile haskell haxe hy io java js julia kotlin livescript logo lua make mal \ matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp plpgsql \ @@ -173,6 +173,7 @@ scheme_STEP_TO_PROG_foment = scheme/$($(1)).scm # Map of step (e.g. "step8") to executable file for that step ada_STEP_TO_PROG = ada/$($(1)) +ada2_STEP_TO_PROG = ada2/$($(1)) awk_STEP_TO_PROG = awk/$($(1)).awk bash_STEP_TO_PROG = bash/$($(1)).sh basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) diff --git a/ada2/Makefile b/ada2/Makefile new file mode 100644 index 0000000000..bb58c83206 --- /dev/null +++ b/ada2/Makefile @@ -0,0 +1,71 @@ +# Variables expected on the command line: +OPT := -O2 +GNATN := -gnatn +GNATP := -gnatp +ADAFLAGS := +LDFLAGS := +DEBUG := + +ifdef DEBUG + # Some warnings require -O1. + OPT := -O1 + GNATN := + GNATP := + ADAFLAGS := -Wall -Wextra -gnatw.eH.Y -gnatySdouxy -gnatVa -g -gnataEfoqQ \ + -fstack-check -pg + LDFLAGS := -pg +endif + +# Compiler arguments. +CARGS = -gnat2012 $(OPT) $(GNATN) $(GNATP) $(ADAFLAGS) +# Linker arguments. +LARGS = $(LDFLAGS) -lreadline + +step0 := step0_repl +step13 := step1_read_print \ + step2_eval \ + step3_env +step49 := step4_if_fn_do \ + step5_tco \ + step6_file \ + step7_quote \ + step8_macros \ + step9_try +stepa := stepA_mal +steps := $(step0) $(step13) $(step49) $(stepa) + +.PHONY: all clean +all: $(steps) +clean: + $(RM) *~ *.ali *.o b~*.ad[bs] gmon.out $(steps) + +# Tell Make how to detect out-of-date executables, and let gnatmake do +# the rest when it must be executed. +TYPES := \ + atoms.ads atoms.adb \ + environments.ads environments.adb \ + lists.ads lists.adb \ + maps.ads maps.adb \ + names.ads \ + printer.ads printer.adb \ + reader.ads reader.adb \ + types.ads types.adb \ + strings.ads strings.adb +CORE := \ + core.ads core.adb + +$(step0) : %: %.adb +$(step13): %: %.adb $(TYPES) +$(step49): %: %.adb $(TYPES) $(CORE) +$(stepa) : stepA%: stepa%.adb $(TYPES) $(CORE) +$(steps) : + gnatmake $< -o $@ -cargs $(CARGS) -largs $(LARGS) + +# Step 8 freezes during the "(or)" test with -gnatp. +step8%: GNATP := + +# The compiler crashes on types.adb with -gnatn. +$(step13) $(step49) $(stepa): types.o +types.o: GNATN := +types.o: $(TYPES) + gcc -c $(CARGS) types.adb diff --git a/ada2/atoms.adb b/ada2/atoms.adb new file mode 100644 index 0000000000..24650a04d1 --- /dev/null +++ b/ada2/atoms.adb @@ -0,0 +1,52 @@ +with Ada.Unchecked_Deallocation; +with Types; + +package body Atoms is + + type Atom_Record is limited record + Data : Types.Mal_Type; + Refs : Positive; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Object => Atom_Record, + Name => Atom_Access); + + ---------------------------------------------------------------------- + + procedure Adjust (Object : in out Ptr) is + begin + if Object.Ref /= null then + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end if; + end Adjust; + + function Alloc (New_Value : in Types.Mal_Type) return Ptr + is (Ada.Finalization.Controlled with + Ref => new Atom_Record'(Data => New_Value, + Refs => 1)); + + function Deref (Container : in Ptr) return Types.Mal_Type is + (Container.Ref.all.Data); + + procedure Finalize (Object : in out Ptr) + is + Refs : Positive; + begin + if Object.Ref /= null then + Refs := Object.Ref.all.Refs; + if 1 < Refs then + Object.Ref.all.Refs := Refs - 1; + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + procedure Set (Container : in Ptr; + New_Value : in Types.Mal_Type) is + begin + Container.Ref.all.Data := New_Value; + end Set; + +end Atoms; diff --git a/ada2/atoms.ads b/ada2/atoms.ads new file mode 100644 index 0000000000..3fa5aae990 --- /dev/null +++ b/ada2/atoms.ads @@ -0,0 +1,36 @@ +private with Ada.Finalization; +limited with Types; + +package Atoms is + + -- Equivalent to a Lists.Ptr with zero or one elements. + + type Ptr is tagged private; + No_Element : constant Ptr; + + function Alloc (New_Value : in Types.Mal_Type) return Ptr + with Inline; + + function Deref (Container : in Ptr) return Types.Mal_Type + with Inline, Pre => Container /= No_Element; + + procedure Set (Container : in Ptr; + New_Value : in Types.Mal_Type) + with Inline, Pre => Container /= No_Element; + +private + + type Atom_Record; + type Atom_Access is access Atom_Record; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Atom_Access := null; + end record; + overriding procedure Adjust (Object : in out Ptr) + with Inline; + overriding procedure Finalize (Object : in out Ptr) + with Inline; + -- Predefined equality is fine. + + No_Element : constant Ptr := (Ada.Finalization.Controlled with Ref => null); + +end Atoms; diff --git a/ada2/core.adb b/ada2/core.adb new file mode 100644 index 0000000000..aa8be989a0 --- /dev/null +++ b/ada2/core.adb @@ -0,0 +1,581 @@ +with Ada.Calendar; use type Ada.Calendar.Time; +with Ada.Characters.Latin_1; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Atoms; use type Atoms.Ptr; +with Lists; +with Maps; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; + +package body Core is + + use Types; + + Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; + + Eval : Eval_Callback_Type; + + function Concatenation_Of_Pr_Str + (Args : in Mal_Type_Array; + Print_Readably : in Boolean := True; + Separator : in String := " ") + return Ada.Strings.Unbounded.Unbounded_String; + + function Apply (Args : in Mal_Type_Array) return Mal_Type; + function Assoc (Args : in Mal_Type_Array) return Mal_Type; + function Atom (Args : in Mal_Type_Array) return Mal_Type; + function Concat (Args : in Mal_Type_Array) return Mal_Type; + function Conj (Args : in Mal_Type_Array) return Mal_Type; + function Cons (Args : in Mal_Type_Array) return Mal_Type; + function Contains (Args : in Mal_Type_Array) return Mal_Type; + function Count (Args : in Mal_Type_Array) return Mal_Type; + function Deref (Args : in Mal_Type_Array) return Mal_Type; + function Dissoc (Args : in Mal_Type_Array) return Mal_Type; + function Equals (Args : in Mal_Type_Array) return Mal_Type; + function First (Args : in Mal_Type_Array) return Mal_Type; + function Get (Args : in Mal_Type_Array) return Mal_Type; + function Hash_Map (Args : in Mal_Type_Array) return Mal_Type; + function Is_Empty (Args : in Mal_Type_Array) return Mal_Type; + function Is_False (Args : in Mal_Type_Array) return Mal_Type; + function Is_Sequential (Args : in Mal_Type_Array) return Mal_Type; + function Is_True (Args : in Mal_Type_Array) return Mal_Type; + function Keys (Args : in Mal_Type_Array) return Mal_Type; + function Keyword (Args : in Mal_Type_Array) return Mal_Type; + function List (Args : in Mal_Type_Array) return Mal_Type; + function Map (Args : in Mal_Type_Array) return Mal_Type; + function Meta (Args : in Mal_Type_Array) return Mal_Type; + function Nth (Args : in Mal_Type_Array) return Mal_Type; + function Pr_Str (Args : in Mal_Type_Array) return Mal_Type; + function Println (Args : in Mal_Type_Array) return Mal_Type; + function Prn (Args : in Mal_Type_Array) return Mal_Type; + function Read_String (Args : in Mal_Type_Array) return Mal_Type; + function Readline (Args : in Mal_Type_Array) return Mal_Type; + function Reset (Args : in Mal_Type_Array) return Mal_Type; + function Rest (Args : in Mal_Type_Array) return Mal_Type; + function Seq (Args : in Mal_Type_Array) return Mal_Type; + function Slurp (Args : in Mal_Type_Array) return Mal_Type; + function Str (Args : in Mal_Type_Array) return Mal_Type; + function Swap (Args : in Mal_Type_Array) return Mal_Type; + function Symbol (Args : in Mal_Type_Array) return Mal_Type; + function Throw (Args : in Mal_Type_Array) return Mal_Type; + function Time_Ms (Args : in Mal_Type_Array) return Mal_Type; + function Vals (Args : in Mal_Type_Array) return Mal_Type; + function Vector (Args : in Mal_Type_Array) return Mal_Type; + function With_Meta (Args : in Mal_Type_Array) return Mal_Type; + + generic + with function Ada_Operator (Left, Right : in Integer) return Integer; + function Generic_Mal_Operator (Args : in Mal_Type_Array) return Mal_Type; + function Generic_Mal_Operator (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Number, Atoms.No_Element, + Ada_Operator (Args (Args'First).Integer_Value, + Args (Args'First + 1).Integer_Value)); + function Addition is new Generic_Mal_Operator ("+"); + function Subtraction is new Generic_Mal_Operator ("-"); + function Product is new Generic_Mal_Operator ("*"); + function Division is new Generic_Mal_Operator ("/"); + + generic + with function Ada_Operator (Left, Right : in Integer) return Boolean; + function Generic_Comparison (Args : in Mal_Type_Array) return Mal_Type; + function Generic_Comparison (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, + Ada_Operator (Args (Args'First).Integer_Value, + Args (Args'First + 1).Integer_Value)); + function Greater_Than is new Generic_Comparison (">"); + function Greater_Equal is new Generic_Comparison (">="); + function Less_Than is new Generic_Comparison ("<"); + function Less_Equal is new Generic_Comparison ("<="); + + generic + Kind : Kind_Type; + function Generic_Kind_Test (Args : in Mal_Type_Array) return Mal_Type; + function Generic_Kind_Test (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, Args (Args'First).Kind = Kind); + function Is_Atom is new Generic_Kind_Test (Kind_Atom); + function Is_Keyword is new Generic_Kind_Test (Kind_Keyword); + function Is_List is new Generic_Kind_Test (Kind_List); + function Is_Map is new Generic_Kind_Test (Kind_Map); + function Is_Nil is new Generic_Kind_Test (Kind_Nil); + function Is_String is new Generic_Kind_Test (Kind_String); + function Is_Symbol is new Generic_Kind_Test (Kind_Symbol); + function Is_Vector is new Generic_Kind_Test (Kind_Vector); + + ---------------------------------------------------------------------- + + procedure Add_Built_In_Functions + (Repl : in Environments.Ptr; + Eval_Callback : in not null Eval_Callback_Type) + is + function N (N : in Native_Function_Access) return Mal_Type + is (Kind_Native, Atoms.No_Element, N) with Inline; + begin + Eval := Eval_Callback; + + Repl.Increase_Capacity (57); + + Repl.Set (Names.Apply, N (Apply'Access)); + Repl.Set (Names.Assoc, N (Assoc'Access)); + Repl.Set (Names.Asterisk, N (Product'Access)); + Repl.Set (Names.Atom, N (Atom'Access)); + Repl.Set (Names.Concat, N (Concat'Access)); + Repl.Set (Names.Conj, N (Conj'Access)); + Repl.Set (Names.Cons, N (Cons'Access)); + Repl.Set (Names.Contains, N (Contains'Access)); + Repl.Set (Names.Count, N (Count'Access)); + Repl.Set (Names.Deref, N (Deref'Access)); + Repl.Set (Names.Dissoc, N (Dissoc'Access)); + Repl.Set (Names.Equals, N (Equals'Access)); + Repl.Set (Names.First, N (First'Access)); + Repl.Set (Names.Get, N (Get'Access)); + Repl.Set (Names.Greater_Equal, N (Greater_Equal'Access)); + Repl.Set (Names.Greater_Than, N (Greater_Than'Access)); + Repl.Set (Names.Hash_Map, N (Hash_Map'Access)); + Repl.Set (Names.Is_Atom, N (Is_Atom'Access)); + Repl.Set (Names.Is_Empty, N (Is_Empty'Access)); + Repl.Set (Names.Is_False, N (Is_False'Access)); + Repl.Set (Names.Is_Keyword, N (Is_Keyword'Access)); + Repl.Set (Names.Is_List, N (Is_List'Access)); + Repl.Set (Names.Is_Map, N (Is_Map'Access)); + Repl.Set (Names.Is_Nil, N (Is_Nil'Access)); + Repl.Set (Names.Is_Sequential, N (Is_Sequential'Access)); + Repl.Set (Names.Is_String, N (Is_String'Access)); + Repl.Set (Names.Is_Symbol, N (Is_Symbol'Access)); + Repl.Set (Names.Is_True, N (Is_True'Access)); + Repl.Set (Names.Is_Vector, N (Is_Vector'Access)); + Repl.Set (Names.Keys, N (Keys'Access)); + Repl.Set (Names.Keyword, N (Keyword'Access)); + Repl.Set (Names.Less_Equal, N (Less_Equal'Access)); + Repl.Set (Names.Less_Than, N (Less_Than'Access)); + Repl.Set (Names.List, N (List'Access)); + Repl.Set (Names.Map, N (Map'Access)); + Repl.Set (Names.Meta, N (Meta'Access)); + Repl.Set (Names.Minus, N (Subtraction'Access)); + Repl.Set (Names.Nth, N (Nth'Access)); + Repl.Set (Names.Plus, N (Addition'Access)); + Repl.Set (Names.Pr_Str, N (Pr_Str'Access)); + Repl.Set (Names.Println, N (Println'Access)); + Repl.Set (Names.Prn, N (Prn'Access)); + Repl.Set (Names.Read_String, N (Read_String'Access)); + Repl.Set (Names.Readline, N (Readline'Access)); + Repl.Set (Names.Reset, N (Reset'Access)); + Repl.Set (Names.Rest, N (Rest'Access)); + Repl.Set (Names.Seq, N (Seq'Access)); + Repl.Set (Names.Slash, N (Division'Access)); + Repl.Set (Names.Slurp, N (Slurp'Access)); + Repl.Set (Names.Str, N (Str'Access)); + Repl.Set (Names.Swap, N (Swap'Access)); + Repl.Set (Names.Symbol, N (Symbol'Access)); + Repl.Set (Names.Throw, N (Throw'Access)); + Repl.Set (Names.Time_Ms, N (Time_Ms'Access)); + Repl.Set (Names.Vals, N (Vals'Access)); + Repl.Set (Names.Vector, N (Vector'Access)); + Repl.Set (Names.With_Meta, N (With_Meta'Access)); + end Add_Built_In_Functions; + + function Apply (Args : in Mal_Type_Array) return Mal_Type + is + Func : Mal_Type renames Args (Args'First); + List : Lists.Ptr renames Args (Args'Last).L; + Actuals : Mal_Type_Array (1 .. Args'Length - 2 + List.Length); + begin + Actuals (1 .. Args'Length - 2) := Args (Args'First + 1 .. Args'Last - 1); + for I in 1 .. List.Length loop + Actuals (Args'Length - 2 + I) := List.Element (I); + end loop; + if Func.Kind = Kind_Native then + return Func.Native.all (Actuals); + else + declare + Env : constant Environments.Ptr + := Environments.Alloc (Outer => Func.Environment); + begin + Env.Set_Binds (Func.Formals, Actuals); + return Eval.all (Func.Expression.Deref, Env); + end; + end if; + end Apply; + + function Assoc (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Map, Atoms.No_Element, + Args (Args'First).Map.Assoc (Args (Args'First + 1 .. Args'Last))); + + function Atom (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Atom, Atoms.No_Element, Atoms.Alloc (Args (Args'First))); + + function Concat (Args : in Mal_Type_Array) return Mal_Type + is + L : array (Args'Range) of Lists.Ptr; + Sum : Natural := 0; + Result : Lists.Ptr; + begin + for I in Args'Range loop + L (I) := Args (I).L; + Sum := Sum + L (I).Length; + end loop; + Result := Lists.Alloc (Sum); + Sum := 0; + for LI of L loop + for J in 1 .. LI.Length loop + Sum := Sum + 1; + Result.Replace_Element (Sum, LI.Element (J)); + end loop; + end loop; + return (Kind_List, Atoms.No_Element, Result); + end Concat; + + function Concatenation_Of_Pr_Str + (Args : in Mal_Type_Array; + Print_Readably : in Boolean := True; + Separator : in String := " ") + return Ada.Strings.Unbounded.Unbounded_String + is + use Ada.Strings.Unbounded; + Result : Unbounded_String; + begin + if 1 <= Args'Length then + Append (Result, Printer.Pr_Str (Args (Args'First), Print_Readably)); + for I in Args'First + 1 .. Args'Last loop + Append (Result, Separator); + Append (Result, Printer.Pr_Str (Args (I), Print_Readably)); + end loop; + end if; + return Result; + end Concatenation_Of_Pr_Str; + + function Conj (Args : in Mal_Type_Array) return Mal_Type + is + List : Lists.Ptr renames Args (Args'First).L; + Result : constant Lists.Ptr + := Lists.Alloc (List.Length + Args'Length - 1); + begin + if Args (Args'First).Kind = Kind_List then + for I in Args'First + 1 .. Args'Last loop + Result.Replace_Element (Args'Last + 1 - I, Args (I)); + end loop; + for I in 1 .. List.Length loop + Result.Replace_Element (Args'Length + I - 1, List.Element (I)); + end loop; + return (Kind_List, Atoms.No_Element, Result); + else + for I in 1 .. Args'Length - 1 loop + Result.Replace_Element (List.Length + I, Args (Args'First + I)); + end loop; + for I in 1 .. List.Length loop + Result.Replace_Element (I, List.Element (I)); + end loop; + return (Kind_Vector, Atoms.No_Element, Result); + end if; + end Conj; + + function Cons (Args : in Mal_Type_Array) return Mal_Type + is + List : Lists.Ptr renames Args (Args'First + 1).L; + Result : constant Lists.Ptr := Lists.Alloc (1 + List.Length); + begin + Result.Replace_Element (1, Args (Args'First)); + for I in 1 .. List.Length loop + Result.Replace_Element (I + 1, List.Element (I)); + end loop; + return (Kind_List, Atoms.No_Element, Result); + end Cons; + + function Contains (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, + Args (Args'First).Map.Contains (Args (Args'First + 1))); + + function Count (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Number, Atoms.No_Element, + (if Args (Args'First).Kind = Kind_Nil + then 0 + else Args (Args'First).L.Length)); + + function Deref (Args : in Mal_Type_Array) return Mal_Type + is (Args (Args'First).Reference.Deref); + + function Dissoc (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Map, Atoms.No_Element, + Args (Args'First).Map.Dissoc (Args (Args'First + 1 .. Args'Last))); + + function Equals (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, + Args (Args'First) = Args (Args'First + 1)); + + function First (Args : in Mal_Type_Array) return Mal_Type + is (if Args (Args'First).Kind = Kind_Nil + or else Args (Args'First).L.Length = 0 + then (Kind_Nil, Atoms.No_Element) + else Args (Args'First).L.Element (1)); + + function Get (Args : in Mal_Type_Array) return Mal_Type is + begin + if Args (Args'First).Kind = Kind_Nil then + return (Kind_Nil, Atoms.No_Element); + else + return Args (Args'First).Map.Get (Args (Args'First + 1)); + end if; + exception + when Maps.Unknown_Key => + return (Kind_Nil, Atoms.No_Element); + end Get; + + function Hash_Map (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Map, Atoms.No_Element, Maps.Hash_Map (Args)); + + function Is_Empty (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, Args (Args'First).L.Length = 0); + + function Is_False (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, + Args (Args'First).Kind = Kind_Boolean + and then not Args (Args'First).Boolean_Value); + + function Is_True (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, + Args (Args'First).Kind = Kind_Boolean + and then Args (Args'First).Boolean_Value); + + function Is_Sequential (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Boolean, Atoms.No_Element, + Args (Args'First).Kind in Kind_List | Kind_Vector); + + function Keyword (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Keyword, Atoms.No_Element, Args (Args'First).S); + + function Keys (Args : in Mal_Type_Array) return Mal_Type + is + M : Maps.Ptr renames Args (Args'First).Map; + Result : constant Mal_Type := (Kind_List, Atoms.No_Element, + Lists.Alloc (M.Length)); + I : Natural := 0; + procedure Process (Key, Element : in Mal_Type); + procedure Process (Key, Element : in Mal_Type) is + begin + I := I + 1; + Result.L.Replace_Element (I, Key); + pragma Unreferenced (Element); + end Process; + begin + M.Iterate (Process'Access); + return Result; + end Keys; + + function List (Args : in Mal_Type_Array) return Mal_Type + is (Kind_List, Atoms.No_Element, Lists.Alloc (Args)); + + function Map (Args : in Mal_Type_Array) return Mal_Type + is + Func : Mal_Type renames Args (Args'First); + List : Lists.Ptr renames Args (Args'First + 1).L; + Actuals : Mal_Type_Array (1 .. 1); + Result : constant Lists.Ptr := Lists.Alloc (List.Length); + begin + for I in 1 .. List.Length loop + Actuals (1) := List.Element (I); + if Func.Kind = Kind_Native then + Result.Replace_Element (I, Func.Native.all (Actuals)); + else + declare + Env : constant Environments.Ptr + := Environments.Alloc (Func.Environment); + begin + Env.Set_Binds (Func.Formals, Actuals); + Result.Replace_Element (I, Eval.all (Func.Expression.Deref, + Env)); + end; + end if; + end loop; + return (Kind_List, Atoms.No_Element, Result); + end Map; + + function Meta (Args : in Mal_Type_Array) return Mal_Type + is (if Args (Args'First).Meta = Atoms.No_Element + then (Kind_Nil, Atoms.No_Element) + else Args (Args'First).Meta.Deref); + + function Nth (Args : in Mal_Type_Array) return Mal_Type + is (Args (Args'First).L.Element (1 + Args (Args'First + 1).Integer_Value)); + + function Pr_Str (Args : in Mal_Type_Array) return Mal_Type + is (Kind_String, Atoms.No_Element, Strings.Alloc + (Ada.Strings.Unbounded.To_String (Concatenation_Of_Pr_Str (Args)))); + + function Println (Args : in Mal_Type_Array) return Mal_Type is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Concatenation_Of_Pr_Str + (Args, Print_Readably => False)); + return (Kind_Nil, Atoms.No_Element); + end Println; + + function Prn (Args : in Mal_Type_Array) return Mal_Type is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Concatenation_Of_Pr_Str (Args)); + return (Kind_Nil, Atoms.No_Element); + end Prn; + + function Readline (Args : in Mal_Type_Array) return Mal_Type is + begin + Ada.Text_IO.Put (Args (Args'First).S.Deref); + return (Kind_String, Atoms.No_Element, + Strings.Alloc (Ada.Text_IO.Get_Line)); + exception + when Ada.Text_IO.End_Error => + return (Kind_Nil, Atoms.No_Element); + end Readline; + + function Read_String (Args : in Mal_Type_Array) return Mal_Type + is (Reader.Read_Str (Args (Args'First).S.Deref)); + + function Reset (Args : in Mal_Type_Array) return Mal_Type is + begin + Args (Args'First).Reference.Set (Args (Args'Last)); + return Args (Args'Last); + end Reset; + + function Rest (Args : in Mal_Type_Array) return Mal_Type + is + List : Mal_Type renames Args (Args'First); + Len : Natural; + begin + return Result : Mal_Type (Kind_List) do + if List.Kind /= Kind_Nil then + Len := List.L.Length; + if 0 < Len then + Len := Len - 1; + Result.L := Lists.Alloc (Len); + for I in 1 .. Len loop + Result.L.Replace_Element (I, List.L.Element (I + 1)); + end loop; + end if; + end if; + end return; + end Rest; + + function Seq (Args : in Mal_Type_Array) return Mal_Type is + begin + if Args (Args'First).Kind = Kind_String then + declare + S : constant String := Args (Args'First).S.Deref; + Result : Lists.Ptr; + begin + if S'Length = 0 then + return (Kind_Nil, Atoms.No_Element); + else + Result := Lists.Alloc (S'Length); + for I in S'Range loop + Result.Replace_Element (I - S'First + 1, Mal_Type' + (Kind_String, Atoms.No_Element, + Strings.Alloc (S (I .. I)))); + end loop; + return (Kind_List, Atoms.No_Element, Result); + end if; + end; + elsif Args (Args'First).Kind = Kind_Nil + or else Args (Args'First).L.Length = 0 + then + return (Kind_Nil, Atoms.No_Element); + else + return (Kind_List, Atoms.No_Element, Args (Args'First).L); + end if; + end Seq; + + function Slurp (Args : in Mal_Type_Array) return Mal_Type + is + use Ada.Strings.Unbounded; + use Ada.Text_IO; + File : File_Type; + Buffer : Unbounded_String; + begin + Open (File, In_File, Args (Args'First).S.Deref); + while not End_Of_File (File) loop + Append (Buffer, Get_Line (File)); + Append (Buffer, Ada.Characters.Latin_1.LF); + end loop; + Close (File); + return (Kind_String, Atoms.No_Element, + Strings.Alloc (To_String (Buffer))); + exception + when others => + Close (File); + raise; + end Slurp; + + function Str (Args : in Mal_Type_Array) return Mal_Type + is (Kind_String, Atoms.No_Element, Strings.Alloc + (Ada.Strings.Unbounded.To_String + (Concatenation_Of_Pr_Str (Args, + Print_Readably => False, + Separator => "")))); + + function Swap (Args : in Mal_Type_Array) return Mal_Type + is + Atom : Mal_Type renames Args (Args'First); + Func : Mal_Type renames Args (Args'First + 1); + Actuals : Mal_Type_Array (Args'First + 1 .. Args'Last); + Result : Mal_Type; + begin + Actuals (Actuals'First) := Atom.Reference.Deref; + for I in Actuals'First + 1 .. Args'Last loop + Actuals (I) := Args (I); + end loop; + if Func.Kind = Kind_Native then + Result := Func.Native.all (Actuals); + else + declare + Env : constant Environments.Ptr + := Environments.Alloc (Outer => Func.Environment); + begin + Env.Set_Binds (Func.Formals, Actuals); + Result := Eval.all (Func.Expression.Deref, Env); + end; + end if; + Atom.Reference.Set (Result); + return Result; + end Swap; + + function Symbol (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Symbol, Atoms.No_Element, Args (Args'First).S); + + function Throw (Args : in Mal_Type_Array) return Mal_Type is + begin + Last_Exception := Args (Args'First); + raise Exception_Throwed; + return (Kind_Nil, Atoms.No_Element); -- GNAT wants a return. + end Throw; + + function Time_Ms (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Number, Atoms.No_Element, + Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); + + function Vals (Args : in Mal_Type_Array) return Mal_Type + is + M : Maps.Ptr renames Args (Args'First).Map; + Result : constant Mal_Type := (Kind_List, Atoms.No_Element, + Lists.Alloc (M.Length)); + I : Natural := 0; + procedure Process (Key, Element : in Mal_Type); + procedure Process (Key, Element : in Mal_Type) is + begin + I := I + 1; + Result.L.Replace_Element (I, Element); + pragma Unreferenced (Key); + end Process; + begin + M.Iterate (Process'Access); + return Result; + end Vals; + + function Vector (Args : in Mal_Type_Array) return Mal_Type + is (Kind_Vector, Atoms.No_Element, Lists.Alloc (Args)); + + function With_Meta (Args : in Mal_Type_Array) return Mal_Type is + begin + return Result : Mal_Type := Args (Args'First) do + Result.Meta := Atoms.Alloc (Args (Args'First + 1)); + end return; + end With_Meta; + +end Core; diff --git a/ada2/core.ads b/ada2/core.ads new file mode 100644 index 0000000000..89d5414cc8 --- /dev/null +++ b/ada2/core.ads @@ -0,0 +1,17 @@ +with Environments; +with Types; pragma Elaborate_All (Types); + +package Core is + + type Eval_Callback_Type is access + function (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + + procedure Add_Built_In_Functions + (Repl : in Environments.Ptr; + Eval_Callback : in not null Eval_Callback_Type); + + Exception_Throwed : exception; + Last_Exception : Types.Mal_Type; + +end Core; diff --git a/ada2/environments.adb b/ada2/environments.adb new file mode 100644 index 0000000000..79c09bcd7f --- /dev/null +++ b/ada2/environments.adb @@ -0,0 +1,166 @@ +with Ada.Containers.Hashed_Maps; use type Ada.Containers.Count_Type; +with Ada.Unchecked_Deallocation; +with Atoms; +with Names; +with Strings; use type Strings.Ptr; +with Types; use type Types.Kind_Type; + +package body Environments is + + -- There must be a reference level so that functions may keep + -- track of their initial environment, and another one for + -- reallocations. + + package Maps is new Ada.Containers.Hashed_Maps + (Key_Type => Strings.Ptr, + Element_Type => Types.Mal_Type, + Hash => Strings.Hash, + Equivalent_Keys => Strings."=", + "=" => Types."="); + + type Env_Record is limited record + Data : Maps.Map; + Outer : Env_Access; + Refs : Positive; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Object => Env_Record, + Name => Env_Access); + + ---------------------------------------------------------------------- + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Alloc return Ptr + is (Ada.Finalization.Controlled with + Ref => new Env_Record'(Data => Maps.Empty_Map, + Outer => null, + Refs => 1)); + + function Alloc (Outer : in Ptr) return Ptr is + begin + Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + return (Ada.Finalization.Controlled with + Ref => new Env_Record'(Data => Maps.Empty_Map, + Outer => Outer.Ref, + Refs => 1)); + end Alloc; + + procedure Finalize (Object : in out Ptr) + is + Ref : Env_Access; + Refs : Positive; + begin + if Object.Ref /= null then + Ref := Object.Ref; + Object.Ref := null; + loop + Refs := Ref.all.Refs; + if 1 < Refs then + Ref.all.Refs := Refs - 1; + exit; + end if; + declare + Tmp : Env_Access := Ref; + begin + Ref := Ref.all.Outer; + Free (Tmp); + end; + exit when Ref = null; + end loop; + end if; + end Finalize; + + function Get (Container : in Ptr; + Key : in Strings.Ptr) return Types.Mal_Type + is + Ref : Env_Access := Container.Ref; + Position : Maps.Cursor; + begin + loop + Position := Ref.all.Data.Find (Key); + if Maps.Has_Element (Position) then + return Ref.all.Data (Position); + end if; + Ref := Ref.all.Outer; + exit when Ref = null; + end loop; + raise Unknown_Key with "'" & Key.Deref & "' not found"; + end Get; + + procedure Increase_Capacity (Container : in Ptr; + Capacity : in Natural) + is + New_Capacity : constant Ada.Containers.Count_Type + := Container.Ref.all.Data.Length + + Ada.Containers.Count_Type (Capacity); + begin + if Container.Ref.all.Data.Capacity < New_Capacity then + Container.Ref.all.Data.Reserve_Capacity (New_Capacity); + end if; + end Increase_Capacity; + + procedure Replace_With_Subenv (Item : in out Ptr) is + begin + if 1 < Item.Ref.all.Refs then + Item.Ref := new Env_Record'(Data => Maps.Empty_Map, + Outer => Item.Ref, + Refs => 1); + end if; + end Replace_With_Subenv; + + procedure Set (Container : in Ptr; + Key : in Strings.Ptr; + New_Item : in Types.Mal_Type) is + begin + Container.Ref.all.Data.Include (Key, New_Item); + end Set; + + procedure Set_Binds (Container : in Ptr; + Formals : in Lists.Ptr; + Actuals : in Types.Mal_Type_Array) + is + -- The assertions should be a precondition, but cannot be + -- expressed with a "limited with" view on Types. + begin + if Formals.Length <= 1 + or else Formals.Element (Formals.Length - 1).S /= Names.Ampersand + then + pragma Assert (Formals.Length = Actuals'Length); + pragma Assert (for all I in 1 .. Formals.Length => + Formals.Element (I).Kind = Types.Kind_Symbol + and then Formals.Element (I).S /= Names.Ampersand); + Increase_Capacity (Container, Formals.Length); + for I in 1 .. Formals.Length loop + Container.Ref.all.Data.Include (Formals.Element (I).S, + Actuals (Actuals'First + I - 1)); + end loop; + else + declare + Len : constant Natural := Formals.Length - 2; + begin + pragma Assert (Len <= Actuals'Length); + pragma Assert (for all I in 1 .. Len => + Formals.Element (I).Kind = Types.Kind_Symbol + and then Formals.Element (I).S /= Names.Ampersand); + pragma Assert (Formals.Element (Len + 1).Kind = Types.Kind_Symbol); + pragma Assert (Formals.Element (Len + 1).S = Names.Ampersand); + pragma Assert (Formals.Element (Len + 2).Kind = Types.Kind_Symbol); + pragma Assert (Formals.Element (Len + 2).S /= Names.Ampersand); + Increase_Capacity (Container, Len + 1); + for I in 1 .. Len loop + Container.Ref.all.Data.Include + (Formals.Element (I).S, Actuals (Actuals'First + I - 1)); + end loop; + Container.Ref.all.Data.Include + (Formals.Element (Formals.Length).S, + (Types.Kind_List, Atoms.No_Element, + Lists.Alloc (Actuals (Actuals'First + Len .. Actuals'Last)))); + end; + end if; + end Set_Binds; + +end Environments; diff --git a/ada2/environments.ads b/ada2/environments.ads new file mode 100644 index 0000000000..c1584be4b9 --- /dev/null +++ b/ada2/environments.ads @@ -0,0 +1,54 @@ +private with Ada.Finalization; +with Lists; +with Strings; +limited with Types; + +package Environments is + + type Ptr is tagged private; + -- Any variable must be assigned immediately with one of the two + -- following functions. + function Alloc return Ptr + with Inline; + function Alloc (Outer : in Ptr) return Ptr + with Inline; + -- A hidden invariant ensures this when assertions are enabled. + + procedure Increase_Capacity (Container : in Ptr; + Capacity : in Natural) + with Inline; + + procedure Replace_With_Subenv (Item : in out Ptr) + with Inline; + -- Equivalent to Item := Alloc (Outer => Item, Capacity), but + -- faster when Item was the last reference to its environment, as + -- the storage and maps are then reused. + + procedure Set (Container : in Ptr; + Key : in Strings.Ptr; + New_Item : in Types.Mal_Type) + with Inline; + + procedure Set_Binds (Container : in Ptr; + Formals : in Lists.Ptr; + Actuals : in Types.Mal_Type_Array); + + function Get (Container : in Ptr; + Key : in Strings.Ptr) return Types.Mal_Type; + Unknown_Key : exception; + + -- procedure Dump; + +private + + type Env_Record; + type Env_Access is access Env_Record; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Env_Access := null; + end record + with Invariant => Ptr.Ref /= null; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr); + -- Predefined equality is fine. + +end Environments; diff --git a/ada2/lists.adb b/ada2/lists.adb new file mode 100644 index 0000000000..6aed887521 --- /dev/null +++ b/ada2/lists.adb @@ -0,0 +1,95 @@ +with Ada.Unchecked_Deallocation; +with Atoms; +with Types; + +package body Lists is + + type List_Record (Last : Positive) is limited record + Data : Types.Mal_Type_Array (1 .. Last); + Refs : Positive; + end record; + -- The invariant for Ptr is: + -- Ptr.Ref = null or else Ptr.First <= Ptr.Ref.all.Last + -- but we cannot express this in the specification because the limited + -- view on Types forbids to define List_Record there. + + procedure Free is new Ada.Unchecked_Deallocation (Object => List_Record, + Name => List_Access); + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in Ptr) return Boolean is + (if Left.Ref = null + then Right.Ref = null + else + -- As strange as it may seem, this assertion fails when + -- running "(= [(list)] (list []))". + -- pragma Assert + -- ((Left.Ref.all.Data (1) = Right.Ref.all.Data (1)) + -- = + -- (Left.Ref.all.Data (1 .. 1) = Right.Ref.all.Data (1 .. 1))); + -- This may be a compiler bug. + Right.Ref /= null + and then Left.Ref.all.Last = Right.Ref.all.Last + and then (for all I in 1 .. Left.Ref.all.Last => + Types."=" (Left.Ref.all.Data (I), + Right.Ref.all.Data (I)))); + + procedure Adjust (Object : in out Ptr) is + begin + if Object.Ref /= null then + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end if; + end Adjust; + + function Element (Container : in Ptr; + Index : in Positive) return Types.Mal_Type is + (Container.Ref.all.Data (Index)); + + procedure Finalize (Object : in out Ptr) + is + Refs : Positive; + begin + -- Ensure that we can be called twice in a row (7.6.1(24)). + if Object.Ref /= null then + Refs := Object.Ref.all.Refs; + if 1 < Refs then + Object.Ref.all.Refs := Refs - 1; + Object.Ref := null; + else + -- pragma Assert (Ptr (Object.Ref.all.Id) = Object.Ref); + -- Ptr (Object.Ref.all.Id) := null; + Free (Object.Ref); + end if; + end if; + end Finalize; + + function Length (Source : in Ptr) return Natural is + (if Source.Ref = null then 0 else Source.Ref.all.Last); + + function Alloc (Source : in Types.Mal_Type_Array) return Ptr is + (if Source'Length = 0 + then Empty_List + else (Ada.Finalization.Controlled with + Ref => new List_Record'(Data => Source, + Last => Source'Length, + Refs => 1))); + + function Alloc (Length : in Natural) return Ptr is + (if Length = 0 + then Empty_List + else (Ada.Finalization.Controlled with + Ref => new List_Record' + (Data => (1 .. Length => (Types.Kind_Nil, Atoms.No_Element)), + Last => Length, + Refs => 1))); + + procedure Replace_Element (Source : in Ptr; + Index : in Positive; + New_Value : in Types.Mal_Type) is + begin + pragma Assert (Source.Ref.all.Refs = 1); + Source.Ref.all.Data (Index) := New_Value; + end Replace_Element; + +end Lists; diff --git a/ada2/lists.ads b/ada2/lists.ads new file mode 100644 index 0000000000..28c76cfe39 --- /dev/null +++ b/ada2/lists.ads @@ -0,0 +1,47 @@ +private with Ada.Finalization; +limited with Types; + +package Lists is + + -- A pointer to an array of Mal_Type elements. It differs from + -- Ada.Containers.Vectors because assignment give another pointer + -- to the same storage and does not copy contents. + + type Ptr is tagged private; + Empty_List : constant Ptr; -- The default value. + + function Length (Source : in Ptr) return Natural + with Inline; + + function Element (Container : in Ptr; + Index : in Positive) return Types.Mal_Type + with Inline, Pre => Index <= Container.Length; + + function Alloc (Length : in Natural) return Ptr + with Inline; + -- All elements are Nil, the default value for Mal_Type. + + function Alloc (Source : in Types.Mal_Type_Array) return Ptr + with Inline; + + procedure Replace_Element (Source : in Ptr; + Index : in Positive; + New_Value : in Types.Mal_Type) + with Inline, Pre => Index <= Source.Length; + -- An assertion checks that Source is the only reference to its + -- storage. + +private + + type List_Record; + type List_Access is access List_Record; + type Ptr is new Ada.Finalization.Controlled with record + Ref : List_Access := null; + end record; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + overriding function "=" (Left, Right : in Ptr) return Boolean; + + Empty_List : constant Ptr := (Ada.Finalization.Controlled with Ref => null); + +end Lists; diff --git a/ada2/maps.adb b/ada2/maps.adb new file mode 100644 index 0000000000..f1e1eacc85 --- /dev/null +++ b/ada2/maps.adb @@ -0,0 +1,160 @@ +with Ada.Containers.Hashed_Maps; +with Ada.Unchecked_Deallocation; +with Strings; +with Types; + +package body Maps is + + function Hash (Item : in Types.Mal_Type) return Ada.Containers.Hash_Type + with Inline, Pre => Item.Kind in Types.Kind_String | Types.Kind_Keyword; + + package Hashed_Maps is new Ada.Containers.Hashed_Maps + (Key_Type => Types.Mal_Type, + Element_Type => Types.Mal_Type, + Hash => Hash, + Equivalent_Keys => Types."=", + "=" => Types."="); + + type Map_Record is limited record + Data : Hashed_Maps.Map; + Refs : Positive; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Object => Map_Record, + Name => Map_Access); + + use type Ada.Containers.Count_Type; + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in Ptr) return Boolean is + (Hashed_Maps."=" (Left.Ref.all.Data, Right.Ref.all.Data)); + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Assoc (Container : in Ptr; + Pairs : in Types.Mal_Type_Array) return Ptr + is + pragma Assert (Pairs'Length mod 2 = 0); + Pair_Count : constant Ada.Containers.Count_Type + := Ada.Containers.Count_Type (Pairs'Length) / 2; + Result : Ptr; + begin + Result.Ref.all.Data.Reserve_Capacity (Pair_Count + + Container.Ref.all.Data.Length); + Result.Ref.all.Data.Assign (Container.Ref.all.Data); + for I in 0 .. Pairs'Length / 2 - 1 loop + pragma Assert (Pairs (Pairs'First + 2 * I).Kind in Types.Kind_String + | Types.Kind_Keyword); + Result.Ref.all.Data.Include (Pairs (Pairs'First + 2 * I), + Pairs (Pairs'First + 2 * I + 1)); + end loop; + return Result; + end Assoc; + + function Contains (Container : in Ptr; + Key : in Types.Mal_Type) return Boolean is + (Container.Ref.all.Data.Contains (Key)); + + function Dissoc (Source : in Ptr; + Keys : in Types.Mal_Type_Array) return Ptr + is + Result : Ptr; + begin + Result.Ref.all.Data.Assign (Source.Ref.all.Data); + for I in Keys'Range loop + pragma Assert (Keys (I).Kind in Types.Kind_String + | Types.Kind_Keyword); + Result.Ref.all.Data.Exclude (Keys (I)); + end loop; + return Result; + end Dissoc; + + procedure Finalize (Object : in out Ptr) + is + Refs : Positive; + begin + -- Finalize may be called twice. + if Object.Ref /= null then + Refs := Object.Ref.all.Refs; + if 1 < Refs then + Object.Ref.all.Refs := Refs - 1; + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + procedure Iterate + (Container : in Ptr; + Process : not null access procedure (Key : in Types.Mal_Type; + Element : in Types.Mal_Type)) is + begin + for Position in Container.Ref.all.Data.Iterate loop + Process.all (Hashed_Maps.Key (Position), + Hashed_Maps.Element (Position)); + end loop; + end Iterate; + + function Get (Container : in Ptr; + Key : in Types.Mal_Type) return Types.Mal_Type + is + Position : Hashed_Maps.Cursor; + begin + Position := Container.Ref.all.Data.Find (Key); + if Hashed_Maps.Has_Element (Position) then + return Hashed_Maps.Element (Position); + end if; + raise Unknown_Key with "'" & Key.S.Deref & "' not found"; + end Get; + + function Hash (Item : in Types.Mal_Type) return Ada.Containers.Hash_Type is + (Item.S.Hash); + + function Hash_Map (Pairs : in Types.Mal_Type_Array) return Ptr + is + pragma Assert (Pairs'Length mod 2 = 0); + Pair_Count : constant Ada.Containers.Count_Type + := Ada.Containers.Count_Type (Pairs'Length) / 2; + Result : Ptr; + begin + Result.Ref.all.Data.Reserve_Capacity (Pair_Count); + for I in 0 .. Pairs'Length / 2 - 1 loop + pragma Assert (Pairs (Pairs'First + 2 * I).Kind in Types.Kind_String + | Types.Kind_Keyword); + Result.Ref.all.Data.Include (Pairs (Pairs'First + 2 * I), + Pairs (Pairs'First + 2 * I + 1)); + end loop; + return Result; + end Hash_Map; + + procedure Initialize (Object : in out Ptr) is + begin + Object.Ref := new Map_Record'(Data => Hashed_Maps.Empty_Map, + Refs => 1); + end Initialize; + + function Length (Container : in Ptr) return Natural + is (Natural (Container.Ref.all.Data.Length)); + + function Map (Container : in Ptr; + F : not null access function (X : in Types.Mal_Type) + return Types.Mal_Type) + return Ptr + is + Result : Ptr; + begin + Result.Ref.all.Data.Assign (Container.Ref.all.Data); + -- Ensure the invariants before calling F, in case it raises exceptions. + for Position in Result.Ref.all.Data.Iterate loop + Result.Ref.all.Data.Replace_Element + (Position, F.all (Hashed_Maps.Element (Position))); + end loop; + return Result; + end Map; + +end Maps; diff --git a/ada2/maps.ads b/ada2/maps.ads new file mode 100644 index 0000000000..5bf81efa14 --- /dev/null +++ b/ada2/maps.ads @@ -0,0 +1,59 @@ +private with Ada.Finalization; +with Lists; +limited with Types; + +package Maps is + + -- A pointer to an Ada.Containers.Hashed_Maps.Map of + -- Types.Mal_Type. Keys must be Strings or Keywords. We can + -- probably not state this with a limited with, so this will + -- become an assertion. + + type Ptr is tagged private; + -- The default value is empty. + + function Length (Container : in Ptr) return Natural + with Inline; + + function Hash_Map (Pairs : in Types.Mal_Type_Array) return Ptr; + + function Assoc (Container : in Ptr; + Pairs : in Types.Mal_Type_Array) return Ptr; + + function Dissoc (Source : in Ptr; + Keys : in Types.Mal_Type_Array) return Ptr; + + function Map (Container : in Ptr; + F : not null access function (X : in Types.Mal_Type) + return Types.Mal_Type) + return Ptr; + + procedure Iterate + (Container : in Ptr; + Process : not null access procedure (Key : in Types.Mal_Type; + Element : in Types.Mal_Type)) + with Inline; + + function Contains (Container : in Ptr; + Key : in Types.Mal_Type) return Boolean + with Inline; + + function Get (Container : in Ptr; + Key : in Types.Mal_Type) return Types.Mal_Type + with Inline; + Unknown_Key : exception; + +private + + type Map_Record; + type Map_Access is access Map_Record; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Map_Access := null; + end record + with Invariant => Ptr.Ref /= null; + overriding procedure Initialize (Object : in out Ptr) with Inline; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + overriding function "=" (Left, Right : in Ptr) return Boolean with Inline; + +end Maps; diff --git a/ada2/names.ads b/ada2/names.ads new file mode 100644 index 0000000000..40613a160c --- /dev/null +++ b/ada2/names.ads @@ -0,0 +1,87 @@ +with Strings; use Strings; + +package Names is + + -- Symbols known at compile time are allocated at program + -- start, in order to avoid repeated allocations and + -- deallocations during each Read and /Eval/Print cycle. The + -- reference is kept so each usage does not trigger a search in + -- the global hash map. + + Ada2 : constant Ptr := Alloc ("ada2"); + Ampersand : constant Ptr := Alloc ("&"); + Apply : constant Ptr := Alloc ("apply"); + Argv : constant Ptr := Alloc ("*ARGV*"); + Assoc : constant Ptr := Alloc ("assoc"); + Asterisk : constant Ptr := Alloc ("*"); + Atom : constant Ptr := Alloc ("atom"); + Catch : constant Ptr := Alloc ("catch*"); + Concat : constant Ptr := Alloc ("concat"); + Conj : constant Ptr := Alloc ("conj"); + Cons : constant Ptr := Alloc ("cons"); + Contains : constant Ptr := Alloc ("contains?"); + Count : constant Ptr := Alloc ("count"); + Def : constant Ptr := Alloc ("def!"); + Defmacro : constant Ptr := Alloc ("defmacro!"); + Deref : constant Ptr := Alloc ("deref"); + Dissoc : constant Ptr := Alloc ("dissoc"); + Equals : constant Ptr := Alloc ("="); + Eval : constant Ptr := Alloc ("eval"); + First : constant Ptr := Alloc ("first"); + Fn : constant Ptr := Alloc ("fn*"); + Get : constant Ptr := Alloc ("get"); + Greater_Equal : constant Ptr := Alloc (">="); + Greater_Than : constant Ptr := Alloc (">"); + Hash_Map : constant Ptr := Alloc ("hash-map"); + Host_Language : constant Ptr := Alloc ("*host-language*"); + Is_Atom : constant Ptr := Alloc ("atom?"); + Is_Empty : constant Ptr := Alloc ("empty?"); + Is_False : constant Ptr := Alloc ("false?"); + Is_Keyword : constant Ptr := Alloc ("keyword?"); + Is_List : constant Ptr := Alloc ("list?"); + Is_Map : constant Ptr := Alloc ("map?"); + Is_Nil : constant Ptr := Alloc ("nil?"); + Is_Sequential : constant Ptr := Alloc ("sequential?"); + Is_String : constant Ptr := Alloc ("string?"); + Is_Symbol : constant Ptr := Alloc ("symbol?"); + Is_True : constant Ptr := Alloc ("true?"); + Is_Vector : constant Ptr := Alloc ("vector?"); + Keys : constant Ptr := Alloc ("keys"); + Keyword : constant Ptr := Alloc ("keyword"); + Less_Equal : constant Ptr := Alloc ("<="); + Less_Than : constant Ptr := Alloc ("<"); + Let : constant Ptr := Alloc ("let*"); + List : constant Ptr := Alloc ("list"); + Macroexpand : constant Ptr := Alloc ("macroexpand"); + Mal_Do : constant Ptr := Alloc ("do"); + Mal_If : constant Ptr := Alloc ("if"); + Map : constant Ptr := Alloc ("map"); + Meta : constant Ptr := Alloc ("meta"); + Minus : constant Ptr := Alloc ("-"); + Nth : constant Ptr := Alloc ("nth"); + Plus : constant Ptr := Alloc ("+"); + Pr_Str : constant Ptr := Alloc ("pr-str"); + Println : constant Ptr := Alloc ("println"); + Prn : constant Ptr := Alloc ("prn"); + Quasiquote : constant Ptr := Alloc ("quasiquote"); + Quote : constant Ptr := Alloc ("quote"); + Read_String : constant Ptr := Alloc ("read-string"); + Readline : constant Ptr := Alloc ("readline"); + Reset : constant Ptr := Alloc ("reset!"); + Rest : constant Ptr := Alloc ("rest"); + Seq : constant Ptr := Alloc ("seq"); + Slash : constant Ptr := Alloc ("/"); + Slurp : constant Ptr := Alloc ("slurp"); + Splice_Unquote : constant Ptr := Alloc ("splice-unquote"); + Str : constant Ptr := Alloc ("str"); + Swap : constant Ptr := Alloc ("swap!"); + Symbol : constant Ptr := Alloc ("symbol"); + Throw : constant Ptr := Alloc ("throw"); + Time_Ms : constant Ptr := Alloc ("time-ms"); + Try : constant Ptr := Alloc ("try*"); + Unquote : constant Ptr := Alloc ("unquote"); + Vals : constant Ptr := Alloc ("vals"); + Vector : constant Ptr := Alloc ("vector"); + With_Meta : constant Ptr := Alloc ("with-meta"); + +end Names; diff --git a/ada2/printer.adb b/ada2/printer.adb new file mode 100644 index 0000000000..6b21c4a7ef --- /dev/null +++ b/ada2/printer.adb @@ -0,0 +1,177 @@ +with Ada.Characters.Latin_1; +with Atoms; +with Lists; +with Maps; +with Strings; + +package body Printer is + + use Ada.Strings.Unbounded; + use Types; + + procedure Print_Form (Buffer : in out Unbounded_String; + Ast : in Mal_Type; + Print_Readably : in Boolean); + procedure Print_List (Buffer : in out Unbounded_String; + List : in Lists.Ptr; + Print_Readably : in Boolean) + with Inline; + procedure Print_Function (Buffer : in out Unbounded_String; + Formals : in Lists.Ptr; + Expression : in Atoms.Ptr; + Print_Readably : in Boolean) + with Inline; + procedure Print_Map (Buffer : in out Unbounded_String; + Map : in Maps.Ptr; + Print_Readably : in Boolean) + with Inline; + + ---------------------------------------------------------------------- + + procedure Print_Form (Buffer : in out Unbounded_String; + Ast : in Mal_Type; + Print_Readably : in Boolean) is + begin + case Ast.Kind is + + when Kind_Nil => + Append (Buffer, "nil"); + + when Kind_Boolean => + if Ast.Boolean_Value then + Append (Buffer, "true"); + else + Append (Buffer, "false"); + end if; + + when Kind_Symbol => + Append (Buffer, Ast.S.Deref); + + when Kind_Number => + declare + Img : constant String := Integer'Image (Ast.Integer_Value); + F : Positive := Img'First; + begin + if Img (F) = ' ' then + F := F + 1; + end if; + Append (Buffer, Img (F .. Img'Last)); + end; + + when Kind_Keyword => + Append (Buffer, ':'); + Append (Buffer, Ast.S.Deref); + + when Kind_String => + if Print_Readably then + Append (Buffer, '"'); + for C of Ast.S.Deref loop + case C is + when '"' | '\' => + Append (Buffer, '\'); + Append (Buffer, C); + when Ada.Characters.Latin_1.LF => + Append (Buffer, "\n"); + when others => + Append (Buffer, C); + end case; + end loop; + Append (Buffer, '"'); + else + Append (Buffer, Ast.S.Deref); + end if; + + when Kind_List => + Append (Buffer, '('); + Print_List (Buffer, Ast.L, Print_Readably); + Append (Buffer, ')'); + when Kind_Vector => + Append (Buffer, '['); + Print_List (Buffer, Ast.L, Print_Readably); + Append (Buffer, ']'); + + when Kind_Map => + Print_Map (Buffer, Ast.Map, Print_Readably); + + when Kind_Native => + Append (Buffer, "#"); + when Kind_Function => + Append (Buffer, "#'); + when Kind_Macro => + Append (Buffer, "#'); + + when Kind_Atom => + Append (Buffer, "(atom "); + Print_Form (Buffer, Ast.Reference.Deref, Print_Readably); + Append (Buffer, ')'); + + end case; + end Print_Form; + + procedure Print_Function (Buffer : in out Unbounded_String; + Formals : in Lists.Ptr; + Expression : in Atoms.Ptr; + Print_Readably : in Boolean) is + begin + if 0 < Formals.Length then + Print_List (Buffer, Formals, Print_Readably); + Append (Buffer, " -> "); + Print_Form (Buffer, Expression.Deref, Print_Readably); + end if; + end Print_Function; + + procedure Print_List (Buffer : in out Unbounded_String; + List : in Lists.Ptr; + Print_Readably : in Boolean) is + begin + if 1 <= List.Length then + Print_Form (Buffer, List.Element (1), Print_Readably); + for I in 2 .. List.Length loop + Append (Buffer, ' '); + Print_Form (Buffer, List.Element (I), Print_Readably); + end loop; + end if; + end Print_List; + + procedure Print_Map (Buffer : in out Unbounded_String; + Map : in Maps.Ptr; + Print_Readably : in Boolean) + is + Is_First : Boolean := True; + procedure Process (Key : in Mal_Type; + Element : in Mal_Type); + procedure Process (Key : in Mal_Type; + Element : in Mal_Type) is + begin + if Is_First then + Is_First := False; + else + Append (Buffer, ' '); + end if; + Print_Form (Buffer, Key, Print_Readably); + Append (Buffer, ' '); + Print_Form (Buffer, Element, Print_Readably); + end Process; + begin + Append (Buffer, '{'); + Map.Iterate (Process'Access); + Append (Buffer, '}'); + end Print_Map; + + function Pr_Str (Ast : in Mal_Type; + Print_Readably : in Boolean := True) + return Unbounded_String + is + Result : Unbounded_String; + begin + Print_Form (Result, Ast, Print_Readably); + return Result; + end Pr_Str; + +end Printer; diff --git a/ada2/printer.ads b/ada2/printer.ads new file mode 100644 index 0000000000..5071a801f7 --- /dev/null +++ b/ada2/printer.ads @@ -0,0 +1,12 @@ +with Ada.Strings.Unbounded; +with Types; + +package Printer is + + pragma Elaborate_Body; + + function Pr_Str (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String; + +end Printer; diff --git a/ada2/reader.adb b/ada2/reader.adb new file mode 100644 index 0000000000..d72af57749 --- /dev/null +++ b/ada2/reader.adb @@ -0,0 +1,252 @@ +with Ada.Characters.Latin_1; +with Atoms; +with Lists; +with Maps; +with Names; +with Strings; + +package body Reader is + + function Read_Str (Source : in String) return Types.Mal_Type + is + First : Positive; + Last : Natural := Source'First - 1; + + function Read_Form return Types.Mal_Type; + + procedure Find_Next_Token; + -- Search next token from index Last + 1. + -- If none is found, set First to Source'Last + 1. + -- Find_Next_Token is normally invoked right before Read_Form, + -- allowing the caller to check whether First <= Source'Last. + + -- Helpers: + + -- Read_Atom has been merged into the same case/switch + -- statement, for clarity and efficiency. + function Read_List (Ending : in Character) return Types.Mal_Type_Array + with Inline; + function Read_Quote (Symbol : in Strings.Ptr) return Types.Mal_Type + with Inline; + + ---------------------------------------------------------------------- + procedure Find_Next_Token + is + use Ada.Characters.Latin_1; + begin + First := Last + 1; + while First <= Source'Last loop + + case Source (First) is + + when ' ' | ',' | HT | VT | LF | CR => + First := First + 1; + + when '[' | ']' | '{' | '}' | '(' | ')' | ''' | '`' | '^' | '@' + => + Last := First; + exit; + + when '~' => + if First + 1 <= Source'Last + and then Source (First + 1) = '@' + then + Last := First + 1; + else + Last := First; + end if; + exit; + + when '"' => + Last := First + 1; + loop + if Source'Last < Last then + raise Reader_Error with "expected '""'"; + end if; + exit when Source (Last) = '"'; + if Source (Last) = '\' then + Last := Last + 1; + end if; + Last := Last + 1; + end loop; + exit; + + when ';' => + First := First + 1; + while First <= Source'Last loop + if Source (First) = LF then + First := First + 1; + exit; + end if; + First := First + 1; + end loop; + + when others => + Last := First; + while Last + 1 <= Source'Last + and then Source (Last + 1) not in + ' ' | ',' | HT | VT | LF | CR | '[' | ']' | '{' | '}' + | '(' | ')' | ''' | '`' | '^' | '@' | '~' | '"' | ';' + loop + Last := Last + 1; + end loop; + exit; + + end case; + end loop; + end Find_Next_Token; + + function Read_Form return Types.Mal_Type + is + use Types; + begin + case Source (First) is + + when '(' => + return (Kind_List, Atoms.No_Element, + Lists.Alloc (Read_List (')'))); + when '[' => + return (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Read_List (']'))); + when '{' => + return (Kind_Map, Atoms.No_Element, + Maps.Hash_Map (Read_List ('}'))); + + when '"' => + declare + Buffer : String (First .. Last); + B_Last : Natural := Buffer'First - 1; + I : Positive := First + 1; + begin + while I <= Last - 1 loop + if Source (I) /= '\' or else I = Last - 1 then + B_Last := B_Last + 1; + Buffer (B_Last) := Source (I); + else + case Source (I + 1) is + when '\' | '"' => + B_Last := B_Last + 1; + Buffer (B_Last) := Source (I + 1); + I := I + 1; + when 'n' => + B_Last := B_Last + 1; + Buffer (B_Last) := Ada.Characters.Latin_1.LF; + I := I + 1; + when others => + B_Last := B_Last + 1; + Buffer (B_Last) := Source (I); + end case; + end if; + I := I + 1; + end loop; + return (Kind_String, Atoms.No_Element, + Strings.Alloc (Buffer (Buffer'First .. B_Last))); + end; + when ':' => + return (Kind_Keyword, Atoms.No_Element, + Strings.Alloc (Source (First + 1 .. Last))); + + when '-' => + if First < Last + and then (for all C of Source (First + 1 .. Last) => + C in '0' .. '9') + then + return (Kind_Number, Atoms.No_Element, + Integer'Value (Source (First .. Last))); + else + return (Kind_Symbol, Atoms.No_Element, + Strings.Alloc (Source (First .. Last))); + end if; + when '0' .. '9' => + return (Kind_Number, Atoms.No_Element, + Integer'Value (Source (First .. Last))); + + when ''' => + return Read_Quote (Names.Quote); + when '`' => + return Read_Quote (Names.Quasiquote); + when '@' => + return Read_Quote (Names.Deref); + when '~' => + if First = Last then + return Read_Quote (Names.Unquote); + else + return Read_Quote (Names.Splice_Unquote); + end if; + when '^' => + return Result : constant Mal_Type + := (Kind_List, Atoms.No_Element, Lists.Alloc (3)) + do + Result.L.Replace_Element (1, Mal_Type' + (Kind_Symbol, Atoms.No_Element, Names.With_Meta)); + Find_Next_Token; + if Source'Last < First then + raise Reader_Error with "Unfinished 'with-meta'"; + end if; + Result.L.Replace_Element (3, Read_Form); + Find_Next_Token; + if Source'Last < First then + raise Reader_Error with "Unfinished 'with-meta'"; + end if; + Result.L.Replace_Element (2, Read_Form); + end return; + + when others => + if Source (First .. Last) = "nil" then + return (Kind_Nil, Atoms.No_Element); + elsif Source (First .. Last) = "true" then + return (Kind_Boolean, Atoms.No_Element, True); + elsif Source (First .. Last) = "false" then + return (Kind_Boolean, Atoms.No_Element, False); + else + return (Kind_Symbol, Atoms.No_Element, + Strings.Alloc (Source (First .. Last))); + end if; + end case; + end Read_Form; + + function Read_List (Ending : in Character) return Types.Mal_Type_Array + is + -- Using big arrays on the stack is faster than doing + -- repeated dynamic reallocations. + Buffer : Types.Mal_Type_Array (First + 1 .. Source'Last); + B_Last : Natural := Buffer'First - 1; + begin + loop + Find_Next_Token; + if Source'Last < First then + raise Reader_Error with "expected '" & Ending & "'"; + end if; + exit when Source (First) = Ending; + B_Last := B_Last + 1; + Buffer (B_Last) := Read_Form; + end loop; + return Buffer (Buffer'First .. B_Last); + end Read_List; + + function Read_Quote (Symbol : in Strings.Ptr) return Types.Mal_Type is + use Types; + Result : constant Mal_Type + := (Kind_List, Atoms.No_Element, Lists.Alloc (2)); + begin + Result.L.Replace_Element (1, + Mal_Type'(Kind_Symbol, Atoms.No_Element, Symbol)); + Find_Next_Token; + if Source'Last < First then + raise Reader_Error with "Unfinished '" & Symbol.Deref & "'"; + end if; + Result.L.Replace_Element (2, Read_Form); + return Result; + end Read_Quote; + + ---------------------------------------------------------------------- + + begin + Find_Next_Token; + if Source'Last < First then + raise Empty_Source; + end if; + return Read_Form; + end Read_Str; + +end Reader; diff --git a/ada2/reader.ads b/ada2/reader.ads new file mode 100644 index 0000000000..d5e85b36bd --- /dev/null +++ b/ada2/reader.ads @@ -0,0 +1,12 @@ +with Types; + +package Reader is + + pragma Elaborate_Body; + + function Read_Str (Source : in String) return Types.Mal_Type; + + Empty_Source : exception; + Reader_Error : exception; + +end Reader; diff --git a/ada2/run b/ada2/run new file mode 100755 index 0000000000..8ba68a5484 --- /dev/null +++ b/ada2/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/ada2/step0_repl.adb b/ada2/step0_repl.adb new file mode 100644 index 0000000000..bf8d73ab17 --- /dev/null +++ b/ada2/step0_repl.adb @@ -0,0 +1,64 @@ +with Ada.Exceptions; +with Ada.Text_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; + +procedure Step0_Repl is + + function Read (Source : in String) return String + is (Source); + + function Eval (Ast : in String) return String + is (Ast); + + function Print (Ast : in String) return String + is (Ast); + + function Rep (Source : in String) return String + is (Print (Eval (Read (Source)))); + + procedure Interactive_Loop; + + ---------------------------------------------------------------------- + + procedure Interactive_Loop + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Put_Line (Rep (Line)); + exception + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + +begin + Interactive_Loop; +end Step0_Repl; diff --git a/ada2/step1_read_print.adb b/ada2/step1_read_print.adb new file mode 100644 index 0000000000..b68f1197c2 --- /dev/null +++ b/ada2/step1_read_print.adb @@ -0,0 +1,75 @@ +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Printer; +with Reader; +with Types; + +procedure Step1_Read_Print is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Ast : in Types.Mal_Type) return Types.Mal_Type + is (Ast); + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source)))) + with Inline; + + procedure Interactive_Loop + with Inline; + + ---------------------------------------------------------------------- + + procedure Interactive_Loop + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + +begin + Interactive_Loop; +end Step1_Read_Print; diff --git a/ada2/step2_eval.adb b/ada2/step2_eval.adb new file mode 100644 index 0000000000..3c72b8c7d9 --- /dev/null +++ b/ada2/step2_eval.adb @@ -0,0 +1,175 @@ +with Ada.Containers.Indefinite_Hashed_Maps; +with Ada.Exceptions; +with Ada.Strings.Hash; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Lists; +with Printer; +with Reader; +with Types; + +procedure Step2_Eval is + + package Environments is new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => Types.Native_Function_Access, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "=", + "=" => Types."="); + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Ast : in Types.Mal_Type; + Env : in out Environments.Map) return Types.Mal_Type; + Unable_To_Call : exception; + Unknown_Symbol : exception; + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in out Environments.Map) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in out Environments.Map) + with Inline; + + generic + with function Ada_Operator (Left, Right : in Integer) return Integer; + function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) + return Types.Mal_Type; + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.Mal_Type; + Env : in out Environments.Map) return Types.Mal_Type + is + use Types; + begin + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + declare + S : constant String := Ast.S.Deref; + C : constant Environments.Cursor := Env.Find (S); + begin + if Environments.Has_Element (C) then + return (Kind_Native, Atoms.No_Element, + Environments.Element (C)); + else + raise Unknown_Symbol with "'" & S & "' not found"; + end if; + end; + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + -- Apply phase + declare + First : constant Mal_Type := Eval (Ast.L.Element (1), Env); + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + case First.Kind is + when Kind_Native => + return First.Native.all (Args); + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) + return Types.Mal_Type + is (Types.Kind_Number, Atoms.No_Element, + Ada_Operator (Args (Args'First).Integer_Value, + Args (Args'First + 1).Integer_Value)); + + procedure Interactive_Loop (Repl : in out Environments.Map) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + + function Addition is new Generic_Mal_Operator ("+"); + function Subtraction is new Generic_Mal_Operator ("-"); + function Product is new Generic_Mal_Operator ("*"); + function Division is new Generic_Mal_Operator ("/"); + + Repl : Environments.Map; +begin + Repl.Include ("+", Addition 'Unrestricted_Access); + Repl.Include ("-", Subtraction'Unrestricted_Access); + Repl.Include ("*", Product 'Unrestricted_Access); + Repl.Include ("/", Division 'Unrestricted_Access); + + Interactive_Loop (Repl); + pragma Unreferenced (Repl); +end Step2_Eval; diff --git a/ada2/step3_env.adb b/ada2/step3_env.adb new file mode 100644 index 0000000000..b19d660b6a --- /dev/null +++ b/ada2/step3_env.adb @@ -0,0 +1,199 @@ +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; + +procedure Step3_Env is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + generic + with function Ada_Operator (Left, Right : in Integer) return Integer; + function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) + return Types.Mal_Type; + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + First : Mal_Type; + begin + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + New_Env : constant Environments.Ptr + := Environments.Alloc (Outer => Env); + begin + New_Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + New_Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), New_Env)); + end loop; + return Eval (Ast.L.Element (3), New_Env); + end; + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + case First.Kind is + when Kind_Native => + return First.Native.all (Args); + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) + return Types.Mal_Type + is (Types.Kind_Number, Atoms.No_Element, + Ada_Operator (Args (Args'First).Integer_Value, + Args (Args'First + 1).Integer_Value)); + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + + function Addition is new Generic_Mal_Operator ("+"); + function Subtraction is new Generic_Mal_Operator ("-"); + function Product is new Generic_Mal_Operator ("*"); + function Division is new Generic_Mal_Operator ("/"); + + use Types; + Repl : constant Environments.Ptr := Environments.Alloc; +begin + Repl.Increase_Capacity (4); + Repl.Set (Names.Plus, Types.Mal_Type' + (Types.Kind_Native, Atoms.No_Element, Addition'Unrestricted_Access)); + Repl.Set (Names.Minus, Types.Mal_Type' + (Types.Kind_Native, Atoms.No_Element, Subtraction'Unrestricted_Access)); + Repl.Set (Names.Asterisk, Types.Mal_Type' + (Types.Kind_Native, Atoms.No_Element, Product'Unrestricted_Access)); + Repl.Set (Names.Slash, Types.Mal_Type' + (Types.Kind_Native, Atoms.No_Element, Division'Unrestricted_Access)); + + Interactive_Loop (Repl); +end Step3_Env; diff --git a/ada2/step4_if_fn_do.adb b/ada2/step4_if_fn_do.adb new file mode 100644 index 0000000000..c554a6ec12 --- /dev/null +++ b/ada2/step4_if_fn_do.adb @@ -0,0 +1,231 @@ +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; + +procedure Step4_If_Fn_Do is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + First : Mal_Type; + begin + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + return Eval (Ast.L.Element (Ast.L.Length), Env); + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + return Eval (Ast.L.Element (3), Env); + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + return Eval (Ast.L.Element (4), Env); + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + New_Env : constant Environments.Ptr + := Environments.Alloc (Outer => Env); + begin + New_Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + New_Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), New_Env)); + end loop; + return Eval (Ast.L.Element (3), New_Env); + end; + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + case First.Kind is + when Kind_Native => + return First.Native.all (Args); + when Kind_Function => + declare + New_Env : constant Environments.Ptr + := Environments.Alloc (Outer => First.Environment); + begin + New_Env.Set_Binds (First.Formals, Args); + return Eval (First.Expression.Deref, New_Env); + end; + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + + Repl : constant Environments.Ptr := Environments.Alloc; +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + + Interactive_Loop (Repl); +end Step4_If_Fn_Do; diff --git a/ada2/step5_tco.adb b/ada2/step5_tco.adb new file mode 100644 index 0000000000..3838b6b3ad --- /dev/null +++ b/ada2/step5_tco.adb @@ -0,0 +1,234 @@ +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; + +procedure Step5_Tco is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + ---------------------------------------------------------------------- + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + Ast : Types.Mal_Type := Rec_Ast; + Env : Environments.Ptr := Rec_Env; + First : Mal_Type; + begin + <> + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + Ast := Ast.L.Element (3); + goto Restart; + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + begin + Env.Replace_With_Subenv; + Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + case First.Kind is + when Kind_Native => + return First.Native.all (Args); + when Kind_Function => + Env := Environments.Alloc (Outer => First.Environment); + Env.Set_Binds (First.Formals, Args); + Ast := First.Expression.Deref; + goto Restart; + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + + Repl : constant Environments.Ptr := Environments.Alloc; +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + + Interactive_Loop (Repl); +end Step5_Tco; diff --git a/ada2/step6_file.adb b/ada2/step6_file.adb new file mode 100644 index 0000000000..7670995b73 --- /dev/null +++ b/ada2/step6_file.adb @@ -0,0 +1,260 @@ +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; + +procedure Step6_File is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + -- Eval, with a profile compatible with Native_Function_Access. + function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + + ---------------------------------------------------------------------- + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + Ast : Types.Mal_Type := Rec_Ast; + Env : Environments.Ptr := Rec_Env; + First : Mal_Type; + begin + <> + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + Ast := Ast.L.Element (3); + goto Restart; + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + begin + Env.Replace_With_Subenv; + Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + case First.Kind is + when Kind_Native => + return First.Native.all (Args); + when Kind_Function => + Env := Environments.Alloc (Outer => First.Environment); + Env.Set_Binds (First.Formals, Args); + Ast := First.Expression.Deref; + goto Restart; + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + ---------------------------------------------------------------------- + + use Types; + Argv : Mal_Type (Kind_List); + Repl : constant Environments.Ptr := Environments.Alloc; + function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is + (Eval (Args (Args'First), Repl)); +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, + Eval_Native'Unrestricted_Access)); + + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + Discard (Eval (Read ("(def! load-file (fn* (f) " + & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); + + if Ada.Command_Line.Argument_Count = 0 then + Repl.Set (Names.Argv, Argv); + Interactive_Loop (Repl); + else + Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); + for I in 2 .. Ada.Command_Line.Argument_Count loop + Argv.L.Replace_Element (I - 1, + Mal_Type'(Kind_String, Atoms.No_Element, + Strings.Alloc (Ada.Command_Line.Argument (I)))); + end loop; + Repl.Set (Names.Argv, Argv); + Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) + & """)"), Repl)); + end if; +end Step6_File; diff --git a/ada2/step7_quote.adb b/ada2/step7_quote.adb new file mode 100644 index 0000000000..9286169aee --- /dev/null +++ b/ada2/step7_quote.adb @@ -0,0 +1,326 @@ +with Ada.Containers.Vectors; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; use type Types.Kind_Type; + +procedure Step7_Quote is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + with Inline; + -- Handle vectors and lists not starting with unquote. + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + -- Eval, with a profile compatible with Native_Function_Access. + function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + + package Mal_Type_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Types.Mal_Type, + "=" => Types."="); + + ---------------------------------------------------------------------- + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + Ast : Types.Mal_Type := Rec_Ast; + Env : Environments.Ptr := Rec_Env; + First : Mal_Type; + begin + <> + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + Ast := Ast.L.Element (3); + goto Restart; + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + begin + Env.Replace_With_Subenv; + Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + + elsif First.S = Names.Quote then + pragma Assert (Ast.L.Length = 2); + return Ast.L.Element (2); + + elsif First.S = Names.Quasiquote then + pragma Assert (Ast.L.Length = 2); + return Quasiquote (Ast.L.Element (2), Env); + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + case First.Kind is + when Kind_Native => + return First.Native.all (Args); + when Kind_Function => + Env := Environments.Alloc (Outer => First.Environment); + Env.Set_Binds (First.Formals, Args); + Ast := First.Expression.Deref; + goto Restart; + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type + is (case Ast.Kind is + when Types.Kind_Vector => + (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Types.Kind_List => + (if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Types.Kind_Symbol + and then Ast.L.Element (1).S = Names.Unquote + then Eval (Ast.L.Element (2), Env) + else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + when others => Ast); + + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + is + use Types; + Buffer : Mal_Type_Vectors.Vector; + Elt : Mal_Type; + begin + for I in 1 .. List.Length loop + Elt := List.Element (I); + if Elt.Kind in Kind_List | Kind_Vector + and then 0 < Elt.L.Length + and then Elt.L.Element (1).Kind = Kind_Symbol + and then Elt.L.Element (1).S = Names.Splice_Unquote + then + pragma Assert (Elt.L.Length = 2); + Elt := Eval (Elt.L.Element (2), Env); + pragma Assert (Elt.Kind = Kind_List); + for J in 1 .. Elt.L.Length loop + Buffer.Append (Elt.L.Element (J)); + end loop; + else + Buffer.Append (Quasiquote (Elt, Env)); + end if; + end loop; + return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do + for I in 1 .. R.Length loop + R.Replace_Element (I, Buffer.Element (I)); + end loop; + end return; + end Quasiquote; + + ---------------------------------------------------------------------- + + use Types; + Argv : Mal_Type (Kind_List); + Repl : constant Environments.Ptr := Environments.Alloc; + function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is + (Eval (Args (Args'First), Repl)); +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, + Eval_Native'Unrestricted_Access)); + + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + Discard (Eval (Read ("(def! load-file (fn* (f) " + & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); + + if Ada.Command_Line.Argument_Count = 0 then + Repl.Set (Names.Argv, Argv); + Interactive_Loop (Repl); + else + Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); + for I in 2 .. Ada.Command_Line.Argument_Count loop + Argv.L.Replace_Element (I - 1, + Mal_Type'(Kind_String, Atoms.No_Element, + Strings.Alloc (Ada.Command_Line.Argument (I)))); + end loop; + Repl.Set (Names.Argv, Argv); + Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) + & """)"), Repl)); + end if; +end Step7_Quote; diff --git a/ada2/step8_macros.adb b/ada2/step8_macros.adb new file mode 100644 index 0000000000..c85b0a3222 --- /dev/null +++ b/ada2/step8_macros.adb @@ -0,0 +1,383 @@ +with Ada.Containers.Vectors; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; use type Types.Kind_Type; + +procedure Step8_Macros is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + with Inline; + -- Handle vectors and lists not starting with unquote. + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + -- Eval, with a profile compatible with Native_Function_Access. + function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + + package Mal_Type_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Types.Mal_Type, + "=" => Types."="); + + ---------------------------------------------------------------------- + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + Ast : Types.Mal_Type := Rec_Ast; + Env : Environments.Ptr := Rec_Env; + Macroexpanding : Boolean := False; + First : Mal_Type; + begin + <> + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Defmacro then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + F : constant Mal_Type := Eval (Ast.L.Element (3), Env); + pragma Assert (F.Kind = Kind_Function); + begin + return R : constant Mal_Type + := (Kind => Kind_Macro, + Meta => Atoms.No_Element, + Mac_Formals => F.Formals, + Mac_Expression => F.Expression) + do + Env.Set (Ast.L.Element (2).S, R); + end return; + end; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + Ast := Ast.L.Element (3); + goto Restart; + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + begin + Env.Replace_With_Subenv; + Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + + elsif First.S = Names.Macroexpand then + pragma Assert (Ast.L.Length = 2); + Macroexpanding := True; + Ast := Ast.L.Element (2); + goto Restart; + + elsif First.S = Names.Quote then + pragma Assert (Ast.L.Length = 2); + return Ast.L.Element (2); + + elsif First.S = Names.Quasiquote then + pragma Assert (Ast.L.Length = 2); + return Quasiquote (Ast.L.Element (2), Env); + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + case First.Kind is + + when Kind_Native => + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Native.all (Args); + + when Kind_Function => + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + Env := Environments.Alloc (Outer => First.Environment); + Env.Set_Binds (First.Formals, Args); + Ast := First.Expression.Deref; + goto Restart; + + when Kind_Macro => + for I in Args'Range loop + Args (I) := Ast.L.Element (I); + end loop; + declare + New_Env : constant Environments.Ptr + := Environments.Alloc (Outer => Env); + begin + New_Env.Set_Binds (First.Mac_Formals, Args); + Ast := Eval (First.Mac_Expression.Deref, New_Env); + end; + if Macroexpanding then + return Ast; + end if; + goto Restart; + + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type + is (case Ast.Kind is + when Types.Kind_Vector => + (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Types.Kind_List => + (if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Types.Kind_Symbol + and then Ast.L.Element (1).S = Names.Unquote + then Eval (Ast.L.Element (2), Env) + else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + when others => Ast); + + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + is + use Types; + Buffer : Mal_Type_Vectors.Vector; + Elt : Mal_Type; + begin + for I in 1 .. List.Length loop + Elt := List.Element (I); + if Elt.Kind in Kind_List | Kind_Vector + and then 0 < Elt.L.Length + and then Elt.L.Element (1).Kind = Kind_Symbol + and then Elt.L.Element (1).S = Names.Splice_Unquote + then + pragma Assert (Elt.L.Length = 2); + Elt := Eval (Elt.L.Element (2), Env); + pragma Assert (Elt.Kind = Kind_List); + for J in 1 .. Elt.L.Length loop + Buffer.Append (Elt.L.Element (J)); + end loop; + else + Buffer.Append (Quasiquote (Elt, Env)); + end if; + end loop; + return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do + for I in 1 .. R.Length loop + R.Replace_Element (I, Buffer.Element (I)); + end loop; + end return; + end Quasiquote; + + ---------------------------------------------------------------------- + + use Types; + Argv : Mal_Type (Kind_List); + Repl : constant Environments.Ptr := Environments.Alloc; + function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is + (Eval (Args (Args'First), Repl)); +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, + Eval_Native'Unrestricted_Access)); + + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + Discard (Eval (Read ("(def! load-file (fn* (f) " + & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); + Discard (Eval (Read ("(defmacro! cond " + & "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) " + & "(if (> (count xs) 1) (nth xs 1) " + & "(throw ""odd number of forms to cond"")) " + & "(cons 'cond (rest (rest xs)))))))"), Repl)); + Discard (Eval (Read ("(defmacro! or (fn* (& xs) " + & "(if (empty? xs) nil " + & "(if (= 1 (count xs)) (first xs) " + & "`(let* (or_FIXME ~(first xs)) " + & "(if or_FIXME or_FIXME " + & "(or ~@(rest xs))))))))"), Repl)); + + if Ada.Command_Line.Argument_Count = 0 then + Repl.Set (Names.Argv, Argv); + Interactive_Loop (Repl); + else + Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); + for I in 2 .. Ada.Command_Line.Argument_Count loop + Argv.L.Replace_Element (I - 1, + Mal_Type'(Kind_String, Atoms.No_Element, + Strings.Alloc (Ada.Command_Line.Argument (I)))); + end loop; + Repl.Set (Names.Argv, Argv); + Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) + & """)"), Repl)); + end if; +end Step8_Macros; diff --git a/ada2/step9_try.adb b/ada2/step9_try.adb new file mode 100644 index 0000000000..6651b5ba30 --- /dev/null +++ b/ada2/step9_try.adb @@ -0,0 +1,411 @@ +with Ada.Containers.Vectors; +with Ada.Command_Line; +with Ada.Exceptions; use type Ada.Exceptions.Exception_Id; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; use type Types.Kind_Type; + +procedure Step9_Try is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + with Inline; + -- Handle vectors and lists not starting with unquote. + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + -- Eval, with a profile compatible with Native_Function_Access. + function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + + package Mal_Type_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Types.Mal_Type, + "=" => Types."="); + + ---------------------------------------------------------------------- + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + Ast : Types.Mal_Type := Rec_Ast; + Env : Environments.Ptr := Rec_Env; + Macroexpanding : Boolean := False; + First : Mal_Type; + begin + <> + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Defmacro then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + F : constant Mal_Type := Eval (Ast.L.Element (3), Env); + pragma Assert (F.Kind = Kind_Function); + begin + return R : constant Mal_Type + := (Kind => Kind_Macro, + Meta => Atoms.No_Element, + Mac_Formals => F.Formals, + Mac_Expression => F.Expression) + do + Env.Set (Ast.L.Element (2).S, R); + end return; + end; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + Ast := Ast.L.Element (3); + goto Restart; + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + begin + Env.Replace_With_Subenv; + Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + + elsif First.S = Names.Macroexpand then + pragma Assert (Ast.L.Length = 2); + Macroexpanding := True; + Ast := Ast.L.Element (2); + goto Restart; + + elsif First.S = Names.Quote then + pragma Assert (Ast.L.Length = 2); + return Ast.L.Element (2); + + elsif First.S = Names.Quasiquote then + pragma Assert (Ast.L.Length = 2); + return Quasiquote (Ast.L.Element (2), Env); + + elsif First.S = Names.Try then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (3).Kind = Kind_List); + A3 : constant Lists.Ptr := Ast.L.Element (3).L; + pragma Assert (A3.Length = 3); + pragma Assert (A3.Element (1).Kind = Kind_Symbol); + pragma Assert (A3.Element (1).S = Names.Catch); + pragma Assert (A3.Element (2).Kind = Kind_Symbol); + begin + return Eval (Ast.L.Element (2), Env); + exception + when E : others => + Env.Replace_With_Subenv; + if Ada.Exceptions.Exception_Identity (E) + = Core.Exception_Throwed'Identity + then + Env.Set (A3.Element (2).S, Core.Last_Exception); + Core.Last_Exception := (Kind_Nil, Atoms.No_Element); + else + Env.Set (A3.Element (2).S, Mal_Type' + (Kind_String, Atoms.No_Element, Strings.Alloc + (Ada.Exceptions.Exception_Message (E)))); + end if; + Ast := A3.Element (3); + goto Restart; + end; + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + case First.Kind is + + when Kind_Native => + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Native.all (Args); + + when Kind_Function => + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + Env := Environments.Alloc (Outer => First.Environment); + Env.Set_Binds (First.Formals, Args); + Ast := First.Expression.Deref; + goto Restart; + + when Kind_Macro => + for I in Args'Range loop + Args (I) := Ast.L.Element (I); + end loop; + declare + New_Env : constant Environments.Ptr + := Environments.Alloc (Outer => Env); + begin + New_Env.Set_Binds (First.Mac_Formals, Args); + Ast := Eval (First.Mac_Expression.Deref, New_Env); + end; + if Macroexpanding then + return Ast; + end if; + goto Restart; + + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type + is (case Ast.Kind is + when Types.Kind_Vector => + (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Types.Kind_List => + (if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Types.Kind_Symbol + and then Ast.L.Element (1).S = Names.Unquote + then Eval (Ast.L.Element (2), Env) + else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + when others => Ast); + + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + is + use Types; + Buffer : Mal_Type_Vectors.Vector; + Elt : Mal_Type; + begin + for I in 1 .. List.Length loop + Elt := List.Element (I); + if Elt.Kind in Kind_List | Kind_Vector + and then 0 < Elt.L.Length + and then Elt.L.Element (1).Kind = Kind_Symbol + and then Elt.L.Element (1).S = Names.Splice_Unquote + then + pragma Assert (Elt.L.Length = 2); + Elt := Eval (Elt.L.Element (2), Env); + pragma Assert (Elt.Kind = Kind_List); + for J in 1 .. Elt.L.Length loop + Buffer.Append (Elt.L.Element (J)); + end loop; + else + Buffer.Append (Quasiquote (Elt, Env)); + end if; + end loop; + return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do + for I in 1 .. R.Length loop + R.Replace_Element (I, Buffer.Element (I)); + end loop; + end return; + end Quasiquote; + + ---------------------------------------------------------------------- + + use Types; + Argv : Mal_Type (Kind_List); + Repl : constant Environments.Ptr := Environments.Alloc; + function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is + (Eval (Args (Args'First), Repl)); +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, + Eval_Native'Unrestricted_Access)); + + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + Discard (Eval (Read ("(def! load-file (fn* (f) " + & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); + Discard (Eval (Read ("(defmacro! cond " + & "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) " + & "(if (> (count xs) 1) (nth xs 1) " + & "(throw ""odd number of forms to cond"")) " + & "(cons 'cond (rest (rest xs)))))))"), Repl)); + Discard (Eval (Read ("(defmacro! or (fn* (& xs) " + & "(if (empty? xs) nil " + & "(if (= 1 (count xs)) (first xs) " + & "`(let* (or_FIXME ~(first xs)) " + & "(if or_FIXME or_FIXME " + & "(or ~@(rest xs))))))))"), Repl)); + + if Ada.Command_Line.Argument_Count = 0 then + Repl.Set (Names.Argv, Argv); + Interactive_Loop (Repl); + else + Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); + for I in 2 .. Ada.Command_Line.Argument_Count loop + Argv.L.Replace_Element (I - 1, + Mal_Type'(Kind_String, Atoms.No_Element, + Strings.Alloc (Ada.Command_Line.Argument (I)))); + end loop; + Repl.Set (Names.Argv, Argv); + Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) + & """)"), Repl)); + end if; +end Step9_Try; diff --git a/ada2/stepa_mal.adb b/ada2/stepa_mal.adb new file mode 100644 index 0000000000..a695b6e52e --- /dev/null +++ b/ada2/stepa_mal.adb @@ -0,0 +1,417 @@ +with Ada.Containers.Vectors; +with Ada.Command_Line; +with Ada.Exceptions; use type Ada.Exceptions.Exception_Id; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; +with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Atoms; +with Core; +with Environments; +with Lists; +with Names; +with Printer; +with Reader; +with Strings; use type Strings.Ptr; +with Types; use type Types.Kind_Type; + +procedure StepA_Mal is + + function Read (Source : in String) return Types.Mal_Type + renames Reader.Read_Str; + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type; + Unable_To_Call : exception; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + with Inline; + -- Handle vectors and lists not starting with unquote. + + function Print (Ast : in Types.Mal_Type; + Print_Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + renames Printer.Pr_Str; + + function Rep (Source : in String; + Env : in Environments.Ptr) + return Ada.Strings.Unbounded.Unbounded_String + is (Print (Eval (Read (Source), Env))) + with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + with Inline; + + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Types.Mal_Type) is null; + + -- Eval, with a profile compatible with Native_Function_Access. + function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + + package Mal_Type_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Types.Mal_Type, + "=" => Types."="); + + ---------------------------------------------------------------------- + + function Eval (Rec_Ast : in Types.Mal_Type; + Rec_Env : in Environments.Ptr) return Types.Mal_Type + is + use Types; + Ast : Types.Mal_Type := Rec_Ast; + Env : Environments.Ptr := Rec_Env; + Macroexpanding : Boolean := False; + First : Mal_Type; + begin + <> + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => + return Ast; + + when Kind_Symbol => + return Env.Get (Ast.S); + + when Kind_Map => + declare + function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); + begin + return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); + end; + + when Kind_Vector => + return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, + Lists.Alloc (Ast.L.Length)) + do + for I in 1 .. Ast.L.Length loop + R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); + end loop; + end return; + + when Kind_List => + if Ast.L.Length = 0 then + return Ast; + end if; + + First := Ast.L.Element (1); + + -- Special forms + if First.Kind = Kind_Symbol then + + if First.S = Names.Def then + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).S, R); + end return; + + elsif First.S = Names.Defmacro then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); + F : constant Mal_Type := Eval (Ast.L.Element (3), Env); + pragma Assert (F.Kind = Kind_Function); + begin + return R : constant Mal_Type + := (Kind => Kind_Macro, + Meta => Atoms.No_Element, + Mac_Formals => F.Formals, + Mac_Expression => F.Expression) + do + Env.Set (Ast.L.Element (2).S, R); + end return; + end; + + elsif First.S = Names.Mal_Do then + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + + elsif First.S = Names.Fn then + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); + pragma Assert + (Ast.L.Element (2).L.Length < 1 + or else Names.Ampersand /= + Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); + pragma Assert + (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => + Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); + return (Kind => Kind_Function, + Meta => Atoms.No_Element, + Formals => Ast.L.Element (2).L, + Expression => Atoms.Alloc (Ast.L.Element (3)), + Environment => Env); + + elsif First.S = Names.Mal_If then + declare + pragma Assert (Ast.L.Length in 3 .. 4); + Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Boolean_Value, + when others => True) + then + Ast := Ast.L.Element (3); + goto Restart; + elsif Ast.L.Length = 3 then + return (Kind_Nil, Atoms.No_Element); + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + + elsif First.S = Names.Let then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert + (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + pragma Assert (Bindings.Length mod 2 = 0); + begin + Env.Replace_With_Subenv; + Env.Increase_Capacity (Bindings.Length / 2); + for I in 1 .. Bindings.Length / 2 loop + pragma Assert + (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); + Env.Set (Bindings.Element (2 * I - 1).S, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + + elsif First.S = Names.Macroexpand then + pragma Assert (Ast.L.Length = 2); + Macroexpanding := True; + Ast := Ast.L.Element (2); + goto Restart; + + elsif First.S = Names.Quote then + pragma Assert (Ast.L.Length = 2); + return Ast.L.Element (2); + + elsif First.S = Names.Quasiquote then + pragma Assert (Ast.L.Length = 2); + return Quasiquote (Ast.L.Element (2), Env); + + elsif First.S = Names.Try then + declare + pragma Assert (Ast.L.Length = 3); + pragma Assert (Ast.L.Element (3).Kind = Kind_List); + A3 : constant Lists.Ptr := Ast.L.Element (3).L; + pragma Assert (A3.Length = 3); + pragma Assert (A3.Element (1).Kind = Kind_Symbol); + pragma Assert (A3.Element (1).S = Names.Catch); + pragma Assert (A3.Element (2).Kind = Kind_Symbol); + begin + return Eval (Ast.L.Element (2), Env); + exception + when E : others => + Env.Replace_With_Subenv; + if Ada.Exceptions.Exception_Identity (E) + = Core.Exception_Throwed'Identity + then + Env.Set (A3.Element (2).S, Core.Last_Exception); + Core.Last_Exception := (Kind_Nil, Atoms.No_Element); + else + Env.Set (A3.Element (2).S, Mal_Type' + (Kind_String, Atoms.No_Element, Strings.Alloc + (Ada.Exceptions.Exception_Message (E)))); + end if; + Ast := A3.Element (3); + goto Restart; + end; + end if; + end if; + + -- No special form has been found, attempt to apply the + -- first element to the rest of the list. + declare + Args : Mal_Type_Array (2 .. Ast.L.Length); + begin + First := Eval (First, Env); + case First.Kind is + + when Kind_Native => + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Native.all (Args); + + when Kind_Function => + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + Env := Environments.Alloc (Outer => First.Environment); + Env.Set_Binds (First.Formals, Args); + Ast := First.Expression.Deref; + goto Restart; + + when Kind_Macro => + for I in Args'Range loop + Args (I) := Ast.L.Element (I); + end loop; + declare + New_Env : constant Environments.Ptr + := Environments.Alloc (Outer => Env); + begin + New_Env.Set_Binds (First.Mac_Formals, Args); + Ast := Eval (First.Mac_Expression.Deref, New_Env); + end; + if Macroexpanding then + return Ast; + end if; + goto Restart; + + when others => + raise Unable_To_Call + with Ada.Strings.Unbounded.To_String (Print (First)); + end case; + end; + end case; + end Eval; + + procedure Interactive_Loop (Repl : in Environments.Ptr) + is + + function Readline (Prompt : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + with Import, Convention => C, External_Name => "free"; + + Prompt : constant Interfaces.C.char_array + := Interfaces.C.To_C ("user> "); + C_Line : Interfaces.C.Strings.chars_ptr; + begin + loop + C_Line := Readline (Prompt); + exit when C_Line = Interfaces.C.Strings.Null_Ptr; + declare + Line : constant String := Interfaces.C.Strings.Value (C_Line); + begin + if Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); + exception + when Reader.Empty_Source => + null; + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- but go on proceeding. + end; + end loop; + Ada.Text_IO.New_Line; + end Interactive_Loop; + + function Quasiquote (Ast : in Types.Mal_Type; + Env : in Environments.Ptr) return Types.Mal_Type + is (case Ast.Kind is + when Types.Kind_Vector => + (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Types.Kind_List => + (if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Types.Kind_Symbol + and then Ast.L.Element (1).S = Names.Unquote + then Eval (Ast.L.Element (2), Env) + else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + when others => Ast); + + function Quasiquote (List : in Lists.Ptr; + Env : in Environments.Ptr) return Lists.Ptr + is + use Types; + Buffer : Mal_Type_Vectors.Vector; + Elt : Mal_Type; + begin + for I in 1 .. List.Length loop + Elt := List.Element (I); + if Elt.Kind in Kind_List | Kind_Vector + and then 0 < Elt.L.Length + and then Elt.L.Element (1).Kind = Kind_Symbol + and then Elt.L.Element (1).S = Names.Splice_Unquote + then + pragma Assert (Elt.L.Length = 2); + Elt := Eval (Elt.L.Element (2), Env); + pragma Assert (Elt.Kind = Kind_List); + for J in 1 .. Elt.L.Length loop + Buffer.Append (Elt.L.Element (J)); + end loop; + else + Buffer.Append (Quasiquote (Elt, Env)); + end if; + end loop; + return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do + for I in 1 .. R.Length loop + R.Replace_Element (I, Buffer.Element (I)); + end loop; + end return; + end Quasiquote; + + ---------------------------------------------------------------------- + + use Types; + Argv : Mal_Type (Kind_List); + Repl : constant Environments.Ptr := Environments.Alloc; + function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is + (Eval (Args (Args'First), Repl)); +begin + Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); + Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, + Eval_Native'Unrestricted_Access)); + + Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); + Discard (Eval (Read ("(def! load-file (fn* (f) " + & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); + Discard (Eval (Read ("(defmacro! cond " + & "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) " + & "(if (> (count xs) 1) (nth xs 1) " + & "(throw ""odd number of forms to cond"")) " + & "(cons 'cond (rest (rest xs)))))))"), Repl)); + Discard (Eval (Read ("(def! *gensym-counter* (atom 0))"), Repl)); + Discard (Eval (Read ("(def! gensym (fn* [] (symbol (str ""G__"" " + & "(swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"), Repl)); + Discard (Eval (Read ("(defmacro! or (fn* (& xs) (if (empty? xs) nil " + & "(if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) " + & "`(let* (~condvar ~(first xs)) (if ~condvar ~condvar " + & "(or ~@(rest xs)))))))))"), Repl)); + + Repl.Set (Names.Host_Language, + Mal_Type'(Kind_Symbol, Atoms.No_Element, Names.Ada2)); + + if Ada.Command_Line.Argument_Count = 0 then + Repl.Set (Names.Argv, Argv); + Discard (Eval (Read ("(println (str ""Mal ["" *host-language* ""]""))"), + Repl)); + Interactive_Loop (Repl); + else + Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); + for I in 2 .. Ada.Command_Line.Argument_Count loop + Argv.L.Replace_Element (I - 1, + Mal_Type'(Kind_String, Atoms.No_Element, + Strings.Alloc (Ada.Command_Line.Argument (I)))); + end loop; + Repl.Set (Names.Argv, Argv); + Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) + & """)"), Repl)); + end if; +end StepA_Mal; diff --git a/ada2/strings.adb b/ada2/strings.adb new file mode 100644 index 0000000000..6cee7acf03 --- /dev/null +++ b/ada2/strings.adb @@ -0,0 +1,62 @@ +with Ada.Strings.Hash; + +package body Strings is + + Dict : Sets.Set; + Empty_Hash : constant Ada.Containers.Hash_Type := Ada.Strings.Hash (""); + + ---------------------------------------------------------------------- + + procedure Adjust (Object : in out Ptr) is + begin + if Sets.Has_Element (Object.Position) then + Dict (Object.Position).Refs := Dict (Object.Position).Refs + 1; + end if; + end Adjust; + + function Alloc (Source : in String) return Ptr + is + Inserted : Boolean; + Position : Sets.Cursor; + begin + if Source /= "" then + Sets.Insert (Dict, + (Data => Source, + Hash => Ada.Strings.Hash (Source), + Last => Source'Length, + Refs => 1), + Position, + Inserted); + if not Inserted then + Dict (Position).Refs := Dict (Position).Refs + 1; + end if; + end if; + return (Ada.Finalization.Controlled with Position => Position); + end Alloc; + + function Deref (Source : in Ptr) return String is + (if Sets.Has_Element (Source.Position) + then Dict (Source.Position).Data + else ""); + + procedure Finalize (Object : in out Ptr) + is + Refs : Positive; + begin + if Sets.Has_Element (Object.Position) then + Refs := Dict (Object.Position).Refs; + if 1 < Refs then + Dict (Object.Position).Refs := Refs - 1; + Object.Position := Sets.No_Element; + else + Sets.Delete (Dict, Object.Position); + end if; + end if; + end Finalize; + + function Hash (Source : in Ptr) return Ada.Containers.Hash_Type is + (if Sets.Has_Element (Source.Position) + then Dict (Source.Position).Hash + else Empty_Hash); + +end Strings; diff --git a/ada2/strings.ads b/ada2/strings.ads new file mode 100644 index 0000000000..aeb8222725 --- /dev/null +++ b/ada2/strings.ads @@ -0,0 +1,65 @@ +with Ada.Containers; +private with Ada.Containers.Indefinite_Hashed_Sets; +private with Ada.Finalization; + +package Strings is + + pragma Elaborate_Body; + + -- An abstraction similar to Ada.Strings.Unbounded, except that + -- the type is immutable, and that only one instance is allocated + -- with a given content. This avoids many allocations and + -- deallocations, since symbols and keywords are expected to be + -- used many times. Using this for all strings even if they are + -- not used as keys in maps should not hurt. + + -- As a side effect, some frequent string comparisons (with "def!" + -- or "fn*" for example) will become a bit more efficient because + -- comparing pointers is faster than comparing strings. + + type Ptr is tagged private; + Empty_String : constant Ptr; -- The default value. + + function Alloc (Source : in String) return Ptr; + + function Deref (Source : in Ptr) return String + with Inline; + + -- We make the hash value visible so that environments and maps do + -- not need to recompute it. + function Hash (Source : in Ptr) return Ada.Containers.Hash_Type + with Inline; + +private + + type Element_Type (Last : Positive) is record + Data : String (1 .. Last); + Hash : Ada.Containers.Hash_Type; + Refs : Positive; + end record; + + function Hash (Element : Element_Type) return Ada.Containers.Hash_Type + is (Element.Hash) + with Inline; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean + is (Left.Data = Right.Data) + with Inline; + + package Sets is new Ada.Containers.Indefinite_Hashed_Sets + (Element_Type => Element_Type, + Hash => Hash, + Equivalent_Elements => Equivalent_Elements, + "=" => "="); + + type Ptr is new Ada.Finalization.Controlled with record + Position : Sets.Cursor := Sets.No_Element; + end record; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + -- Predefined equality is fine. + + Empty_String : constant Ptr + := (Ada.Finalization.Controlled with Position => Sets.No_Element); + +end Strings; diff --git a/ada2/types.adb b/ada2/types.adb new file mode 100644 index 0000000000..d87297f3c8 --- /dev/null +++ b/ada2/types.adb @@ -0,0 +1,37 @@ +package body Types is + + function "=" (Left, Right : in Mal_Type) return Boolean is + (case Left.Kind is + when Kind_Nil => + Right.Kind = Kind_Nil, + when Kind_Atom => + Right.Kind = Kind_Atom + and then Atoms."=" (Left.Reference, Right.Reference), + when Kind_Boolean => + Right.Kind = Kind_Boolean + and then Left.Boolean_Value = Right.Boolean_Value, + when Kind_Number => + Right.Kind = Kind_Number + and then Left.Integer_Value = Right.Integer_Value, + when Kind_String | Kind_Keyword | Kind_Symbol => + Right.Kind = Left.Kind + and then Strings."=" (Left.S, Right.S), + when Kind_List | Kind_Vector => + Right.Kind in Kind_List | Kind_Vector + and then Lists."=" (Left.L, Right.L), + when Kind_Map => + Right.Kind = Kind_Map + and then Maps."=" (Left.Map, Right.Map), + when Kind_Function => + Right.Kind = Kind_Function + and then Lists."=" (Left.Formals, Right.Formals) + and then Atoms."=" (Left.Expression, Right.Expression) + and then Environments."=" (Left.Environment, Right.Environment), + when Kind_Native => + Right.Kind = Kind_Native and then Left.Native = Right.Native, + when Kind_Macro => + Right.Kind = Kind_Macro + and then Atoms."=" (Left.Mac_Expression, Right.Mac_Expression) + and then Lists."=" (Left.Mac_Formals, Right.Mac_Formals)); + +end Types; diff --git a/ada2/types.ads b/ada2/types.ads new file mode 100644 index 0000000000..24c4d51e03 --- /dev/null +++ b/ada2/types.ads @@ -0,0 +1,59 @@ +with Atoms; +with Environments; +with Lists; +with Maps; +with Strings; + +package Types is + + type Mal_Type; + type Mal_Type_Array; + type Native_Function_Access is not null access + function (Arguments : in Mal_Type_Array) return Mal_Type; + + -- Make similar kinds consecutive for efficient case statements. + type Kind_Type is + (Kind_Nil, + Kind_Atom, + Kind_Boolean, + Kind_Number, + Kind_String, Kind_Symbol, Kind_Keyword, + Kind_List, Kind_Vector, + Kind_Map, + Kind_Macro, Kind_Function, Kind_Native); + + type Mal_Type (Kind : Kind_Type := Kind_Nil) is record + Meta : Atoms.Ptr; + case Kind is + when Kind_Nil => + null; + when Kind_Boolean => + Boolean_Value : Boolean; + when Kind_Number => + Integer_Value : Integer; + when Kind_Atom => + Reference : Atoms.Ptr; + when Kind_String | Kind_Keyword | Kind_Symbol => + S : Strings.Ptr; + when Kind_List | Kind_Vector => + L : Lists.Ptr; + when Kind_Map => + Map : Maps.Ptr; + when Kind_Native => + Native : Native_Function_Access; + when Kind_Function => + Formals : Lists.Ptr; + Expression : Atoms.Ptr; + Environment : Environments.Ptr; + when Kind_Macro => + Mac_Formals : Lists.Ptr; + Mac_Expression : Atoms.Ptr; + end case; + end record; + + function "=" (Left, Right : in Mal_Type) return Boolean; + -- By default, a list /= a vector. + + type Mal_Type_Array is array (Positive range <>) of Types.Mal_Type; + +end Types; From daffc668e924daa703d83279adda4196cb1ce6ed Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Wed, 27 Feb 2019 22:27:12 +0100 Subject: [PATCH 0485/1998] Major rewrite, improving style and improving performances. --- ada2/Makefile | 59 ++- ada2/README | 42 ++ ada2/atoms.adb | 52 -- ada2/atoms.ads | 36 -- ada2/core.adb | 917 ++++++++++++++++------------------- ada2/core.ads | 22 +- ada2/environments.adb | 430 +++++++++++----- ada2/environments.ads | 137 ++++-- ada2/lists.adb | 95 ---- ada2/lists.ads | 47 -- ada2/maps.adb | 160 ------ ada2/maps.ads | 59 --- ada2/names.ads | 87 ---- ada2/printer.adb | 171 +++---- ada2/printer.ads | 9 +- ada2/reader.adb | 140 +++--- ada2/reader.ads | 8 +- ada2/step0_repl.adb | 47 +- ada2/step1_read_print.adb | 56 +-- ada2/step2_eval.adb | 166 +++---- ada2/step3_env.adb | 237 +++++---- ada2/step4_if_fn_do.adb | 324 ++++++------- ada2/step5_tco.adb | 330 +++++++------ ada2/step6_file.adb | 366 +++++++------- ada2/step7_quote.adb | 459 +++++++++--------- ada2/step8_macros.adb | 544 ++++++++++----------- ada2/step9_try.adb | 607 ++++++++++++----------- ada2/stepa_mal.adb | 621 ++++++++++++------------ ada2/strings.adb | 62 --- ada2/strings.ads | 65 --- ada2/types-atoms.adb | 62 +++ ada2/types-atoms.ads | 35 ++ ada2/types-builtins.adb | 53 ++ ada2/types-builtins.ads | 46 ++ ada2/types-functions.adb | 171 +++++++ ada2/types-functions.ads | 67 +++ ada2/types-lists.adb | 260 ++++++++++ ada2/types-lists.ads | 83 ++++ ada2/types-mal.adb | 31 ++ ada2/types-mal.ads | 84 ++++ ada2/types-maps.adb | 266 ++++++++++ ada2/types-maps.ads | 68 +++ ada2/types-symbols-names.ads | 31 ++ ada2/types-symbols.adb | 90 ++++ ada2/types-symbols.ads | 59 +++ ada2/types.adb | 37 -- ada2/types.ads | 55 +-- 47 files changed, 4261 insertions(+), 3592 deletions(-) create mode 100644 ada2/README delete mode 100644 ada2/atoms.adb delete mode 100644 ada2/atoms.ads delete mode 100644 ada2/lists.adb delete mode 100644 ada2/lists.ads delete mode 100644 ada2/maps.adb delete mode 100644 ada2/maps.ads delete mode 100644 ada2/names.ads delete mode 100644 ada2/strings.adb delete mode 100644 ada2/strings.ads create mode 100644 ada2/types-atoms.adb create mode 100644 ada2/types-atoms.ads create mode 100644 ada2/types-builtins.adb create mode 100644 ada2/types-builtins.ads create mode 100644 ada2/types-functions.adb create mode 100644 ada2/types-functions.ads create mode 100644 ada2/types-lists.adb create mode 100644 ada2/types-lists.ads create mode 100644 ada2/types-mal.adb create mode 100644 ada2/types-mal.ads create mode 100644 ada2/types-maps.adb create mode 100644 ada2/types-maps.ads create mode 100644 ada2/types-symbols-names.ads create mode 100644 ada2/types-symbols.adb create mode 100644 ada2/types-symbols.ads delete mode 100644 ada2/types.adb diff --git a/ada2/Makefile b/ada2/Makefile index bb58c83206..a74b81ff2d 100644 --- a/ada2/Makefile +++ b/ada2/Makefile @@ -1,23 +1,16 @@ -# Variables expected on the command line: -OPT := -O2 -GNATN := -gnatn -GNATP := -gnatp -ADAFLAGS := -LDFLAGS := -DEBUG := - ifdef DEBUG - # Some warnings require -O1. - OPT := -O1 - GNATN := - GNATP := ADAFLAGS := -Wall -Wextra -gnatw.eH.Y -gnatySdouxy -gnatVa -g -gnataEfoqQ \ -fstack-check -pg LDFLAGS := -pg +else + # -O3 is not recommended as the default by the GCC documentation, + # and -O2 seems to produce slightly better performances. + # See README for a discussion of -gnatp. + ADAFLAGS := -O2 -gnatnp endif # Compiler arguments. -CARGS = -gnat2012 $(OPT) $(GNATN) $(GNATP) $(ADAFLAGS) +CARGS = -gnat2012 $(OPT) $(ADAFLAGS) # Linker arguments. LARGS = $(LDFLAGS) -lreadline @@ -42,15 +35,18 @@ clean: # Tell Make how to detect out-of-date executables, and let gnatmake do # the rest when it must be executed. TYPES := \ - atoms.ads atoms.adb \ - environments.ads environments.adb \ - lists.ads lists.adb \ - maps.ads maps.adb \ - names.ads \ - printer.ads printer.adb \ - reader.ads reader.adb \ - types.ads types.adb \ - strings.ads strings.adb + environments.ads environments.adb \ + printer.ads printer.adb \ + reader.ads reader.adb \ + types-atoms.ads types-atoms.adb \ + types-builtins.ads types-builtins.adb \ + types-functions.ads types-functions.adb \ + types-lists.ads types-lists.adb \ + types-mal.ads types-mal.adb \ + types-maps.ads types-maps.adb \ + types-symbols-names.ads \ + types-symbols.ads types-symbols.adb \ + types.ads CORE := \ core.ads core.adb @@ -61,11 +57,14 @@ $(stepa) : stepA%: stepa%.adb $(TYPES) $(CORE) $(steps) : gnatmake $< -o $@ -cargs $(CARGS) -largs $(LARGS) -# Step 8 freezes during the "(or)" test with -gnatp. -step8%: GNATP := - -# The compiler crashes on types.adb with -gnatn. -$(step13) $(step49) $(stepa): types.o -types.o: GNATN := -types.o: $(TYPES) - gcc -c $(CARGS) types.adb +.PHONY: steps.diff +steps.diff: + diff -u step1*.adb step2*.adb; \ + diff -u step2*.adb step3*.adb; \ + diff -u step3*.adb step4*.adb; \ + diff -u step4*.adb step5*.adb; \ + diff -u step5*.adb step6*.adb; \ + diff -u step6*.adb step7*.adb; \ + diff -u step7*.adb step8*.adb; \ + diff -u step8*.adb step9*.adb; \ + diff -u step9*.adb stepa*.adb || true diff --git a/ada2/README b/ada2/README new file mode 100644 index 0000000000..1593347ac3 --- /dev/null +++ b/ada2/README @@ -0,0 +1,42 @@ +Comparison with the first Ada implementation. + +The first implementation was deliberately compatible with all Ada +compilers, while this one illustrates various Ada 2012 features, like +assertions, preconditions, invariants, initial assignment for limited +types, limited imports... + +The variant MAL type is implemented with a discriminant instead of +object-style dispatching. This allows more static and dynamic checks, +but also two crucial performance improvements: +* Nil, boolean and integers are passed by value without dynamic + allocation. +* Lists are implemented as C-style arrays, and most of them can be + allocated on the stack. + +Once each component has an explicit interface, various optimizations +have been added: unique allocation of symbols, stack-style allocation +of environments in the current execution path, reuse of existing +memory when the reference count reaches 1... + +The eventual performances compete with C-style languages, allthough +all user input is checked (implicit language-defined checks like array +bounds and discriminant consistency are only enabled during tests). + +There are also similarities with the first implementation. For +example, both rely on user-defined finalization to handle recursive +structures without garbage collecting. + + +About reference reference counting. + +* The finalize procedure may be called twice, so it does nothing when + the reference count is zero, meaning that we are reaching Finalize + recursively. +* In implementations, a consistent object (that will be deallocated + automatically) must be built before any exception is raised by user + code (for example 'map' may run user functions). + + +Known bugs: the third step of the perf^ada2 target fails during the +final storage deallocation when the executable is built with -gnatp. I +have failed to understand why so far. diff --git a/ada2/atoms.adb b/ada2/atoms.adb deleted file mode 100644 index 24650a04d1..0000000000 --- a/ada2/atoms.adb +++ /dev/null @@ -1,52 +0,0 @@ -with Ada.Unchecked_Deallocation; -with Types; - -package body Atoms is - - type Atom_Record is limited record - Data : Types.Mal_Type; - Refs : Positive; - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Object => Atom_Record, - Name => Atom_Access); - - ---------------------------------------------------------------------- - - procedure Adjust (Object : in out Ptr) is - begin - if Object.Ref /= null then - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; - end if; - end Adjust; - - function Alloc (New_Value : in Types.Mal_Type) return Ptr - is (Ada.Finalization.Controlled with - Ref => new Atom_Record'(Data => New_Value, - Refs => 1)); - - function Deref (Container : in Ptr) return Types.Mal_Type is - (Container.Ref.all.Data); - - procedure Finalize (Object : in out Ptr) - is - Refs : Positive; - begin - if Object.Ref /= null then - Refs := Object.Ref.all.Refs; - if 1 < Refs then - Object.Ref.all.Refs := Refs - 1; - Object.Ref := null; - else - Free (Object.Ref); - end if; - end if; - end Finalize; - - procedure Set (Container : in Ptr; - New_Value : in Types.Mal_Type) is - begin - Container.Ref.all.Data := New_Value; - end Set; - -end Atoms; diff --git a/ada2/atoms.ads b/ada2/atoms.ads deleted file mode 100644 index 3fa5aae990..0000000000 --- a/ada2/atoms.ads +++ /dev/null @@ -1,36 +0,0 @@ -private with Ada.Finalization; -limited with Types; - -package Atoms is - - -- Equivalent to a Lists.Ptr with zero or one elements. - - type Ptr is tagged private; - No_Element : constant Ptr; - - function Alloc (New_Value : in Types.Mal_Type) return Ptr - with Inline; - - function Deref (Container : in Ptr) return Types.Mal_Type - with Inline, Pre => Container /= No_Element; - - procedure Set (Container : in Ptr; - New_Value : in Types.Mal_Type) - with Inline, Pre => Container /= No_Element; - -private - - type Atom_Record; - type Atom_Access is access Atom_Record; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Atom_Access := null; - end record; - overriding procedure Adjust (Object : in out Ptr) - with Inline; - overriding procedure Finalize (Object : in out Ptr) - with Inline; - -- Predefined equality is fine. - - No_Element : constant Ptr := (Ada.Finalization.Controlled with Ref => null); - -end Atoms; diff --git a/ada2/core.adb b/ada2/core.adb index aa8be989a0..5027457f7f 100644 --- a/ada2/core.adb +++ b/ada2/core.adb @@ -2,580 +2,477 @@ with Ada.Calendar; use type Ada.Calendar.Time; with Ada.Characters.Latin_1; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Atoms; use type Atoms.Ptr; -with Lists; -with Maps; -with Names; + +with Environments; +with Types.Atoms; +with Types.Builtins; +with Types.Functions; +with Types.Lists; +with Types.Maps; +with Types.Symbols.Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; package body Core is + package ASU renames Ada.Strings.Unbounded; use Types; + use Types.Lists; + use type Mal.T; + use type Mal.T_Array; Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; - Eval : Eval_Callback_Type; - - function Concatenation_Of_Pr_Str - (Args : in Mal_Type_Array; - Print_Readably : in Boolean := True; - Separator : in String := " ") - return Ada.Strings.Unbounded.Unbounded_String; - - function Apply (Args : in Mal_Type_Array) return Mal_Type; - function Assoc (Args : in Mal_Type_Array) return Mal_Type; - function Atom (Args : in Mal_Type_Array) return Mal_Type; - function Concat (Args : in Mal_Type_Array) return Mal_Type; - function Conj (Args : in Mal_Type_Array) return Mal_Type; - function Cons (Args : in Mal_Type_Array) return Mal_Type; - function Contains (Args : in Mal_Type_Array) return Mal_Type; - function Count (Args : in Mal_Type_Array) return Mal_Type; - function Deref (Args : in Mal_Type_Array) return Mal_Type; - function Dissoc (Args : in Mal_Type_Array) return Mal_Type; - function Equals (Args : in Mal_Type_Array) return Mal_Type; - function First (Args : in Mal_Type_Array) return Mal_Type; - function Get (Args : in Mal_Type_Array) return Mal_Type; - function Hash_Map (Args : in Mal_Type_Array) return Mal_Type; - function Is_Empty (Args : in Mal_Type_Array) return Mal_Type; - function Is_False (Args : in Mal_Type_Array) return Mal_Type; - function Is_Sequential (Args : in Mal_Type_Array) return Mal_Type; - function Is_True (Args : in Mal_Type_Array) return Mal_Type; - function Keys (Args : in Mal_Type_Array) return Mal_Type; - function Keyword (Args : in Mal_Type_Array) return Mal_Type; - function List (Args : in Mal_Type_Array) return Mal_Type; - function Map (Args : in Mal_Type_Array) return Mal_Type; - function Meta (Args : in Mal_Type_Array) return Mal_Type; - function Nth (Args : in Mal_Type_Array) return Mal_Type; - function Pr_Str (Args : in Mal_Type_Array) return Mal_Type; - function Println (Args : in Mal_Type_Array) return Mal_Type; - function Prn (Args : in Mal_Type_Array) return Mal_Type; - function Read_String (Args : in Mal_Type_Array) return Mal_Type; - function Readline (Args : in Mal_Type_Array) return Mal_Type; - function Reset (Args : in Mal_Type_Array) return Mal_Type; - function Rest (Args : in Mal_Type_Array) return Mal_Type; - function Seq (Args : in Mal_Type_Array) return Mal_Type; - function Slurp (Args : in Mal_Type_Array) return Mal_Type; - function Str (Args : in Mal_Type_Array) return Mal_Type; - function Swap (Args : in Mal_Type_Array) return Mal_Type; - function Symbol (Args : in Mal_Type_Array) return Mal_Type; - function Throw (Args : in Mal_Type_Array) return Mal_Type; - function Time_Ms (Args : in Mal_Type_Array) return Mal_Type; - function Vals (Args : in Mal_Type_Array) return Mal_Type; - function Vector (Args : in Mal_Type_Array) return Mal_Type; - function With_Meta (Args : in Mal_Type_Array) return Mal_Type; + function Apply (Func : in Mal.T; + Args : in Mal.T_Array; + Name : in String) return Mal.T with Inline; + -- If Func is not executable, report an exception using "name" as + -- the built-in function name. generic - with function Ada_Operator (Left, Right : in Integer) return Integer; - function Generic_Mal_Operator (Args : in Mal_Type_Array) return Mal_Type; - function Generic_Mal_Operator (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Number, Atoms.No_Element, - Ada_Operator (Args (Args'First).Integer_Value, - Args (Args'First + 1).Integer_Value)); - function Addition is new Generic_Mal_Operator ("+"); - function Subtraction is new Generic_Mal_Operator ("-"); - function Product is new Generic_Mal_Operator ("*"); - function Division is new Generic_Mal_Operator ("/"); + Kind : in Kind_Type; + Name : in String; + function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T; + function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 + then raise Argument_Error with Name & ": expects 1 argument" + else (Kind_Boolean, Args (Args'First).Kind = Kind)); generic - with function Ada_Operator (Left, Right : in Integer) return Boolean; - function Generic_Comparison (Args : in Mal_Type_Array) return Mal_Type; - function Generic_Comparison (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, - Ada_Operator (Args (Args'First).Integer_Value, - Args (Args'First + 1).Integer_Value)); - function Greater_Than is new Generic_Comparison (">"); - function Greater_Equal is new Generic_Comparison (">="); - function Less_Than is new Generic_Comparison ("<"); - function Less_Equal is new Generic_Comparison ("<="); + with function Ada_Operator (Left, Right : in Integer) return Integer; + Name : in String; + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 2 + then raise Argument_Error with Name & ": expects 2 arguments" + elsif (for some A of Args => A.Kind /= Kind_Number) + then raise Argument_Error with Name & ": expects numbers" + else (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number, + Args (Args'Last).Ada_Number))); generic - Kind : Kind_Type; - function Generic_Kind_Test (Args : in Mal_Type_Array) return Mal_Type; - function Generic_Kind_Test (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, Args (Args'First).Kind = Kind); - function Is_Atom is new Generic_Kind_Test (Kind_Atom); - function Is_Keyword is new Generic_Kind_Test (Kind_Keyword); - function Is_List is new Generic_Kind_Test (Kind_List); - function Is_Map is new Generic_Kind_Test (Kind_Map); - function Is_Nil is new Generic_Kind_Test (Kind_Nil); - function Is_String is new Generic_Kind_Test (Kind_String); - function Is_Symbol is new Generic_Kind_Test (Kind_Symbol); - function Is_Vector is new Generic_Kind_Test (Kind_Vector); + with function Ada_Operator (Left, Right : in Integer) return Boolean; + Name : in String; + function Generic_Comparison (Args : in Mal.T_Array) return Mal.T; + function Generic_Comparison (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 2 + then raise Argument_Error with Name & ": expects 2 arguments" + elsif (for some A of Args => A.Kind /= Kind_Number) + then raise Argument_Error with Name & ": expects numbers" + else (Kind_Boolean, Ada_Operator (Args (Args'First).Ada_Number, + Args (Args'Last).Ada_Number))); + + -- Built-in functions from this package. + function Addition is new Generic_Mal_Operator ("+", "+"); + function Apply (Args : in Mal.T_Array) return Mal.T; + function Division is new Generic_Mal_Operator ("/", "/"); + function Equals (Args : in Mal.T_Array) return Mal.T; + function Eval (Args : in Mal.T_Array) return Mal.T; + function Greater_Equal is new Generic_Comparison (">=", ">="); + function Greater_Than is new Generic_Comparison (">", ">"); + function Is_Atom is new Generic_Kind_Test (Kind_Atom, "atom?"); + function Is_False (Args : in Mal.T_Array) return Mal.T; + function Is_Function (Args : in Mal.T_Array) return Mal.T; + function Is_Keyword is new Generic_Kind_Test (Kind_Keyword, "keyword?"); + function Is_List is new Generic_Kind_Test (Kind_List, "list?"); + function Is_Macro is new Generic_Kind_Test (Kind_Macro, "macro?"); + function Is_Map is new Generic_Kind_Test (Kind_Map, "map?"); + function Is_Nil is new Generic_Kind_Test (Kind_Nil, "nil?"); + function Is_Number is new Generic_Kind_Test (Kind_Number, "number?"); + function Is_Sequential (Args : in Mal.T_Array) return Mal.T; + function Is_String is new Generic_Kind_Test (Kind_String, "string?"); + function Is_Symbol is new Generic_Kind_Test (Kind_Symbol, "symbol?"); + function Is_True (Args : in Mal.T_Array) return Mal.T; + function Is_Vector is new Generic_Kind_Test (Kind_Vector, "vector?"); + function Keyword (Args : in Mal.T_Array) return Mal.T; + function Less_Equal is new Generic_Comparison ("<=", "<="); + function Less_Than is new Generic_Comparison ("<", "<"); + function Map (Args : in Mal.T_Array) return Mal.T; + function Meta (Args : in Mal.T_Array) return Mal.T; + function Pr_Str (Args : in Mal.T_Array) return Mal.T; + function Println (Args : in Mal.T_Array) return Mal.T; + function Prn (Args : in Mal.T_Array) return Mal.T; + function Product is new Generic_Mal_Operator ("*", "*"); + function Read_String (Args : in Mal.T_Array) return Mal.T; + function Readline (Args : in Mal.T_Array) return Mal.T; + function Seq (Args : in Mal.T_Array) return Mal.T; + function Slurp (Args : in Mal.T_Array) return Mal.T; + function Str (Args : in Mal.T_Array) return Mal.T; + function Subtraction is new Generic_Mal_Operator ("-", "-"); + function Swap (Args : in Mal.T_Array) return Mal.T; + function Symbol (Args : in Mal.T_Array) return Mal.T; + function Throw (Args : in Mal.T_Array) return Mal.T; + function Time_Ms (Args : in Mal.T_Array) return Mal.T; + function With_Meta (Args : in Mal.T_Array) return Mal.T; ---------------------------------------------------------------------- - procedure Add_Built_In_Functions - (Repl : in Environments.Ptr; - Eval_Callback : in not null Eval_Callback_Type) - is - function N (N : in Native_Function_Access) return Mal_Type - is (Kind_Native, Atoms.No_Element, N) with Inline; + function Apply (Func : in Mal.T; + Args : in Mal.T_Array; + Name : in String) + return Mal.T is begin - Eval := Eval_Callback; - - Repl.Increase_Capacity (57); - - Repl.Set (Names.Apply, N (Apply'Access)); - Repl.Set (Names.Assoc, N (Assoc'Access)); - Repl.Set (Names.Asterisk, N (Product'Access)); - Repl.Set (Names.Atom, N (Atom'Access)); - Repl.Set (Names.Concat, N (Concat'Access)); - Repl.Set (Names.Conj, N (Conj'Access)); - Repl.Set (Names.Cons, N (Cons'Access)); - Repl.Set (Names.Contains, N (Contains'Access)); - Repl.Set (Names.Count, N (Count'Access)); - Repl.Set (Names.Deref, N (Deref'Access)); - Repl.Set (Names.Dissoc, N (Dissoc'Access)); - Repl.Set (Names.Equals, N (Equals'Access)); - Repl.Set (Names.First, N (First'Access)); - Repl.Set (Names.Get, N (Get'Access)); - Repl.Set (Names.Greater_Equal, N (Greater_Equal'Access)); - Repl.Set (Names.Greater_Than, N (Greater_Than'Access)); - Repl.Set (Names.Hash_Map, N (Hash_Map'Access)); - Repl.Set (Names.Is_Atom, N (Is_Atom'Access)); - Repl.Set (Names.Is_Empty, N (Is_Empty'Access)); - Repl.Set (Names.Is_False, N (Is_False'Access)); - Repl.Set (Names.Is_Keyword, N (Is_Keyword'Access)); - Repl.Set (Names.Is_List, N (Is_List'Access)); - Repl.Set (Names.Is_Map, N (Is_Map'Access)); - Repl.Set (Names.Is_Nil, N (Is_Nil'Access)); - Repl.Set (Names.Is_Sequential, N (Is_Sequential'Access)); - Repl.Set (Names.Is_String, N (Is_String'Access)); - Repl.Set (Names.Is_Symbol, N (Is_Symbol'Access)); - Repl.Set (Names.Is_True, N (Is_True'Access)); - Repl.Set (Names.Is_Vector, N (Is_Vector'Access)); - Repl.Set (Names.Keys, N (Keys'Access)); - Repl.Set (Names.Keyword, N (Keyword'Access)); - Repl.Set (Names.Less_Equal, N (Less_Equal'Access)); - Repl.Set (Names.Less_Than, N (Less_Than'Access)); - Repl.Set (Names.List, N (List'Access)); - Repl.Set (Names.Map, N (Map'Access)); - Repl.Set (Names.Meta, N (Meta'Access)); - Repl.Set (Names.Minus, N (Subtraction'Access)); - Repl.Set (Names.Nth, N (Nth'Access)); - Repl.Set (Names.Plus, N (Addition'Access)); - Repl.Set (Names.Pr_Str, N (Pr_Str'Access)); - Repl.Set (Names.Println, N (Println'Access)); - Repl.Set (Names.Prn, N (Prn'Access)); - Repl.Set (Names.Read_String, N (Read_String'Access)); - Repl.Set (Names.Readline, N (Readline'Access)); - Repl.Set (Names.Reset, N (Reset'Access)); - Repl.Set (Names.Rest, N (Rest'Access)); - Repl.Set (Names.Seq, N (Seq'Access)); - Repl.Set (Names.Slash, N (Division'Access)); - Repl.Set (Names.Slurp, N (Slurp'Access)); - Repl.Set (Names.Str, N (Str'Access)); - Repl.Set (Names.Swap, N (Swap'Access)); - Repl.Set (Names.Symbol, N (Symbol'Access)); - Repl.Set (Names.Throw, N (Throw'Access)); - Repl.Set (Names.Time_Ms, N (Time_Ms'Access)); - Repl.Set (Names.Vals, N (Vals'Access)); - Repl.Set (Names.Vector, N (Vector'Access)); - Repl.Set (Names.With_Meta, N (With_Meta'Access)); - end Add_Built_In_Functions; - - function Apply (Args : in Mal_Type_Array) return Mal_Type - is - Func : Mal_Type renames Args (Args'First); - List : Lists.Ptr renames Args (Args'Last).L; - Actuals : Mal_Type_Array (1 .. Args'Length - 2 + List.Length); - begin - Actuals (1 .. Args'Length - 2) := Args (Args'First + 1 .. Args'Last - 1); - for I in 1 .. List.Length loop - Actuals (Args'Length - 2 + I) := List.Element (I); - end loop; - if Func.Kind = Kind_Native then - return Func.Native.all (Actuals); - else + case Func.Kind is + when Kind_Builtin => + return Func.Builtin.all (Args); + when Kind_Builtin_With_Meta => + return Func.Builtin_With_Meta.Data.all (Args); + when Kind_Function => declare - Env : constant Environments.Ptr - := Environments.Alloc (Outer => Func.Environment); + Env : constant Environments.Ptr := Func.Function_Value.Closure.Sub; begin - Env.Set_Binds (Func.Formals, Actuals); - return Eval.all (Func.Expression.Deref, Env); + Func.Function_Value.Set_Binds (Env, Args); + return Eval_Ref.all (Func.Function_Value.Expression, Env); end; - end if; + when others => + raise Argument_Error with Name & ": cannot execute " + & ASU.To_String (Printer.Pr_Str (Func)); + end case; end Apply; - function Assoc (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Map, Atoms.No_Element, - Args (Args'First).Map.Assoc (Args (Args'First + 1 .. Args'Last))); - - function Atom (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Atom, Atoms.No_Element, Atoms.Alloc (Args (Args'First))); - - function Concat (Args : in Mal_Type_Array) return Mal_Type - is - L : array (Args'Range) of Lists.Ptr; - Sum : Natural := 0; - Result : Lists.Ptr; - begin - for I in Args'Range loop - L (I) := Args (I).L; - Sum := Sum + L (I).Length; - end loop; - Result := Lists.Alloc (Sum); - Sum := 0; - for LI of L loop - for J in 1 .. LI.Length loop - Sum := Sum + 1; - Result.Replace_Element (Sum, LI.Element (J)); - end loop; - end loop; - return (Kind_List, Atoms.No_Element, Result); - end Concat; - - function Concatenation_Of_Pr_Str - (Args : in Mal_Type_Array; - Print_Readably : in Boolean := True; - Separator : in String := " ") - return Ada.Strings.Unbounded.Unbounded_String - is - use Ada.Strings.Unbounded; - Result : Unbounded_String; + function Apply (Args : in Mal.T_Array) return Mal.T + is (if Args'Length < 2 then + raise Argument_Error with "apply: expects at least 2 arguments" + elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "apply: last arg must a be list or vector" + else + Apply (Args (Args'First), + Args (Args'First + 1 .. Args'Last - 1) & Args (Args'Last).L, + "apply")); + + function Equals (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 2 then + raise Argument_Error with "=: expects 2 arguments" + else + (Kind_Boolean, Args (Args'First) = Args (Args'Last))); + + function Eval (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "eval: expects 1 argument" + else + (Eval_Ref.all (Args (Args'First), Environments.Repl))); + + function Is_False (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "false?: expects 1 argument" + else (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then not Args (Args'First).Ada_Boolean)); + + function Is_Function (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "count: expects 1 argument" + else + (Kind_Boolean, Args (Args'First).Kind in + Kind_Function | Kind_Builtin | Kind_Builtin_With_Meta)); + + function Is_Sequential (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "sequential?: expects 1 argument" + else + (Kind_Boolean, Args (Args'First).Kind in Kind_List | Kind_Vector)); + + function Is_True (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "true?: expects 1 argument" + else + (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then Args (Args'First).Ada_Boolean)); + + function Keyword (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "keyword: expects 1 argument" + elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then + raise Argument_Error with "keyword: expects a keyword or a string" + else + (Kind_Keyword, Args (Args'First).S)); + + function Map (Args : in Mal.T_Array) return Mal.T is begin - if 1 <= Args'Length then - Append (Result, Printer.Pr_Str (Args (Args'First), Print_Readably)); - for I in Args'First + 1 .. Args'Last loop - Append (Result, Separator); - Append (Result, Printer.Pr_Str (Args (I), Print_Readably)); - end loop; + if Args'Length /= 2 then + raise Argument_Error with "map: expects 2 arguments"; + elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "map: arg 2 must be a list or vector"; end if; - return Result; - end Concatenation_Of_Pr_Str; - - function Conj (Args : in Mal_Type_Array) return Mal_Type - is - List : Lists.Ptr renames Args (Args'First).L; - Result : constant Lists.Ptr - := Lists.Alloc (List.Length + Args'Length - 1); - begin - if Args (Args'First).Kind = Kind_List then - for I in Args'First + 1 .. Args'Last loop - Result.Replace_Element (Args'Last + 1 - I, Args (I)); - end loop; - for I in 1 .. List.Length loop - Result.Replace_Element (Args'Length + I - 1, List.Element (I)); - end loop; - return (Kind_List, Atoms.No_Element, Result); - else - for I in 1 .. Args'Length - 1 loop - Result.Replace_Element (List.Length + I, Args (Args'First + I)); - end loop; - for I in 1 .. List.Length loop - Result.Replace_Element (I, List.Element (I)); + declare + R : Mal.T_Array (1 .. Args (Args'Last).L.Length); + begin + for I in R'Range loop + R (I) := Apply (Args (Args'First), + Mal.T_Array'(1 => Args (Args'Last).L.Element (I)), + "map"); end loop; - return (Kind_Vector, Atoms.No_Element, Result); - end if; - end Conj; + return Lists.List (R); + end; + end Map; - function Cons (Args : in Mal_Type_Array) return Mal_Type - is - List : Lists.Ptr renames Args (Args'First + 1).L; - Result : constant Lists.Ptr := Lists.Alloc (1 + List.Length); - begin - Result.Replace_Element (1, Args (Args'First)); - for I in 1 .. List.Length loop - Result.Replace_Element (I + 1, List.Element (I)); - end loop; - return (Kind_List, Atoms.No_Element, Result); - end Cons; - - function Contains (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, - Args (Args'First).Map.Contains (Args (Args'First + 1))); - - function Count (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Number, Atoms.No_Element, - (if Args (Args'First).Kind = Kind_Nil - then 0 - else Args (Args'First).L.Length)); - - function Deref (Args : in Mal_Type_Array) return Mal_Type - is (Args (Args'First).Reference.Deref); - - function Dissoc (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Map, Atoms.No_Element, - Args (Args'First).Map.Dissoc (Args (Args'First + 1 .. Args'Last))); - - function Equals (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, - Args (Args'First) = Args (Args'First + 1)); - - function First (Args : in Mal_Type_Array) return Mal_Type - is (if Args (Args'First).Kind = Kind_Nil - or else Args (Args'First).L.Length = 0 - then (Kind_Nil, Atoms.No_Element) - else Args (Args'First).L.Element (1)); - - function Get (Args : in Mal_Type_Array) return Mal_Type is - begin - if Args (Args'First).Kind = Kind_Nil then - return (Kind_Nil, Atoms.No_Element); - else - return Args (Args'First).Map.Get (Args (Args'First + 1)); - end if; - exception - when Maps.Unknown_Key => - return (Kind_Nil, Atoms.No_Element); - end Get; - - function Hash_Map (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Map, Atoms.No_Element, Maps.Hash_Map (Args)); - - function Is_Empty (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, Args (Args'First).L.Length = 0); - - function Is_False (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, - Args (Args'First).Kind = Kind_Boolean - and then not Args (Args'First).Boolean_Value); - - function Is_True (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, - Args (Args'First).Kind = Kind_Boolean - and then Args (Args'First).Boolean_Value); - - function Is_Sequential (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Boolean, Atoms.No_Element, - Args (Args'First).Kind in Kind_List | Kind_Vector); - - function Keyword (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Keyword, Atoms.No_Element, Args (Args'First).S); - - function Keys (Args : in Mal_Type_Array) return Mal_Type - is - M : Maps.Ptr renames Args (Args'First).Map; - Result : constant Mal_Type := (Kind_List, Atoms.No_Element, - Lists.Alloc (M.Length)); - I : Natural := 0; - procedure Process (Key, Element : in Mal_Type); - procedure Process (Key, Element : in Mal_Type) is - begin - I := I + 1; - Result.L.Replace_Element (I, Key); - pragma Unreferenced (Element); - end Process; + function Meta (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "meta: expects 1 argument" + else + (case Args (Args'First).Kind is + when Kind_List | Kind_Vector => + Args (Args'First).L.Meta, + when Kind_Map => + Args (Args'First).Map.Meta, + when Kind_Function => + Args (Args'First).Function_Value.Meta, + when Kind_Builtin_With_Meta => + Args (Args'First).Builtin_With_Meta.Meta, + when others => + Mal.Nil)); + + function Pr_Str (Args : in Mal.T_Array) return Mal.T is begin - M.Iterate (Process'Access); - return Result; - end Keys; - - function List (Args : in Mal_Type_Array) return Mal_Type - is (Kind_List, Atoms.No_Element, Lists.Alloc (Args)); - - function Map (Args : in Mal_Type_Array) return Mal_Type - is - Func : Mal_Type renames Args (Args'First); - List : Lists.Ptr renames Args (Args'First + 1).L; - Actuals : Mal_Type_Array (1 .. 1); - Result : constant Lists.Ptr := Lists.Alloc (List.Length); - begin - for I in 1 .. List.Length loop - Actuals (1) := List.Element (I); - if Func.Kind = Kind_Native then - Result.Replace_Element (I, Func.Native.all (Actuals)); - else - declare - Env : constant Environments.Ptr - := Environments.Alloc (Func.Environment); - begin - Env.Set_Binds (Func.Formals, Actuals); - Result.Replace_Element (I, Eval.all (Func.Expression.Deref, - Env)); - end; + return R : Mal.T := (Kind_String, ASU.Null_Unbounded_String) do + if 0 < Args'Length then + ASU.Append (R.S, Printer.Pr_Str (Args (Args'First))); + for I in Args'First + 1 .. Args'Last loop + ASU.Append (R.S, ' '); + ASU.Append (R.S, Printer.Pr_Str (Args (I))); + end loop; end if; - end loop; - return (Kind_List, Atoms.No_Element, Result); - end Map; - - function Meta (Args : in Mal_Type_Array) return Mal_Type - is (if Args (Args'First).Meta = Atoms.No_Element - then (Kind_Nil, Atoms.No_Element) - else Args (Args'First).Meta.Deref); - - function Nth (Args : in Mal_Type_Array) return Mal_Type - is (Args (Args'First).L.Element (1 + Args (Args'First + 1).Integer_Value)); - - function Pr_Str (Args : in Mal_Type_Array) return Mal_Type - is (Kind_String, Atoms.No_Element, Strings.Alloc - (Ada.Strings.Unbounded.To_String (Concatenation_Of_Pr_Str (Args)))); + end return; + end Pr_Str; - function Println (Args : in Mal_Type_Array) return Mal_Type is + function Println (Args : in Mal.T_Array) return Mal.T is + use Ada.Text_IO.Unbounded_IO; begin - Ada.Text_IO.Unbounded_IO.Put_Line (Concatenation_Of_Pr_Str - (Args, Print_Readably => False)); - return (Kind_Nil, Atoms.No_Element); + if 0 < Args'Length then + Put (Printer.Pr_Str (Args (Args'First), Readably => False)); + for I in Args'First + 1 .. Args'Last loop + Ada.Text_IO.Put (' '); + Put (Printer.Pr_Str (Args (I), Readably => False)); + end loop; + end if; + Ada.Text_IO.New_Line; + return Mal.Nil; end Println; - function Prn (Args : in Mal_Type_Array) return Mal_Type is + function Prn (Args : in Mal.T_Array) return Mal.T is begin - Ada.Text_IO.Unbounded_IO.Put_Line (Concatenation_Of_Pr_Str (Args)); - return (Kind_Nil, Atoms.No_Element); + if 0 < Args'Length then + Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (Args'First))); + for I in Args'First + 1 .. Args'Last loop + Ada.Text_IO.Put (' '); + Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (I))); + end loop; + end if; + Ada.Text_IO.New_Line; + return Mal.Nil; end Prn; - function Readline (Args : in Mal_Type_Array) return Mal_Type is + function Readline (Args : in Mal.T_Array) return Mal.T is begin - Ada.Text_IO.Put (Args (Args'First).S.Deref); - return (Kind_String, Atoms.No_Element, - Strings.Alloc (Ada.Text_IO.Get_Line)); + if Args'Length /= 1 then + raise Argument_Error with "readline: expects 1 argument"; + elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then + raise Argument_Error with "readline: expects a keyword or string"; + else + Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S); + return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line); + end if; exception when Ada.Text_IO.End_Error => - return (Kind_Nil, Atoms.No_Element); + return Mal.Nil; end Readline; - function Read_String (Args : in Mal_Type_Array) return Mal_Type - is (Reader.Read_Str (Args (Args'First).S.Deref)); + function Read_String (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "read-string: expects 1 argument" + elsif Args (Args'First).Kind /= Kind_String then + raise Argument_Error with "read-string: expects a string" + else + Reader.Read_Str (ASU.To_String (Args (Args'First).S))); - function Reset (Args : in Mal_Type_Array) return Mal_Type is + function Seq (Args : in Mal.T_Array) return Mal.T is begin - Args (Args'First).Reference.Set (Args (Args'Last)); - return Args (Args'Last); - end Reset; - - function Rest (Args : in Mal_Type_Array) return Mal_Type - is - List : Mal_Type renames Args (Args'First); - Len : Natural; - begin - return Result : Mal_Type (Kind_List) do - if List.Kind /= Kind_Nil then - Len := List.L.Length; - if 0 < Len then - Len := Len - 1; - Result.L := Lists.Alloc (Len); - for I in 1 .. Len loop - Result.L.Replace_Element (I, List.L.Element (I + 1)); - end loop; + if Args'Length /= 1 then + raise Argument_Error with "seq: expects 1 argument"; + end if; + case Args (Args'First).Kind is + when Kind_Nil => + return Mal.Nil; + when Kind_String => + if ASU.Length (Args (Args'First).S) = 0 then + return Mal.Nil; + else + declare + A1 : constant ASU.Unbounded_String := Args (Args'First).S; + R : Mal.T_Array (1 .. ASU.Length (A1)); + begin + for I in R'Range loop + R (I) := (Kind_String, ASU.Unbounded_Slice (A1, I, I)); + end loop; + return Lists.List (R); + end; end if; - end if; - end return; - end Rest; - - function Seq (Args : in Mal_Type_Array) return Mal_Type is - begin - if Args (Args'First).Kind = Kind_String then - declare - S : constant String := Args (Args'First).S.Deref; - Result : Lists.Ptr; - begin - if S'Length = 0 then - return (Kind_Nil, Atoms.No_Element); + when Kind_List | Kind_Vector => + if Args (Args'First).L.Length = 0 then + return Mal.Nil; else - Result := Lists.Alloc (S'Length); - for I in S'Range loop - Result.Replace_Element (I - S'First + 1, Mal_Type' - (Kind_String, Atoms.No_Element, - Strings.Alloc (S (I .. I)))); - end loop; - return (Kind_List, Atoms.No_Element, Result); + return (Kind_List, Args (Args'First).L); end if; - end; - elsif Args (Args'First).Kind = Kind_Nil - or else Args (Args'First).L.Length = 0 - then - return (Kind_Nil, Atoms.No_Element); - else - return (Kind_List, Atoms.No_Element, Args (Args'First).L); - end if; + when others => + raise Argument_Error with "seq: expects a string, list or vector"; + end case; end Seq; - function Slurp (Args : in Mal_Type_Array) return Mal_Type - is - use Ada.Strings.Unbounded; + function Slurp (Args : in Mal.T_Array) return Mal.T is use Ada.Text_IO; File : File_Type; - Buffer : Unbounded_String; + Buffer : ASU.Unbounded_String; begin - Open (File, In_File, Args (Args'First).S.Deref); - while not End_Of_File (File) loop - Append (Buffer, Get_Line (File)); - Append (Buffer, Ada.Characters.Latin_1.LF); - end loop; - Close (File); - return (Kind_String, Atoms.No_Element, - Strings.Alloc (To_String (Buffer))); + if Args'Length /= 1 then + raise Argument_Error with "slurp: expects 1 argument"; + elsif Args (Args'First).Kind /= Kind_String then + raise Argument_Error with "slurp: expects a string"; + else + Open (File, In_File, ASU.To_String (Args (Args'First).S)); + while not End_Of_File (File) loop + ASU.Append (Buffer, Get_Line (File)); + ASU.Append (Buffer, Ada.Characters.Latin_1.LF); + end loop; + Close (File); + return (Kind_String, Buffer); + end if; exception when others => Close (File); raise; end Slurp; - function Str (Args : in Mal_Type_Array) return Mal_Type - is (Kind_String, Atoms.No_Element, Strings.Alloc - (Ada.Strings.Unbounded.To_String - (Concatenation_Of_Pr_Str (Args, - Print_Readably => False, - Separator => "")))); - - function Swap (Args : in Mal_Type_Array) return Mal_Type - is - Atom : Mal_Type renames Args (Args'First); - Func : Mal_Type renames Args (Args'First + 1); - Actuals : Mal_Type_Array (Args'First + 1 .. Args'Last); - Result : Mal_Type; + function Str (Args : in Mal.T_Array) return Mal.T is begin - Actuals (Actuals'First) := Atom.Reference.Deref; - for I in Actuals'First + 1 .. Args'Last loop - Actuals (I) := Args (I); - end loop; - if Func.Kind = Kind_Native then - Result := Func.Native.all (Actuals); - else - declare - Env : constant Environments.Ptr - := Environments.Alloc (Outer => Func.Environment); - begin - Env.Set_Binds (Func.Formals, Actuals); - Result := Eval.all (Func.Expression.Deref, Env); - end; - end if; - Atom.Reference.Set (Result); - return Result; - end Swap; - - function Symbol (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Symbol, Atoms.No_Element, Args (Args'First).S); + return R : Mal.T := (Kind_String, ASU.Null_Unbounded_String) do + for Arg of Args loop + ASU.Append (R.S, Printer.Pr_Str (Arg, Readably => False)); + end loop; + end return; + end Str; - function Throw (Args : in Mal_Type_Array) return Mal_Type is + function Swap (Args : in Mal.T_Array) return Mal.T is begin - Last_Exception := Args (Args'First); - raise Exception_Throwed; - return (Kind_Nil, Atoms.No_Element); -- GNAT wants a return. - end Throw; - - function Time_Ms (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Number, Atoms.No_Element, - Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); - - function Vals (Args : in Mal_Type_Array) return Mal_Type - is - M : Maps.Ptr renames Args (Args'First).Map; - Result : constant Mal_Type := (Kind_List, Atoms.No_Element, - Lists.Alloc (M.Length)); - I : Natural := 0; - procedure Process (Key, Element : in Mal_Type); - procedure Process (Key, Element : in Mal_Type) is + if Args'Length < 2 then + raise Argument_Error with "swap!: expects at least 2 arguments"; + elsif Args (Args'First).Kind /= Kind_Atom then + raise Argument_Error with "swap!: arg 1 must be an atom"; + end if; + declare + X : Mal.T renames Atoms.Deref (Args (Args'First .. Args'First)); + FX : Mal.T renames Apply (Args (Args'First + 1), + X & Args (Args'First + 2 .. Args'Last), + "swap!"); begin - I := I + 1; - Result.L.Replace_Element (I, Element); - pragma Unreferenced (Key); - end Process; - begin - M.Iterate (Process'Access); - return Result; - end Vals; + return Atoms.Reset (Mal.T_Array'(Args (Args'First), FX)); + end; + end Swap; - function Vector (Args : in Mal_Type_Array) return Mal_Type - is (Kind_Vector, Atoms.No_Element, Lists.Alloc (Args)); + function Symbol (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "symbol?: expects 1 argument" + else + (Kind_Symbol, + Symbols.Constructor (ASU.To_String (Args (Args'First).S)))); - function With_Meta (Args : in Mal_Type_Array) return Mal_Type is + function Throw (Args : in Mal.T_Array) return Mal.T is begin - return Result : Mal_Type := Args (Args'First) do - Result.Meta := Atoms.Alloc (Args (Args'First + 1)); - end return; - end With_Meta; + if Args'Length /= 1 then + raise Argument_Error with "throw: expects 1 argument"; + else + Last_Exception := Args (Args'First); + raise Exception_Throwed; + return Mal.Nil; -- GNAT wants a return. + end if; + end Throw; + function Time_Ms (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 0 then + raise Argument_Error with "time: expects no argument" + else + (Kind_Number, Integer (1000.0 * (Ada.Calendar.Clock - Start_Time)))); + + function With_Meta (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 2 then + raise Argument_Error with "with-meta: expects 2 arguments" + else (case Args (Args'First).Kind is + when Kind_Builtin_With_Meta => + Args (Args'First).Builtin_With_Meta.With_Meta (Args (Args'Last)), + when Kind_Builtin => + Builtins.With_Meta (Args (Args'First).Builtin, Args (Args'Last)), + when Kind_List => + (Kind_List, Args (Args'First).L.With_Meta (Args (Args'Last))), + when Kind_Vector => + (Kind_Vector, Args (Args'First).L.With_Meta (Args (Args'Last))), + when Kind_Map => + Args (Args'First).Map.With_Meta (Args (Args'Last)), + when Kind_Function => + Args (Args'First).Function_Value.With_Meta (Args (Args'Last)), + when others => + Args (Args'First))); + + use Symbols; + R : Environments.Ptr renames Environments.Repl; + B : Kind_Type renames Kind_Builtin; +begin + R.Set (Constructor ("+"), (B, Addition'Access)); + R.Set (Constructor ("apply"), (B, Apply'Access)); + R.Set (Constructor ("assoc"), (B, Maps.Assoc'Access)); + R.Set (Constructor ("atom"), (B, Atoms.Atom'Access)); + R.Set (Constructor ("concat"), (B, Lists.Concat'Access)); + R.Set (Constructor ("conj"), (B, Lists.Conj'Access)); + R.Set (Constructor ("cons"), (B, Lists.Cons'Access)); + R.Set (Constructor ("contains?"), (B, Maps.Contains'Access)); + R.Set (Constructor ("count"), (B, Lists.Count'Access)); + R.Set (Names.Deref, (B, Atoms.Deref'Access)); + R.Set (Constructor ("dissoc"), (B, Maps.Dissoc'Access)); + R.Set (Constructor ("/"), (B, Division'Access)); + R.Set (Constructor ("="), (B, Equals'Access)); + R.Set (Constructor ("eval"), (B, Eval'Access)); + R.Set (Constructor ("first"), (B, Lists.First'Access)); + R.Set (Constructor ("get"), (B, Maps.Get'Access)); + R.Set (Constructor (">="), (B, Greater_Equal'Access)); + R.Set (Constructor (">"), (B, Greater_Than'Access)); + R.Set (Constructor ("hash-map"), (B, Maps.Hash_Map'Access)); + R.Set (Constructor ("atom?"), (B, Is_Atom'Access)); + R.Set (Constructor ("empty?"), (B, Lists.Is_Empty'Access)); + R.Set (Constructor ("false?"), (B, Is_False'Access)); + R.Set (Constructor ("fn?"), (B, Is_Function'Access)); + R.Set (Constructor ("keyword?"), (B, Is_Keyword'Access)); + R.Set (Constructor ("list?"), (B, Is_List'Access)); + R.Set (Constructor ("macro?"), (B, Is_Macro'Access)); + R.Set (Constructor ("map?"), (B, Is_Map'Access)); + R.Set (Constructor ("nil?"), (B, Is_Nil'Access)); + R.Set (Constructor ("number?"), (B, Is_Number'Access)); + R.Set (Constructor ("sequential?"), (B, Is_Sequential'Access)); + R.Set (Constructor ("string?"), (B, Is_String'Access)); + R.Set (Constructor ("symbol?"), (B, Is_Symbol'Access)); + R.Set (Constructor ("true?"), (B, Is_True'Access)); + R.Set (Constructor ("vector?"), (B, Is_Vector'Access)); + R.Set (Constructor ("keys"), (B, Maps.Keys'Access)); + R.Set (Constructor ("keyword"), (B, Keyword'Access)); + R.Set (Constructor ("<="), (B, Less_Equal'Access)); + R.Set (Constructor ("<"), (B, Less_Than'Access)); + R.Set (Constructor ("list"), (B, Lists.List'Access)); + R.Set (Constructor ("map"), (B, Map'Access)); + R.Set (Constructor ("meta"), (B, Meta'Access)); + R.Set (Constructor ("nth"), (B, Lists.Nth'Access)); + R.Set (Constructor ("pr-str"), (B, Pr_Str'Access)); + R.Set (Constructor ("println"), (B, Println'Access)); + R.Set (Constructor ("prn"), (B, Prn'Access)); + R.Set (Constructor ("*"), (B, Product'Access)); + R.Set (Constructor ("read-string"), (B, Read_String'Access)); + R.Set (Constructor ("readline"), (B, Readline'Access)); + R.Set (Constructor ("reset!"), (B, Atoms.Reset'Access)); + R.Set (Constructor ("rest"), (B, Lists.Rest'Access)); + R.Set (Constructor ("seq"), (B, Seq'Access)); + R.Set (Constructor ("slurp"), (B, Slurp'Access)); + R.Set (Constructor ("str"), (B, Str'Access)); + R.Set (Constructor ("-"), (B, Subtraction'Access)); + R.Set (Constructor ("swap!"), (B, Swap'Access)); + R.Set (Constructor ("symbol"), (B, Symbol'Access)); + R.Set (Constructor ("throw"), (B, Throw'Access)); + R.Set (Constructor ("time-ms"), (B, Time_Ms'Access)); + R.Set (Constructor ("vals"), (B, Maps.Vals'Access)); + R.Set (Constructor ("vector"), (B, Lists.Vector'Access)); + R.Set (Names.With_Meta, (B, With_Meta'Access)); end Core; diff --git a/ada2/core.ads b/ada2/core.ads index 89d5414cc8..eb1d8dd008 100644 --- a/ada2/core.ads +++ b/ada2/core.ads @@ -1,17 +1,19 @@ -with Environments; -with Types; pragma Elaborate_All (Types); +limited with Environments; +with Types.Mal; -package Core is +package Core with Elaborate_Body is - type Eval_Callback_Type is access - function (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; + -- Initialization of this package fills Environments.Repl with + -- built-in functions. - procedure Add_Built_In_Functions - (Repl : in Environments.Ptr; - Eval_Callback : in not null Eval_Callback_Type); + Eval_Ref : access function (Ast : in Types.Mal.T; + Env : in Environments.Ptr) + return Types.Mal.T; + -- Set by the main program at startup. Exception_Throwed : exception; - Last_Exception : Types.Mal_Type; + Last_Exception : Types.Mal.T; + -- When the exception is throwed, Last_Exception is set with the + -- related Data. end Core; diff --git a/ada2/environments.adb b/ada2/environments.adb index 79c09bcd7f..75fef4b67c 100644 --- a/ada2/environments.adb +++ b/ada2/environments.adb @@ -1,166 +1,348 @@ -with Ada.Containers.Hashed_Maps; use type Ada.Containers.Count_Type; +with Ada.Containers.Hashed_Maps; with Ada.Unchecked_Deallocation; -with Atoms; -with Names; -with Strings; use type Strings.Ptr; -with Types; use type Types.Kind_Type; package body Environments is - -- There must be a reference level so that functions may keep - -- track of their initial environment, and another one for - -- reallocations. + use Types; - package Maps is new Ada.Containers.Hashed_Maps - (Key_Type => Strings.Ptr, - Element_Type => Types.Mal_Type, - Hash => Strings.Hash, - Equivalent_Keys => Strings."=", - "=" => Types."="); + -- The Eval built-in uses the REPL root environment (index 1), + -- all others parameters only repeat the top index. - type Env_Record is limited record - Data : Maps.Map; - Outer : Env_Access; - Refs : Positive; - end record; + package HM is new Ada.Containers.Hashed_Maps + (Key_Type => Symbols.Ptr, + Element_Type => Mal.T, + Hash => Symbols.Hash, + Equivalent_Keys => Symbols."=", + "=" => Mal."="); - procedure Free is new Ada.Unchecked_Deallocation (Object => Env_Record, - Name => Env_Access); + type Stack_Record + (Outer_On_Stack : Boolean := True) is record + Data : HM.Map := HM.Empty_Map; + Refs : Natural := 1; + -- Only references via the Ptr type. + -- References from the stack or Alias are not counted here. + Alias : Heap_Access := null; + -- Used by the closures and heap records to refer to this stack + -- record, so that if it moves to the heap we only need to + -- update the alias. + case Outer_On_Stack is + when True => + Outer_Index : Stack_Index := 0; + when False => + Outer_Ref : Heap_Access := null; + end case; + end record + with Dynamic_Predicate => 0 < Refs + and (Alias = null or else Alias.all.Outer = null) + and (if Outer_On_Stack + then Outer_Index <= Top + else Outer_Ref /= null); + + -- It is forbidden to change the discriminant of an access type, + -- so we cannot use a discriminant here. + type Heap_Record is limited record + Refs : Natural := 1; + Data : HM.Map := HM.Empty_Map; + Index : Stack_Index; + Outer : Heap_Access := null; + end record + with Dynamic_Predicate => + (if Outer = null + then Index in 1 .. Top and Data.Is_Empty + else 0 < Refs); + -- Either an alias for a stack element or an actual environment. + + -- There could be one single type, but this would enlarge the + -- stack without simplifying the code, and prevent some more + -- static type checking. + + Stack : array (Stack_Index range 1 .. Stack_Index'Last) of Stack_Record; + -- The default value gives a consistent value to Stack (1), + -- compatible with the Repl constant. + + procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access); + procedure Unreference (Reference : in out Heap_Access); ---------------------------------------------------------------------- - procedure Adjust (Object : in out Ptr) is + procedure Adjust (Object : in out Closure_Ptr) is begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + if Object.Ref /= null then + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end if; end Adjust; - function Alloc return Ptr - is (Ada.Finalization.Controlled with - Ref => new Env_Record'(Data => Maps.Empty_Map, - Outer => null, - Refs => 1)); + function Copy_Pointer (Env : in Ptr) return Ptr is + begin + Stack (Env.Index).Refs := Stack (Env.Index).Refs + 1; + return (Ada.Finalization.Limited_Controlled with Env.Index); + end Copy_Pointer; + + -- procedure Dump_Stack (Long : Boolean := False) is + -- use Ada.Text_IO; + -- use Ada.Text_IO.Unbounded_IO; + -- begin + -- for I in 1 .. Top loop + -- if Long then + -- Put ("Level"); + -- end if; + -- Put (I'Img); + -- if Long then + -- New_Line; + -- Put_Line (" refs=" & Stack (I).Refs'Img); + -- if Stack (I).Alias = null then + -- Put_Line (" no alias"); + -- else + -- Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img + -- & " refs"); + -- end if; + -- end if; + -- if Long then + -- Put (" outer="); + -- else + -- Put (" (->"); + -- end if; + -- if Stack (I).Outer_On_Stack then + -- Put (Stack (I).Outer_Index'Img); + -- elsif Stack (I).Outer_Ref.all.Outer = null then + -- if Long then + -- Put ("alias for "); + -- end if; + -- Put (Stack (I).Outer_Ref.all.Index'Img); + -- else + -- Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img); + -- end if; + -- if Long then + -- New_Line; + -- else + -- Put ("):"); + -- end if; + -- for P in Stack (I).Data.Iterate loop + -- if HM.Element (P).Kind /= Kind_Builtin then -- skip built-ins. + -- if Long then + -- Put (" "); + -- else + -- Put (' '); + -- end if; + -- Put (HM.Key (P).To_String); + -- Put (':'); + -- Put (Printer.Pr_Str (HM.Element (P))); + -- if Long then + -- New_Line; + -- end if; + -- end if; + -- end loop; + -- if Long then + -- Put (" ... built-ins"); + -- else + -- New_Line; + -- end if; + -- end loop; + -- if Long then + -- New_Line; + -- end if; + -- end Dump_Stack; - function Alloc (Outer : in Ptr) return Ptr is + procedure Finalize (Object : in out Closure_Ptr) is begin - Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; - return (Ada.Finalization.Controlled with - Ref => new Env_Record'(Data => Maps.Empty_Map, - Outer => Outer.Ref, - Refs => 1)); - end Alloc; - - procedure Finalize (Object : in out Ptr) - is - Ref : Env_Access; - Refs : Positive; + Unreference (Object.Ref); + end Finalize; + + procedure Finalize (Object : in out Ptr) is begin - if Object.Ref /= null then - Ref := Object.Ref; - Object.Ref := null; + if 0 < Object.Index then + if 0 < Stack (Object.Index).Refs then + Stack (Object.Index).Refs := Stack (Object.Index).Refs - 1; + end if; + Object.Index := 0; + + -- If Index = Top and there are no more references. loop - Refs := Ref.all.Refs; - if 1 < Refs then - Ref.all.Refs := Refs - 1; - exit; - end if; + pragma Assert (0 < Top); declare - Tmp : Env_Access := Ref; + R : Stack_Record renames Stack (Top); begin - Ref := Ref.all.Outer; - Free (Tmp); + exit when 0 < R.Refs; + + if Top = 1 then + R.Data.Clear; + if R.Alias /= null then + pragma Assert (R.Alias.all.Outer = null); + pragma Assert (R.Alias.all.Refs = 0); + Free (R.Alias); + end if; + exit; + elsif R.Alias = null then + R.Data.Clear; + if not R.Outer_On_Stack then + Unreference (R.Outer_Ref); + end if; + elsif R.Alias.all.Refs = 0 then + pragma Assert (R.Alias.all.Outer = null); + Free (R.Alias); + R.Data.Clear; + if not R.Outer_On_Stack then + Unreference (R.Outer_Ref); + end if; + else + -- Detach this environment from the stack. + + -- The reference count is already correct. + + -- Copy the hashmap contents without reallocation.. + R.Alias.all.Data.Move (R.Data); + + -- The Index will not be used anymore. + + -- We need the parent to have an alias, in case it + -- must be detached later. + if R.Outer_On_Stack then + declare + O : Stack_Record renames Stack (R.Outer_Index); + begin + if O.Alias = null then + O.Alias := new Heap_Record'(Index => R.Outer_Index, + others => <>); + else + O.Alias.all.Refs := O.Alias.all.Refs + 1; + end if; + R.Alias.all.Outer := O.Alias; + end; + else + R.Alias.all.Outer := R.Outer_Ref; + end if; + R.Alias := null; + end if; end; - exit when Ref = null; + Top := Top - 1; end loop; end if; end Finalize; - function Get (Container : in Ptr; - Key : in Strings.Ptr) return Types.Mal_Type - is - Ref : Env_Access := Container.Ref; - Position : Maps.Cursor; + function Get (Env : in Ptr; + Key : in Symbols.Ptr) + return Mal.T is + Index : Stack_Index := Env.Index; + Ref : Heap_Access; + Definition : HM.Cursor; begin - loop - Position := Ref.all.Data.Find (Key); - if Maps.Has_Element (Position) then - return Ref.all.Data (Position); - end if; - Ref := Ref.all.Outer; - exit when Ref = null; - end loop; - raise Unknown_Key with "'" & Key.Deref & "' not found"; + Main_Loop : loop + Index_Loop : loop + Definition := Stack (Index).Data.Find (Key); + if HM.Has_Element (Definition) then + return HM.Element (Definition); + end if; + exit Index_Loop when not Stack (Index).Outer_On_Stack; + Index := Stack (Index).Outer_Index; + exit Main_Loop when Index = 0; + end loop Index_Loop; + Ref := Stack (Index).Outer_Ref; + Ref_Loop : loop + Definition := Ref.all.Data.Find (Key); + if HM.Has_Element (Definition) then + return HM.Element (Definition); + end if; + exit Ref_Loop when Ref.all.Outer = null; + Ref := Ref.all.Outer; + end loop Ref_Loop; + Index := Ref.all.Index; + end loop Main_Loop; + raise Unknown_Key with "'" & Key.To_String & "' not found"; end Get; - procedure Increase_Capacity (Container : in Ptr; - Capacity : in Natural) - is - New_Capacity : constant Ada.Containers.Count_Type - := Container.Ref.all.Data.Length - + Ada.Containers.Count_Type (Capacity); + function New_Closure (Env : in Ptr'Class) return Closure_Ptr is + Alias : Heap_Access renames Stack (Env.Index).Alias; begin - if Container.Ref.all.Data.Capacity < New_Capacity then - Container.Ref.all.Data.Reserve_Capacity (New_Capacity); + if Alias = null then + Alias := new Heap_Record'(Index => Env.Index, others => <>); + else + Alias.all.Refs := Alias.all.Refs + 1; end if; - end Increase_Capacity; + return (Ada.Finalization.Controlled with Alias); + end New_Closure; - procedure Replace_With_Subenv (Item : in out Ptr) is + procedure Replace_With_Sub (Env : in out Ptr) is + R : Stack_Record renames Stack (Env.Index); begin - if 1 < Item.Ref.all.Refs then - Item.Ref := new Env_Record'(Data => Maps.Empty_Map, - Outer => Item.Ref, - Refs => 1); + if Env.Index < Top or 1 < R.Refs + or (R.Alias /= null and then 0 < R.Alias.all.Refs) + then + R.Refs := R.Refs - 1; + Top := Top + 1; + pragma Assert (Stack (Top).Data.Is_Empty); + pragma Assert (Stack (Top).Alias = null); + Stack (Top) := (Outer_Index => Env.Index, + others => <>); + Env.Index := Top; end if; - end Replace_With_Subenv; + -- Else reuse the top stack record, including its map and its + -- unreferenced alias if any. + end Replace_With_Sub; - procedure Set (Container : in Ptr; - Key : in Strings.Ptr; - New_Item : in Types.Mal_Type) is + procedure Replace_With_Sub (Env : in out Ptr; + Outer : in Closure_Ptr'Class) is begin - Container.Ref.all.Data.Include (Key, New_Item); + Finalize (Env); + Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + Top := Top + 1; + pragma Assert (Stack (Top).Data.Is_Empty); + pragma Assert (Stack (Top).Alias = null); + Stack (Top) := (Outer_On_Stack => False, + Outer_Ref => Outer.Ref, + others => <>); + Env.Index := Top; + end Replace_With_Sub; + + procedure Set (Env : in Ptr; + Key : in Symbols.Ptr; + New_Element : in Mal.T) is + begin + Stack (Env.Index).Data.Include (Key, New_Element); end Set; - procedure Set_Binds (Container : in Ptr; - Formals : in Lists.Ptr; - Actuals : in Types.Mal_Type_Array) - is - -- The assertions should be a precondition, but cannot be - -- expressed with a "limited with" view on Types. + function Sub (Outer : in Closure_Ptr'Class) return Ptr is begin - if Formals.Length <= 1 - or else Formals.Element (Formals.Length - 1).S /= Names.Ampersand - then - pragma Assert (Formals.Length = Actuals'Length); - pragma Assert (for all I in 1 .. Formals.Length => - Formals.Element (I).Kind = Types.Kind_Symbol - and then Formals.Element (I).S /= Names.Ampersand); - Increase_Capacity (Container, Formals.Length); - for I in 1 .. Formals.Length loop - Container.Ref.all.Data.Include (Formals.Element (I).S, - Actuals (Actuals'First + I - 1)); - end loop; - else + Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + Top := Top + 1; + pragma Assert (Stack (Top).Data.Is_Empty); + pragma Assert (Stack (Top).Alias = null); + Stack (Top) := (Outer_On_Stack => False, + Outer_Ref => Outer.Ref, + others => <>); + return (Ada.Finalization.Limited_Controlled with Top); + end Sub; + + function Sub (Outer : in Ptr) return Ptr is + R : Stack_Record renames Stack (Outer.Index); + begin + R.Refs := R.Refs + 1; + Top := Top + 1; + pragma Assert (Stack (Top).Data.Is_Empty); + pragma Assert (Stack (Top).Alias = null); + Stack (Top) := (Outer_Index => Outer.Index, + others => <>); + return (Ada.Finalization.Limited_Controlled with Top); + end Sub; + + procedure Unreference (Reference : in out Heap_Access) is + Ref : Heap_Access := Reference; + begin + Reference := null; + loop + exit when Ref = null; + exit when Ref.all.Refs = 0; + Ref.all.Refs := Ref.all.Refs - 1; + exit when 0 < Ref.all.Refs; + exit when Ref.all.Outer = null; -- An alias. Do not free it + -- now, it may be useful for another closure. declare - Len : constant Natural := Formals.Length - 2; + Tmp : Heap_Access := Ref; begin - pragma Assert (Len <= Actuals'Length); - pragma Assert (for all I in 1 .. Len => - Formals.Element (I).Kind = Types.Kind_Symbol - and then Formals.Element (I).S /= Names.Ampersand); - pragma Assert (Formals.Element (Len + 1).Kind = Types.Kind_Symbol); - pragma Assert (Formals.Element (Len + 1).S = Names.Ampersand); - pragma Assert (Formals.Element (Len + 2).Kind = Types.Kind_Symbol); - pragma Assert (Formals.Element (Len + 2).S /= Names.Ampersand); - Increase_Capacity (Container, Len + 1); - for I in 1 .. Len loop - Container.Ref.all.Data.Include - (Formals.Element (I).S, Actuals (Actuals'First + I - 1)); - end loop; - Container.Ref.all.Data.Include - (Formals.Element (Formals.Length).S, - (Types.Kind_List, Atoms.No_Element, - Lists.Alloc (Actuals (Actuals'First + Len .. Actuals'Last)))); + Ref := Ref.all.Outer; + Free (Tmp); + pragma Unreferenced (Tmp); end; - end if; - end Set_Binds; + end loop; + end Unreference; end Environments; diff --git a/ada2/environments.ads b/ada2/environments.ads index c1584be4b9..5ef4561372 100644 --- a/ada2/environments.ads +++ b/ada2/environments.ads @@ -1,54 +1,115 @@ private with Ada.Finalization; -with Lists; -with Strings; -limited with Types; -package Environments is +with Types.Mal; +with Types.Symbols; - type Ptr is tagged private; - -- Any variable must be assigned immediately with one of the two - -- following functions. - function Alloc return Ptr - with Inline; - function Alloc (Outer : in Ptr) return Ptr - with Inline; - -- A hidden invariant ensures this when assertions are enabled. +package Environments with Elaborate_Body is - procedure Increase_Capacity (Container : in Ptr; - Capacity : in Natural) - with Inline; + -- This implementation relies on the fact that the caller only + -- ever references environments in its execution stack. - procedure Replace_With_Subenv (Item : in out Ptr) - with Inline; - -- Equivalent to Item := Alloc (Outer => Item, Capacity), but - -- faster when Item was the last reference to its environment, as - -- the storage and maps are then reused. + -- When a function closure references an environment that the + -- execution leaves behind, a dynamically allocated block is used + -- instead. - procedure Set (Container : in Ptr; - Key : in Strings.Ptr; - New_Item : in Types.Mal_Type) - with Inline; + -- The eval built-in requires REPL (see the implementation of + -- load-file), so we cannot assume that the caller only sees the + -- current environment. + + type Ptr (<>) is tagged limited private; + -- This type is controlled in order count the references to a + -- given environment, even during exception propagation. + -- Since Ptr is limited with a hidden discriminant, any variable + -- must immediately be assigned with one of + -- * Repl (in which case a renaming is probably better), + -- * Copy_Pointer, + -- * Sub (either from a Ptr or from a Closure_Ptr). + -- Usual assignment with reference counting is not provided + -- because we want to enforce the use of the more efficient + -- Replace_With_Sub. - procedure Set_Binds (Container : in Ptr; - Formals : in Lists.Ptr; - Actuals : in Types.Mal_Type_Array); + Repl : constant Ptr; + -- The top environment. - function Get (Container : in Ptr; - Key : in Strings.Ptr) return Types.Mal_Type; + function Copy_Pointer (Env : in Ptr) return Ptr with Inline; + + function Sub (Outer : in Ptr) return Ptr with Inline; + + procedure Replace_With_Sub (Env : in out Ptr) with Inline; + -- Like Env := Sub (Outer => Env); except that Env is finalized + -- *before* the assignement, so its memory may be reused by the + -- new environment. + + procedure Set (Env : in Ptr; + Key : in Types.Symbols.Ptr; + New_Element : in Types.Mal.T) + with Inline; + + function Get (Env : in Ptr; + Key : in Types.Symbols.Ptr) + return Types.Mal.T; Unknown_Key : exception; - -- procedure Dump; + -- Function closures. + + type Closure_Ptr is tagged private; + Null_Closure : constant Closure_Ptr; + + function Sub (Outer : in Closure_Ptr'Class) return Ptr; + + procedure Replace_With_Sub (Env : in out Ptr; + Outer : in Closure_Ptr'Class); + -- Like Env := Sub (Outer => Outer); except that Env is finalized + -- *before* the assignement, so its memory can be reused by the + -- new environment. This is important for tail call optimization. + + function New_Closure (Env : in Ptr'Class) return Closure_Ptr; + -- The class-wide argument does not make much sense, but avoids + -- the compiler wondering on which type is should dispatch. private - type Env_Record; - type Env_Access is access Env_Record; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Env_Access := null; + -- There must be a reference level so that functions may keep + -- track of their initial environment, and another one for + -- reallocations. The second one is delegated to a predefined Ada + -- container. + + -- MAL maps may be tempting, but we do not want to copy the whole + -- map for each addition or removal. + + -- Some tests seem to show that a hashmap is three times faster + -- than a vector with (key, value) couples. + + -- We allow the null value so that the empty environment in a + -- macro does not trigger an allocation. + + -- 300 for normal tests + -- 7_500 for make ada2 && make MAL_IMPL=ada2 test^mal + -- 150_000 for make ada2 && make perf^ada2 + type Stack_Index is range 0 .. 150_000; + + -- See README for the implementation of reference counting. + + type Ptr is new Ada.Finalization.Limited_Controlled with record + Index : Stack_Index := 0; end record - with Invariant => Ptr.Ref /= null; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr); - -- Predefined equality is fine. + with Invariant => Index in 1 .. Top; + overriding procedure Finalize (Object : in out Ptr) with Inline; + pragma Finalize_Storage_Only (Ptr); + + Top : Stack_Index := 1; + Repl : constant Ptr := (Ada.Finalization.Limited_Controlled with 1); + + type Heap_Record; + type Heap_Access is access Heap_Record; + type Closure_Ptr is new Ada.Finalization.Controlled with record + Ref : Heap_Access := null; + end record; + overriding procedure Adjust (Object : in out Closure_Ptr) with Inline; + overriding procedure Finalize (Object : in out Closure_Ptr) with Inline; + pragma Finalize_Storage_Only (Closure_Ptr); + + Null_Closure : constant Closure_Ptr + := (Ada.Finalization.Controlled with null); end Environments; diff --git a/ada2/lists.adb b/ada2/lists.adb deleted file mode 100644 index 6aed887521..0000000000 --- a/ada2/lists.adb +++ /dev/null @@ -1,95 +0,0 @@ -with Ada.Unchecked_Deallocation; -with Atoms; -with Types; - -package body Lists is - - type List_Record (Last : Positive) is limited record - Data : Types.Mal_Type_Array (1 .. Last); - Refs : Positive; - end record; - -- The invariant for Ptr is: - -- Ptr.Ref = null or else Ptr.First <= Ptr.Ref.all.Last - -- but we cannot express this in the specification because the limited - -- view on Types forbids to define List_Record there. - - procedure Free is new Ada.Unchecked_Deallocation (Object => List_Record, - Name => List_Access); - - ---------------------------------------------------------------------- - - function "=" (Left, Right : in Ptr) return Boolean is - (if Left.Ref = null - then Right.Ref = null - else - -- As strange as it may seem, this assertion fails when - -- running "(= [(list)] (list []))". - -- pragma Assert - -- ((Left.Ref.all.Data (1) = Right.Ref.all.Data (1)) - -- = - -- (Left.Ref.all.Data (1 .. 1) = Right.Ref.all.Data (1 .. 1))); - -- This may be a compiler bug. - Right.Ref /= null - and then Left.Ref.all.Last = Right.Ref.all.Last - and then (for all I in 1 .. Left.Ref.all.Last => - Types."=" (Left.Ref.all.Data (I), - Right.Ref.all.Data (I)))); - - procedure Adjust (Object : in out Ptr) is - begin - if Object.Ref /= null then - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; - end if; - end Adjust; - - function Element (Container : in Ptr; - Index : in Positive) return Types.Mal_Type is - (Container.Ref.all.Data (Index)); - - procedure Finalize (Object : in out Ptr) - is - Refs : Positive; - begin - -- Ensure that we can be called twice in a row (7.6.1(24)). - if Object.Ref /= null then - Refs := Object.Ref.all.Refs; - if 1 < Refs then - Object.Ref.all.Refs := Refs - 1; - Object.Ref := null; - else - -- pragma Assert (Ptr (Object.Ref.all.Id) = Object.Ref); - -- Ptr (Object.Ref.all.Id) := null; - Free (Object.Ref); - end if; - end if; - end Finalize; - - function Length (Source : in Ptr) return Natural is - (if Source.Ref = null then 0 else Source.Ref.all.Last); - - function Alloc (Source : in Types.Mal_Type_Array) return Ptr is - (if Source'Length = 0 - then Empty_List - else (Ada.Finalization.Controlled with - Ref => new List_Record'(Data => Source, - Last => Source'Length, - Refs => 1))); - - function Alloc (Length : in Natural) return Ptr is - (if Length = 0 - then Empty_List - else (Ada.Finalization.Controlled with - Ref => new List_Record' - (Data => (1 .. Length => (Types.Kind_Nil, Atoms.No_Element)), - Last => Length, - Refs => 1))); - - procedure Replace_Element (Source : in Ptr; - Index : in Positive; - New_Value : in Types.Mal_Type) is - begin - pragma Assert (Source.Ref.all.Refs = 1); - Source.Ref.all.Data (Index) := New_Value; - end Replace_Element; - -end Lists; diff --git a/ada2/lists.ads b/ada2/lists.ads deleted file mode 100644 index 28c76cfe39..0000000000 --- a/ada2/lists.ads +++ /dev/null @@ -1,47 +0,0 @@ -private with Ada.Finalization; -limited with Types; - -package Lists is - - -- A pointer to an array of Mal_Type elements. It differs from - -- Ada.Containers.Vectors because assignment give another pointer - -- to the same storage and does not copy contents. - - type Ptr is tagged private; - Empty_List : constant Ptr; -- The default value. - - function Length (Source : in Ptr) return Natural - with Inline; - - function Element (Container : in Ptr; - Index : in Positive) return Types.Mal_Type - with Inline, Pre => Index <= Container.Length; - - function Alloc (Length : in Natural) return Ptr - with Inline; - -- All elements are Nil, the default value for Mal_Type. - - function Alloc (Source : in Types.Mal_Type_Array) return Ptr - with Inline; - - procedure Replace_Element (Source : in Ptr; - Index : in Positive; - New_Value : in Types.Mal_Type) - with Inline, Pre => Index <= Source.Length; - -- An assertion checks that Source is the only reference to its - -- storage. - -private - - type List_Record; - type List_Access is access List_Record; - type Ptr is new Ada.Finalization.Controlled with record - Ref : List_Access := null; - end record; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - overriding function "=" (Left, Right : in Ptr) return Boolean; - - Empty_List : constant Ptr := (Ada.Finalization.Controlled with Ref => null); - -end Lists; diff --git a/ada2/maps.adb b/ada2/maps.adb deleted file mode 100644 index f1e1eacc85..0000000000 --- a/ada2/maps.adb +++ /dev/null @@ -1,160 +0,0 @@ -with Ada.Containers.Hashed_Maps; -with Ada.Unchecked_Deallocation; -with Strings; -with Types; - -package body Maps is - - function Hash (Item : in Types.Mal_Type) return Ada.Containers.Hash_Type - with Inline, Pre => Item.Kind in Types.Kind_String | Types.Kind_Keyword; - - package Hashed_Maps is new Ada.Containers.Hashed_Maps - (Key_Type => Types.Mal_Type, - Element_Type => Types.Mal_Type, - Hash => Hash, - Equivalent_Keys => Types."=", - "=" => Types."="); - - type Map_Record is limited record - Data : Hashed_Maps.Map; - Refs : Positive; - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Object => Map_Record, - Name => Map_Access); - - use type Ada.Containers.Count_Type; - - ---------------------------------------------------------------------- - - function "=" (Left, Right : in Ptr) return Boolean is - (Hashed_Maps."=" (Left.Ref.all.Data, Right.Ref.all.Data)); - - procedure Adjust (Object : in out Ptr) is - begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; - end Adjust; - - function Assoc (Container : in Ptr; - Pairs : in Types.Mal_Type_Array) return Ptr - is - pragma Assert (Pairs'Length mod 2 = 0); - Pair_Count : constant Ada.Containers.Count_Type - := Ada.Containers.Count_Type (Pairs'Length) / 2; - Result : Ptr; - begin - Result.Ref.all.Data.Reserve_Capacity (Pair_Count - + Container.Ref.all.Data.Length); - Result.Ref.all.Data.Assign (Container.Ref.all.Data); - for I in 0 .. Pairs'Length / 2 - 1 loop - pragma Assert (Pairs (Pairs'First + 2 * I).Kind in Types.Kind_String - | Types.Kind_Keyword); - Result.Ref.all.Data.Include (Pairs (Pairs'First + 2 * I), - Pairs (Pairs'First + 2 * I + 1)); - end loop; - return Result; - end Assoc; - - function Contains (Container : in Ptr; - Key : in Types.Mal_Type) return Boolean is - (Container.Ref.all.Data.Contains (Key)); - - function Dissoc (Source : in Ptr; - Keys : in Types.Mal_Type_Array) return Ptr - is - Result : Ptr; - begin - Result.Ref.all.Data.Assign (Source.Ref.all.Data); - for I in Keys'Range loop - pragma Assert (Keys (I).Kind in Types.Kind_String - | Types.Kind_Keyword); - Result.Ref.all.Data.Exclude (Keys (I)); - end loop; - return Result; - end Dissoc; - - procedure Finalize (Object : in out Ptr) - is - Refs : Positive; - begin - -- Finalize may be called twice. - if Object.Ref /= null then - Refs := Object.Ref.all.Refs; - if 1 < Refs then - Object.Ref.all.Refs := Refs - 1; - Object.Ref := null; - else - Free (Object.Ref); - end if; - end if; - end Finalize; - - procedure Iterate - (Container : in Ptr; - Process : not null access procedure (Key : in Types.Mal_Type; - Element : in Types.Mal_Type)) is - begin - for Position in Container.Ref.all.Data.Iterate loop - Process.all (Hashed_Maps.Key (Position), - Hashed_Maps.Element (Position)); - end loop; - end Iterate; - - function Get (Container : in Ptr; - Key : in Types.Mal_Type) return Types.Mal_Type - is - Position : Hashed_Maps.Cursor; - begin - Position := Container.Ref.all.Data.Find (Key); - if Hashed_Maps.Has_Element (Position) then - return Hashed_Maps.Element (Position); - end if; - raise Unknown_Key with "'" & Key.S.Deref & "' not found"; - end Get; - - function Hash (Item : in Types.Mal_Type) return Ada.Containers.Hash_Type is - (Item.S.Hash); - - function Hash_Map (Pairs : in Types.Mal_Type_Array) return Ptr - is - pragma Assert (Pairs'Length mod 2 = 0); - Pair_Count : constant Ada.Containers.Count_Type - := Ada.Containers.Count_Type (Pairs'Length) / 2; - Result : Ptr; - begin - Result.Ref.all.Data.Reserve_Capacity (Pair_Count); - for I in 0 .. Pairs'Length / 2 - 1 loop - pragma Assert (Pairs (Pairs'First + 2 * I).Kind in Types.Kind_String - | Types.Kind_Keyword); - Result.Ref.all.Data.Include (Pairs (Pairs'First + 2 * I), - Pairs (Pairs'First + 2 * I + 1)); - end loop; - return Result; - end Hash_Map; - - procedure Initialize (Object : in out Ptr) is - begin - Object.Ref := new Map_Record'(Data => Hashed_Maps.Empty_Map, - Refs => 1); - end Initialize; - - function Length (Container : in Ptr) return Natural - is (Natural (Container.Ref.all.Data.Length)); - - function Map (Container : in Ptr; - F : not null access function (X : in Types.Mal_Type) - return Types.Mal_Type) - return Ptr - is - Result : Ptr; - begin - Result.Ref.all.Data.Assign (Container.Ref.all.Data); - -- Ensure the invariants before calling F, in case it raises exceptions. - for Position in Result.Ref.all.Data.Iterate loop - Result.Ref.all.Data.Replace_Element - (Position, F.all (Hashed_Maps.Element (Position))); - end loop; - return Result; - end Map; - -end Maps; diff --git a/ada2/maps.ads b/ada2/maps.ads deleted file mode 100644 index 5bf81efa14..0000000000 --- a/ada2/maps.ads +++ /dev/null @@ -1,59 +0,0 @@ -private with Ada.Finalization; -with Lists; -limited with Types; - -package Maps is - - -- A pointer to an Ada.Containers.Hashed_Maps.Map of - -- Types.Mal_Type. Keys must be Strings or Keywords. We can - -- probably not state this with a limited with, so this will - -- become an assertion. - - type Ptr is tagged private; - -- The default value is empty. - - function Length (Container : in Ptr) return Natural - with Inline; - - function Hash_Map (Pairs : in Types.Mal_Type_Array) return Ptr; - - function Assoc (Container : in Ptr; - Pairs : in Types.Mal_Type_Array) return Ptr; - - function Dissoc (Source : in Ptr; - Keys : in Types.Mal_Type_Array) return Ptr; - - function Map (Container : in Ptr; - F : not null access function (X : in Types.Mal_Type) - return Types.Mal_Type) - return Ptr; - - procedure Iterate - (Container : in Ptr; - Process : not null access procedure (Key : in Types.Mal_Type; - Element : in Types.Mal_Type)) - with Inline; - - function Contains (Container : in Ptr; - Key : in Types.Mal_Type) return Boolean - with Inline; - - function Get (Container : in Ptr; - Key : in Types.Mal_Type) return Types.Mal_Type - with Inline; - Unknown_Key : exception; - -private - - type Map_Record; - type Map_Access is access Map_Record; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Map_Access := null; - end record - with Invariant => Ptr.Ref /= null; - overriding procedure Initialize (Object : in out Ptr) with Inline; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - overriding function "=" (Left, Right : in Ptr) return Boolean with Inline; - -end Maps; diff --git a/ada2/names.ads b/ada2/names.ads deleted file mode 100644 index 40613a160c..0000000000 --- a/ada2/names.ads +++ /dev/null @@ -1,87 +0,0 @@ -with Strings; use Strings; - -package Names is - - -- Symbols known at compile time are allocated at program - -- start, in order to avoid repeated allocations and - -- deallocations during each Read and /Eval/Print cycle. The - -- reference is kept so each usage does not trigger a search in - -- the global hash map. - - Ada2 : constant Ptr := Alloc ("ada2"); - Ampersand : constant Ptr := Alloc ("&"); - Apply : constant Ptr := Alloc ("apply"); - Argv : constant Ptr := Alloc ("*ARGV*"); - Assoc : constant Ptr := Alloc ("assoc"); - Asterisk : constant Ptr := Alloc ("*"); - Atom : constant Ptr := Alloc ("atom"); - Catch : constant Ptr := Alloc ("catch*"); - Concat : constant Ptr := Alloc ("concat"); - Conj : constant Ptr := Alloc ("conj"); - Cons : constant Ptr := Alloc ("cons"); - Contains : constant Ptr := Alloc ("contains?"); - Count : constant Ptr := Alloc ("count"); - Def : constant Ptr := Alloc ("def!"); - Defmacro : constant Ptr := Alloc ("defmacro!"); - Deref : constant Ptr := Alloc ("deref"); - Dissoc : constant Ptr := Alloc ("dissoc"); - Equals : constant Ptr := Alloc ("="); - Eval : constant Ptr := Alloc ("eval"); - First : constant Ptr := Alloc ("first"); - Fn : constant Ptr := Alloc ("fn*"); - Get : constant Ptr := Alloc ("get"); - Greater_Equal : constant Ptr := Alloc (">="); - Greater_Than : constant Ptr := Alloc (">"); - Hash_Map : constant Ptr := Alloc ("hash-map"); - Host_Language : constant Ptr := Alloc ("*host-language*"); - Is_Atom : constant Ptr := Alloc ("atom?"); - Is_Empty : constant Ptr := Alloc ("empty?"); - Is_False : constant Ptr := Alloc ("false?"); - Is_Keyword : constant Ptr := Alloc ("keyword?"); - Is_List : constant Ptr := Alloc ("list?"); - Is_Map : constant Ptr := Alloc ("map?"); - Is_Nil : constant Ptr := Alloc ("nil?"); - Is_Sequential : constant Ptr := Alloc ("sequential?"); - Is_String : constant Ptr := Alloc ("string?"); - Is_Symbol : constant Ptr := Alloc ("symbol?"); - Is_True : constant Ptr := Alloc ("true?"); - Is_Vector : constant Ptr := Alloc ("vector?"); - Keys : constant Ptr := Alloc ("keys"); - Keyword : constant Ptr := Alloc ("keyword"); - Less_Equal : constant Ptr := Alloc ("<="); - Less_Than : constant Ptr := Alloc ("<"); - Let : constant Ptr := Alloc ("let*"); - List : constant Ptr := Alloc ("list"); - Macroexpand : constant Ptr := Alloc ("macroexpand"); - Mal_Do : constant Ptr := Alloc ("do"); - Mal_If : constant Ptr := Alloc ("if"); - Map : constant Ptr := Alloc ("map"); - Meta : constant Ptr := Alloc ("meta"); - Minus : constant Ptr := Alloc ("-"); - Nth : constant Ptr := Alloc ("nth"); - Plus : constant Ptr := Alloc ("+"); - Pr_Str : constant Ptr := Alloc ("pr-str"); - Println : constant Ptr := Alloc ("println"); - Prn : constant Ptr := Alloc ("prn"); - Quasiquote : constant Ptr := Alloc ("quasiquote"); - Quote : constant Ptr := Alloc ("quote"); - Read_String : constant Ptr := Alloc ("read-string"); - Readline : constant Ptr := Alloc ("readline"); - Reset : constant Ptr := Alloc ("reset!"); - Rest : constant Ptr := Alloc ("rest"); - Seq : constant Ptr := Alloc ("seq"); - Slash : constant Ptr := Alloc ("/"); - Slurp : constant Ptr := Alloc ("slurp"); - Splice_Unquote : constant Ptr := Alloc ("splice-unquote"); - Str : constant Ptr := Alloc ("str"); - Swap : constant Ptr := Alloc ("swap!"); - Symbol : constant Ptr := Alloc ("symbol"); - Throw : constant Ptr := Alloc ("throw"); - Time_Ms : constant Ptr := Alloc ("time-ms"); - Try : constant Ptr := Alloc ("try*"); - Unquote : constant Ptr := Alloc ("unquote"); - Vals : constant Ptr := Alloc ("vals"); - Vector : constant Ptr := Alloc ("vector"); - With_Meta : constant Ptr := Alloc ("with-meta"); - -end Names; diff --git a/ada2/printer.adb b/ada2/printer.adb index 6b21c4a7ef..e768f05bbd 100644 --- a/ada2/printer.adb +++ b/ada2/printer.adb @@ -1,55 +1,48 @@ with Ada.Characters.Latin_1; -with Atoms; -with Lists; -with Maps; -with Strings; + +with Types.Atoms; +with Types.Functions; +with Types.Lists; +with Types.Maps; package body Printer is use Ada.Strings.Unbounded; use Types; - procedure Print_Form (Buffer : in out Unbounded_String; - Ast : in Mal_Type; - Print_Readably : in Boolean); - procedure Print_List (Buffer : in out Unbounded_String; - List : in Lists.Ptr; - Print_Readably : in Boolean) - with Inline; - procedure Print_Function (Buffer : in out Unbounded_String; - Formals : in Lists.Ptr; - Expression : in Atoms.Ptr; - Print_Readably : in Boolean) - with Inline; - procedure Print_Map (Buffer : in out Unbounded_String; - Map : in Maps.Ptr; - Print_Readably : in Boolean) - with Inline; + procedure Print_Form (Buffer : in out Unbounded_String; + Ast : in Mal.T; + Readably : in Boolean); + procedure Print_List (Buffer : in out Unbounded_String; + List : in Lists.Ptr; + Readably : in Boolean) with Inline; + procedure Print_Function (Buffer : in out Unbounded_String; + Fn : in Functions.Ptr; + Readably : in Boolean) with Inline; + procedure Print_Map (Buffer : in out Unbounded_String; + Map : in Maps.Ptr; + Readably : in Boolean) with Inline; ---------------------------------------------------------------------- - procedure Print_Form (Buffer : in out Unbounded_String; - Ast : in Mal_Type; - Print_Readably : in Boolean) is + procedure Print_Form (Buffer : in out Unbounded_String; + Ast : in Mal.T; + Readably : in Boolean) is begin case Ast.Kind is - when Kind_Nil => Append (Buffer, "nil"); - when Kind_Boolean => - if Ast.Boolean_Value then + if Ast.Ada_Boolean then Append (Buffer, "true"); else Append (Buffer, "false"); end if; - when Kind_Symbol => - Append (Buffer, Ast.S.Deref); - + Append (Buffer, Ast.Symbol.To_String); when Kind_Number => declare - Img : constant String := Integer'Image (Ast.Integer_Value); + Img : constant String := Ast.Ada_Number'Img; F : Positive := Img'First; begin if Img (F) = ' ' then @@ -57,121 +50,113 @@ package body Printer is end if; Append (Buffer, Img (F .. Img'Last)); end; - when Kind_Keyword => Append (Buffer, ':'); - Append (Buffer, Ast.S.Deref); - + Append (Buffer, Ast.S); when Kind_String => - if Print_Readably then + if Readably then Append (Buffer, '"'); - for C of Ast.S.Deref loop - case C is - when '"' | '\' => - Append (Buffer, '\'); - Append (Buffer, C); - when Ada.Characters.Latin_1.LF => - Append (Buffer, "\n"); - when others => - Append (Buffer, C); - end case; - end loop; + declare + C : Character; + begin + for I in 1 .. Length (Ast.S) loop + C := Element (Ast.S, I); + case C is + when '"' | '\' => + Append (Buffer, '\'); + Append (Buffer, C); + when Ada.Characters.Latin_1.LF => + Append (Buffer, "\n"); + when others => + Append (Buffer, C); + end case; + end loop; + end; Append (Buffer, '"'); else - Append (Buffer, Ast.S.Deref); + Append (Buffer, Ast.S); end if; - when Kind_List => Append (Buffer, '('); - Print_List (Buffer, Ast.L, Print_Readably); + Print_List (Buffer, Ast.L, Readably); Append (Buffer, ')'); when Kind_Vector => Append (Buffer, '['); - Print_List (Buffer, Ast.L, Print_Readably); + Print_List (Buffer, Ast.L, Readably); Append (Buffer, ']'); - when Kind_Map => - Print_Map (Buffer, Ast.Map, Print_Readably); - - when Kind_Native => + Print_Map (Buffer, Ast.Map, Readably); + when Kind_Builtin | Kind_Builtin_With_Meta => Append (Buffer, "#"); when Kind_Function => Append (Buffer, "#'); when Kind_Macro => Append (Buffer, "#'); - when Kind_Atom => Append (Buffer, "(atom "); - Print_Form (Buffer, Ast.Reference.Deref, Print_Readably); + Print_Form (Buffer, Atoms.Deref (Mal.T_Array'(1 => Ast)), + Readably); Append (Buffer, ')'); - end case; end Print_Form; - procedure Print_Function (Buffer : in out Unbounded_String; - Formals : in Lists.Ptr; - Expression : in Atoms.Ptr; - Print_Readably : in Boolean) is + procedure Print_Function (Buffer : in out Unbounded_String; + Fn : in Functions.Ptr; + Readably : in Boolean) is begin - if 0 < Formals.Length then - Print_List (Buffer, Formals, Print_Readably); - Append (Buffer, " -> "); - Print_Form (Buffer, Expression.Deref, Print_Readably); - end if; + Print_List (Buffer, Fn.Formals, Readably); + Append (Buffer, " -> "); + Print_Form (Buffer, Fn.Expression, Readably); end Print_Function; - procedure Print_List (Buffer : in out Unbounded_String; - List : in Lists.Ptr; - Print_Readably : in Boolean) is + procedure Print_List (Buffer : in out Unbounded_String; + List : in Lists.Ptr; + Readably : in Boolean) is begin - if 1 <= List.Length then - Print_Form (Buffer, List.Element (1), Print_Readably); + if 0 < List.Length then + Print_Form (Buffer, List.Element (1), Readably); for I in 2 .. List.Length loop Append (Buffer, ' '); - Print_Form (Buffer, List.Element (I), Print_Readably); + Print_Form (Buffer, List.Element (I), Readably); end loop; end if; end Print_List; - procedure Print_Map (Buffer : in out Unbounded_String; - Map : in Maps.Ptr; - Print_Readably : in Boolean) - is + procedure Print_Map (Buffer : in out Unbounded_String; + Map : in Maps.Ptr; + Readably : in Boolean) is Is_First : Boolean := True; - procedure Process (Key : in Mal_Type; - Element : in Mal_Type); - procedure Process (Key : in Mal_Type; - Element : in Mal_Type) is + procedure Process (Key : in Mal.T; + Element : in Mal.T); + procedure Iterate is new Maps.Iterate (Process); + procedure Process (Key : in Mal.T; + Element : in Mal.T) is begin if Is_First then Is_First := False; else Append (Buffer, ' '); end if; - Print_Form (Buffer, Key, Print_Readably); + Print_Form (Buffer, Key, Readably); Append (Buffer, ' '); - Print_Form (Buffer, Element, Print_Readably); + Print_Form (Buffer, Element, Readably); end Process; begin Append (Buffer, '{'); - Map.Iterate (Process'Access); + Iterate (Map); Append (Buffer, '}'); end Print_Map; - function Pr_Str (Ast : in Mal_Type; - Print_Readably : in Boolean := True) - return Unbounded_String - is - Result : Unbounded_String; + function Pr_Str (Ast : in Mal.T; + Readably : in Boolean := True) return Unbounded_String is begin - Print_Form (Result, Ast, Print_Readably); - return Result; + return Buffer : Unbounded_String do + Print_Form (Buffer, Ast, Readably); + end return; end Pr_Str; end Printer; diff --git a/ada2/printer.ads b/ada2/printer.ads index 5071a801f7..219f682dae 100644 --- a/ada2/printer.ads +++ b/ada2/printer.ads @@ -1,12 +1,11 @@ with Ada.Strings.Unbounded; -with Types; -package Printer is +with Types.Mal; - pragma Elaborate_Body; +package Printer with Elaborate_Body is - function Pr_Str (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) + function Pr_Str (Ast : in Types.Mal.T; + Readably : in Boolean := True) return Ada.Strings.Unbounded.Unbounded_String; end Printer; diff --git a/ada2/reader.adb b/ada2/reader.adb index d72af57749..36521eef21 100644 --- a/ada2/reader.adb +++ b/ada2/reader.adb @@ -1,18 +1,19 @@ with Ada.Characters.Latin_1; -with Atoms; -with Lists; -with Maps; -with Names; -with Strings; +with Ada.Strings.Unbounded; + +with Types.Lists; +with Types.Maps; +with Types.Symbols.Names; package body Reader is - function Read_Str (Source : in String) return Types.Mal_Type - is + use Types; + + function Read_Str (Source : in String) return Mal.T is First : Positive; Last : Natural := Source'First - 1; - function Read_Form return Types.Mal_Type; + function Read_Form return Mal.T; procedure Find_Next_Token; -- Search next token from index Last + 1. @@ -24,10 +25,9 @@ package body Reader is -- Read_Atom has been merged into the same case/switch -- statement, for clarity and efficiency. - function Read_List (Ending : in Character) return Types.Mal_Type_Array - with Inline; - function Read_Quote (Symbol : in Strings.Ptr) return Types.Mal_Type + function Read_List (Ending : in Character) return Mal.T_Array with Inline; + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline; ---------------------------------------------------------------------- procedure Find_Next_Token @@ -61,7 +61,7 @@ package body Reader is Last := First + 1; loop if Source'Last < Last then - raise Reader_Error with "expected '""'"; + raise Reader_Error with "unbalanced '""'"; end if; exit when Source (Last) = '"'; if Source (Last) = '\' then @@ -96,126 +96,108 @@ package body Reader is end loop; end Find_Next_Token; - function Read_Form return Types.Mal_Type - is - use Types; + function Read_Form return Mal.T is + use Ada.Strings.Unbounded; begin case Source (First) is - when '(' => - return (Kind_List, Atoms.No_Element, - Lists.Alloc (Read_List (')'))); + return Lists.List (Read_List (')')); when '[' => - return (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Read_List (']'))); + return Lists.Vector (Read_List (']')); when '{' => - return (Kind_Map, Atoms.No_Element, - Maps.Hash_Map (Read_List ('}'))); - + return Maps.Hash_Map (Read_List ('}')); when '"' => declare - Buffer : String (First .. Last); - B_Last : Natural := Buffer'First - 1; + Buffer : Unbounded_String; I : Positive := First + 1; begin - while I <= Last - 1 loop - if Source (I) /= '\' or else I = Last - 1 then - B_Last := B_Last + 1; - Buffer (B_Last) := Source (I); + while I < Last loop + if Source (I) /= '\' or else I + 1 = Last then + Append (Buffer, Source (I)); else case Source (I + 1) is when '\' | '"' => - B_Last := B_Last + 1; - Buffer (B_Last) := Source (I + 1); I := I + 1; + Append (Buffer, Source (I)); when 'n' => - B_Last := B_Last + 1; - Buffer (B_Last) := Ada.Characters.Latin_1.LF; I := I + 1; + Append (Buffer, Ada.Characters.Latin_1.LF); when others => - B_Last := B_Last + 1; - Buffer (B_Last) := Source (I); + Append (Buffer, Source (I)); end case; end if; I := I + 1; end loop; - return (Kind_String, Atoms.No_Element, - Strings.Alloc (Buffer (Buffer'First .. B_Last))); + return (Kind_String, Buffer); end; when ':' => - return (Kind_Keyword, Atoms.No_Element, - Strings.Alloc (Source (First + 1 .. Last))); - + return (Kind_Keyword, + To_Unbounded_String (Source (First + 1 .. Last))); when '-' => if First < Last and then (for all C of Source (First + 1 .. Last) => C in '0' .. '9') then - return (Kind_Number, Atoms.No_Element, - Integer'Value (Source (First .. Last))); + return (Kind_Number, Integer'Value (Source (First .. Last))); else - return (Kind_Symbol, Atoms.No_Element, - Strings.Alloc (Source (First .. Last))); + return (Kind_Symbol, + Symbols.Constructor (Source (First .. Last))); end if; when '0' .. '9' => - return (Kind_Number, Atoms.No_Element, - Integer'Value (Source (First .. Last))); - + return (Kind_Number, Integer'Value (Source (First .. Last))); when ''' => - return Read_Quote (Names.Quote); + return Read_Quote (Symbols.Names.Quote); when '`' => - return Read_Quote (Names.Quasiquote); + return Read_Quote (Symbols.Names.Quasiquote); when '@' => - return Read_Quote (Names.Deref); + return Read_Quote (Symbols.Names.Deref); when '~' => if First = Last then - return Read_Quote (Names.Unquote); + return Read_Quote (Symbols.Names.Unquote); else - return Read_Quote (Names.Splice_Unquote); + return Read_Quote (Symbols.Names.Splice_Unquote); end if; when '^' => - return Result : constant Mal_Type - := (Kind_List, Atoms.No_Element, Lists.Alloc (3)) - do - Result.L.Replace_Element (1, Mal_Type' - (Kind_Symbol, Atoms.No_Element, Names.With_Meta)); + declare + Args : Mal.T_Array (1 .. 3); + begin + Args (1) := (Kind_Symbol, Symbols.Names.With_Meta); Find_Next_Token; if Source'Last < First then raise Reader_Error with "Unfinished 'with-meta'"; end if; - Result.L.Replace_Element (3, Read_Form); + Args (3) := Read_Form; Find_Next_Token; if Source'Last < First then raise Reader_Error with "Unfinished 'with-meta'"; end if; - Result.L.Replace_Element (2, Read_Form); - end return; - + Args (2) := Read_Form; + return Lists.List (Args); + end; when others => - if Source (First .. Last) = "nil" then - return (Kind_Nil, Atoms.No_Element); + if Source (First .. Last) = "false" then + return (Kind_Boolean, False); + elsif Source (First .. Last) = "nil" then + return Mal.Nil; elsif Source (First .. Last) = "true" then - return (Kind_Boolean, Atoms.No_Element, True); - elsif Source (First .. Last) = "false" then - return (Kind_Boolean, Atoms.No_Element, False); + return (Kind_Boolean, True); else - return (Kind_Symbol, Atoms.No_Element, - Strings.Alloc (Source (First .. Last))); + return (Kind_Symbol, + Symbols.Constructor (Source (First .. Last))); end if; end case; end Read_Form; - function Read_List (Ending : in Character) return Types.Mal_Type_Array - is + function Read_List (Ending : in Character) return Mal.T_Array is -- Using big arrays on the stack is faster than doing -- repeated dynamic reallocations. - Buffer : Types.Mal_Type_Array (First + 1 .. Source'Last); + Buffer : Mal.T_Array (First + 1 .. Source'Last); B_Last : Natural := Buffer'First - 1; begin loop Find_Next_Token; if Source'Last < First then - raise Reader_Error with "expected '" & Ending & "'"; + raise Reader_Error with "unbalanced '" & Ending & "'"; end if; exit when Source (First) = Ending; B_Last := B_Last + 1; @@ -224,19 +206,13 @@ package body Reader is return Buffer (Buffer'First .. B_Last); end Read_List; - function Read_Quote (Symbol : in Strings.Ptr) return Types.Mal_Type is - use Types; - Result : constant Mal_Type - := (Kind_List, Atoms.No_Element, Lists.Alloc (2)); + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is begin - Result.L.Replace_Element (1, - Mal_Type'(Kind_Symbol, Atoms.No_Element, Symbol)); Find_Next_Token; if Source'Last < First then - raise Reader_Error with "Unfinished '" & Symbol.Deref & "'"; + raise Reader_Error with "Unfinished '" & Symbol.To_String & "'"; end if; - Result.L.Replace_Element (2, Read_Form); - return Result; + return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form)); end Read_Quote; ---------------------------------------------------------------------- @@ -244,7 +220,7 @@ package body Reader is begin Find_Next_Token; if Source'Last < First then - raise Empty_Source; + raise Empty_Source with "attempting to read an empty line"; end if; return Read_Form; end Read_Str; diff --git a/ada2/reader.ads b/ada2/reader.ads index d5e85b36bd..0d9d185b91 100644 --- a/ada2/reader.ads +++ b/ada2/reader.ads @@ -1,10 +1,8 @@ -with Types; +with Types.Mal; -package Reader is +package Reader with Elaborate_Body is - pragma Elaborate_Body; - - function Read_Str (Source : in String) return Types.Mal_Type; + function Read_Str (Source : in String) return Types.Mal.T; Empty_Source : exception; Reader_Error : exception; diff --git a/ada2/step0_repl.adb b/ada2/step0_repl.adb index bf8d73ab17..f318731343 100644 --- a/ada2/step0_repl.adb +++ b/ada2/step0_repl.adb @@ -1,57 +1,48 @@ -with Ada.Exceptions; with Ada.Text_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Interfaces.C.Strings; procedure Step0_Repl is - function Read (Source : in String) return String - is (Source); + subtype Mal_Type is String; - function Eval (Ast : in String) return String - is (Ast); + function Read (Source : in String) return Mal_Type + is (Source); - function Print (Ast : in String) return String - is (Ast); + function Eval (Ast : in Mal_Type) return Mal_Type + is (Ast); + + function Print (Ast : in Mal_Type) return String + is (Ast); function Rep (Source : in String) return String - is (Print (Eval (Read (Source)))); + is (Print (Eval (Read (Source)))) with Inline; procedure Interactive_Loop; ---------------------------------------------------------------------- - procedure Interactive_Loop - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); end if; Free (C_Line); Ada.Text_IO.Put_Line (Rep (Line)); - exception - when E : others => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. end; end loop; Ada.Text_IO.New_Line; diff --git a/ada2/step1_read_print.adb b/ada2/step1_read_print.adb index b68f1197c2..06f49a3005 100644 --- a/ada2/step1_read_print.adb +++ b/ada2/step1_read_print.adb @@ -1,56 +1,50 @@ with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; +with Interfaces.C.Strings; + with Printer; with Reader; -with Types; +with Types.Mal; procedure Step1_Read_Print is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Ast : in Types.Mal_Type) return Types.Mal_Type - is (Ast); + function Eval (Ast : in Mal.T) return Mal.T + is (Ast); - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; - function Rep (Source : in String) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source)))) - with Inline; + function Rep (Source : in String) return ASU.Unbounded_String + is (Print (Eval (Read (Source)))) with Inline; - procedure Interactive_Loop - with Inline; + procedure Interactive_Loop; ---------------------------------------------------------------------- - procedure Interactive_Loop - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -60,9 +54,9 @@ procedure Step1_Read_Print is exception when Reader.Empty_Source => null; - when E : others => + when E : Reader.Reader_Error => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; diff --git a/ada2/step2_eval.adb b/ada2/step2_eval.adb index 3c72b8c7d9..e37de05889 100644 --- a/ada2/step2_eval.adb +++ b/ada2/step2_eval.adb @@ -3,142 +3,122 @@ with Ada.Exceptions; with Ada.Strings.Hash; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; -with Lists; +with Interfaces.C.Strings; + with Printer; with Reader; -with Types; +with Types.Builtins; +with Types.Lists; +with Types.Mal; +with Types.Maps; procedure Step2_Eval is + package ASU renames Ada.Strings.Unbounded; + use Types; + package Environments is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, - Element_Type => Types.Native_Function_Access, + Element_Type => Builtins.Ptr, Hash => Ada.Strings.Hash, Equivalent_Keys => "=", - "=" => Types."="); + "=" => Builtins."="); + Unknown_Symbol : exception; - function Read (Source : in String) return Types.Mal_Type + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Ast : in Types.Mal_Type; - Env : in out Environments.Map) return Types.Mal_Type; - Unable_To_Call : exception; - Unknown_Symbol : exception; + function Eval (Ast : in Mal.T; + Env : in Environments.Map) return Mal.T; - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; - function Rep (Source : in String; - Env : in out Environments.Map) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + function Rep (Source : in String; + Env : in Environments.Map) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - procedure Interactive_Loop (Repl : in out Environments.Map) - with Inline; + procedure Interactive_Loop (Repl : in Environments.Map); generic with function Ada_Operator (Left, Right : in Integer) return Integer; - function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) - return Types.Mal_Type; + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; + + function Eval_Elements is new Lists.Generic_Eval (Environments.Map, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Map, Eval); ---------------------------------------------------------------------- - function Eval (Ast : in Types.Mal_Type; - Env : in out Environments.Map) return Types.Mal_Type - is - use Types; + function Eval (Ast : in Mal.T; + Env : in Environments.Map) return Mal.T is + First : Mal.T; begin + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => declare - S : constant String := Ast.S.Deref; + S : constant String := Ast.Symbol.To_String; C : constant Environments.Cursor := Env.Find (S); begin if Environments.Has_Element (C) then - return (Kind_Native, Atoms.No_Element, - Environments.Element (C)); + return (Kind_Builtin, Environments.Element (C)); else + -- The predefined message does not pass tests. raise Unknown_Symbol with "'" & S & "' not found"; end if; end; - when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - - -- Apply phase - declare - First : constant Mal_Type := Eval (Ast.L.Element (1), Env); - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); - end loop; - case First.Kind is - when Kind_Native => - return First.Native.all (Args); - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + First := Eval (Ast.L.Element (1), Env); + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Builtin.all (Args); + end; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) - return Types.Mal_Type - is (Types.Kind_Number, Atoms.No_Element, - Ada_Operator (Args (Args'First).Integer_Value, - Args (Args'First + 1).Integer_Value)); - - procedure Interactive_Loop (Repl : in out Environments.Map) - is + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T + is (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number, + Args (Args'Last).Ada_Number)); - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Map) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -148,9 +128,10 @@ procedure Step2_Eval is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Unknown_Symbol => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; @@ -165,11 +146,10 @@ procedure Step2_Eval is Repl : Environments.Map; begin - Repl.Include ("+", Addition 'Unrestricted_Access); - Repl.Include ("-", Subtraction'Unrestricted_Access); - Repl.Include ("*", Product 'Unrestricted_Access); - Repl.Include ("/", Division 'Unrestricted_Access); + Repl.Insert ("+", Addition 'Unrestricted_Access); + Repl.Insert ("-", Subtraction'Unrestricted_Access); + Repl.Insert ("*", Product 'Unrestricted_Access); + Repl.Insert ("/", Division 'Unrestricted_Access); Interactive_Loop (Repl); - pragma Unreferenced (Repl); end Step2_Eval; diff --git a/ada2/step3_env.adb b/ada2/step3_env.adb index b19d660b6a..224248e0ac 100644 --- a/ada2/step3_env.adb +++ b/ada2/step3_env.adb @@ -1,163 +1,149 @@ with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step3_Env is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T; - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + procedure Interactive_Loop (Repl : in Environments.Ptr); generic with function Ada_Operator (Left, Right : in Integer) return Integer; - function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) - return Types.Mal_Type; + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; + + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); ---------------------------------------------------------------------- - function Eval (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - First : Mal_Type; + function Eval (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T is + First : Mal.T; begin + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); - end return; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - New_Env : constant Environments.Ptr - := Environments.Alloc (Outer => Env); - begin - New_Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - New_Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), New_Env)); - end loop; - return Eval (Ast.L.Element (3), New_Env); - end; + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + New_Env : constant Environments.Ptr := Env.Sub; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + New_Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), New_Env)); + end loop; + return Eval (Ast.L.Element (3), New_Env); + end; + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); - end loop; - case First.Kind is - when Kind_Native => - return First.Native.all (Args); - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Builtin.all (Args); + end; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - function Generic_Mal_Operator (Args : in Types.Mal_Type_Array) - return Types.Mal_Type - is (Types.Kind_Number, Atoms.No_Element, - Ada_Operator (Args (Args'First).Integer_Value, - Args (Args'First + 1).Integer_Value)); - - procedure Interactive_Loop (Repl : in Environments.Ptr) - is + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T + is (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number, + Args (Args'Last).Ada_Number)); - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -167,9 +153,10 @@ procedure Step3_Env is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; @@ -182,18 +169,14 @@ procedure Step3_Env is function Product is new Generic_Mal_Operator ("*"); function Division is new Generic_Mal_Operator ("/"); - use Types; - Repl : constant Environments.Ptr := Environments.Alloc; + function S (Source : in String) return Symbols.Ptr + renames Symbols.Constructor; + Repl : Environments.Ptr renames Environments.Repl; begin - Repl.Increase_Capacity (4); - Repl.Set (Names.Plus, Types.Mal_Type' - (Types.Kind_Native, Atoms.No_Element, Addition'Unrestricted_Access)); - Repl.Set (Names.Minus, Types.Mal_Type' - (Types.Kind_Native, Atoms.No_Element, Subtraction'Unrestricted_Access)); - Repl.Set (Names.Asterisk, Types.Mal_Type' - (Types.Kind_Native, Atoms.No_Element, Product'Unrestricted_Access)); - Repl.Set (Names.Slash, Types.Mal_Type' - (Types.Kind_Native, Atoms.No_Element, Division'Unrestricted_Access)); + Repl.Set (S ("+"), (Kind_Builtin, Addition 'Unrestricted_Access)); + Repl.Set (S ("-"), (Kind_Builtin, Subtraction'Unrestricted_Access)); + Repl.Set (S ("*"), (Kind_Builtin, Product 'Unrestricted_Access)); + Repl.Set (S ("/"), (Kind_Builtin, Division 'Unrestricted_Access)); Interactive_Loop (Repl); end Step3_Env; diff --git a/ada2/step4_if_fn_do.adb b/ada2/step4_if_fn_do.adb index c554a6ec12..b4ed93798c 100644 --- a/ada2/step4_if_fn_do.adb +++ b/ada2/step4_if_fn_do.adb @@ -1,208 +1,197 @@ with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step4_If_Fn_Do is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T; - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr); - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - First : Mal_Type; + function Eval (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T is + First : Mal.T; begin + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); - end return; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - return Eval (Ast.L.Element (Ast.L.Length), Env); - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - return Eval (Ast.L.Element (3), Env); - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - return Eval (Ast.L.Element (4), Env); - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - New_Env : constant Environments.Ptr - := Environments.Alloc (Outer => Env); - begin - New_Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - New_Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), New_Env)); - end loop; - return Eval (Ast.L.Element (3), New_Env); - end; - end if; - end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. First := Eval (First, Env); - for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); end loop; - case First.Kind is - when Kind_Native => - return First.Native.all (Args); - when Kind_Function => - declare - New_Env : constant Environments.Ptr - := Environments.Alloc (Outer => First.Environment); - begin - New_Env.Set_Binds (First.Formals, Args); - return Eval (First.Expression.Deref, New_Env); - end; - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + return Eval (Ast.L.Element (Ast.L.Length), Env); + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then + return Eval (Ast.L.Element (3), Env); + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + return Eval (Ast.L.Element (4), Env); + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; + end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + New_Env : constant Environments.Ptr := Env.Sub; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + New_Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), New_Env)); + end loop; + return Eval (Ast.L.Element (3), New_Env); + end; + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); + end if; + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Builtin.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + New_Env : constant Environments.Ptr + := First.Function_Value.Closure.Sub; + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + First.Function_Value.Set_Binds (New_Env, Args); + return Eval (First.Function_Value.Expression, New_Env); + end; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -212,9 +201,10 @@ procedure Step4_If_Fn_Do is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; @@ -222,10 +212,12 @@ procedure Step4_If_Fn_Do is ---------------------------------------------------------------------- - Repl : constant Environments.Ptr := Environments.Alloc; + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); Interactive_Loop (Repl); end Step4_If_Fn_Do; diff --git a/ada2/step5_tco.adb b/ada2/step5_tco.adb index 3838b6b3ad..1a865079cf 100644 --- a/ada2/step5_tco.adb +++ b/ada2/step5_tco.adb @@ -1,211 +1,206 @@ with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step5_Tco is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T; - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; + + procedure Interactive_Loop (Repl : in Environments.Ptr); - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - Ast : Types.Mal_Type := Rec_Ast; - Env : Environments.Ptr := Rec_Env; - First : Mal_Type; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Mal.T := Ast0; + Env : Environments.Ptr := Env0.Copy_Pointer; + First : Mal.T; begin - <> + <> + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); - end return; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - Ast := Ast.L.Element (Ast.L.Length); - goto Restart; - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - Ast := Ast.L.Element (3); - goto Restart; - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - Ast := Ast.L.Element (4); - goto Restart; - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - begin - Env.Replace_With_Subenv; - Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), Env)); - end loop; + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then Ast := Ast.L.Element (3); goto Restart; - end; + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + Env.Replace_With_Sub; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); - end loop; - case First.Kind is - when Kind_Native => - return First.Native.all (Args); - when Kind_Function => - Env := Environments.Alloc (Outer => First.Environment); - Env.Set_Binds (First.Formals, Args); - Ast := First.Expression.Deref; + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Builtin.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + Env.Replace_With_Sub (First.Function_Value.Closure); + First.Function_Value.Set_Binds (Env, Args); + Ast := First.Function_Value.Expression; goto Restart; - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + end; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -215,9 +210,10 @@ procedure Step5_Tco is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; @@ -225,10 +221,12 @@ procedure Step5_Tco is ---------------------------------------------------------------------- - Repl : constant Environments.Ptr := Environments.Alloc; + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); Interactive_Loop (Repl); end Step5_Tco; diff --git a/ada2/step6_file.adb b/ada2/step6_file.adb index 7670995b73..85795d77bb 100644 --- a/ada2/step6_file.adb +++ b/ada2/step6_file.adb @@ -2,214 +2,206 @@ with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step6_File is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T; - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + procedure Interactive_Loop (Repl : in Environments.Ptr); - -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); - -- Eval, with a profile compatible with Native_Function_Access. - function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - Ast : Types.Mal_Type := Rec_Ast; - Env : Environments.Ptr := Rec_Env; - First : Mal_Type; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Mal.T := Ast0; + Env : Environments.Ptr := Env0.Copy_Pointer; + First : Mal.T; begin - <> + <> + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); - end return; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - Ast := Ast.L.Element (Ast.L.Length); - goto Restart; - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - Ast := Ast.L.Element (3); - goto Restart; - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - Ast := Ast.L.Element (4); - goto Restart; - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - begin - Env.Replace_With_Subenv; - Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), Env)); - end loop; + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then Ast := Ast.L.Element (3); goto Restart; - end; + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + Env.Replace_With_Sub; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); - end loop; - case First.Kind is - when Kind_Native => - return First.Native.all (Args); - when Kind_Function => - Env := Environments.Alloc (Outer => First.Environment); - Env.Set_Binds (First.Formals, Args); - Ast := First.Expression.Deref; + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Builtin.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + Env.Replace_With_Sub (First.Function_Value.Closure); + First.Function_Value.Set_Binds (Env, Args); + Ast := First.Function_Value.Expression; goto Restart; - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + end; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -219,9 +211,10 @@ procedure Step6_File is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; @@ -229,32 +222,27 @@ procedure Step6_File is ---------------------------------------------------------------------- - use Types; - Argv : Mal_Type (Kind_List); - Repl : constant Environments.Ptr := Environments.Alloc; - function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is - (Eval (Args (Args'First), Repl)); + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; + use Ada.Command_Line; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, - Eval_Native'Unrestricted_Access)); - - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - Discard (Eval (Read ("(def! load-file (fn* (f) " - & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); - - if Ada.Command_Line.Argument_Count = 0 then - Repl.Set (Names.Argv, Argv); + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); + declare + Args : Mal.T_Array (2 .. Argument_Count); + begin + for I in Args'Range loop + Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + end loop; + Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + end; + if Argument_Count = 0 then Interactive_Loop (Repl); else - Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); - for I in 2 .. Ada.Command_Line.Argument_Count loop - Argv.L.Replace_Element (I - 1, - Mal_Type'(Kind_String, Atoms.No_Element, - Strings.Alloc (Ada.Command_Line.Argument (I)))); - end loop; - Repl.Set (Names.Argv, Argv); - Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) - & """)"), Repl)); + Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); end if; end Step6_File; diff --git a/ada2/step7_quote.adb b/ada2/step7_quote.adb index 9286169aee..c2b5438ff8 100644 --- a/ada2/step7_quote.adb +++ b/ada2/step7_quote.adb @@ -1,236 +1,227 @@ -with Ada.Containers.Vectors; with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; use type Types.Kind_Type; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step7_Quote is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T; function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - with Inline; + Env : in Environments.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. + -- Mergeing quote and quasiquote into eval with a flag triggering + -- a different behaviour as done for macros in step8 would improve + -- the performances significantly, but Kanaka finds that it breaks + -- too much the step structure shared by all implementations. - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; - - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; + procedure Interactive_Loop (Repl : in Environments.Ptr); - -- Eval, with a profile compatible with Native_Function_Access. - function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); - package Mal_Type_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, - Element_Type => Types.Mal_Type, - "=" => Types."="); + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - Ast : Types.Mal_Type := Rec_Ast; - Env : Environments.Ptr := Rec_Env; - First : Mal_Type; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Mal.T := Ast0; + Env : Environments.Ptr := Env0.Copy_Pointer; + First : Mal.T; begin - <> + <> + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); - end return; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - Ast := Ast.L.Element (Ast.L.Length); - goto Restart; - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - Ast := Ast.L.Element (3); - goto Restart; - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - Ast := Ast.L.Element (4); - goto Restart; - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - begin - Env.Replace_With_Subenv; - Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), Env)); - end loop; + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then Ast := Ast.L.Element (3); goto Restart; - end; - - elsif First.S = Names.Quote then - pragma Assert (Ast.L.Length = 2); - return Ast.L.Element (2); - - elsif First.S = Names.Quasiquote then - pragma Assert (Ast.L.Length = 2); - return Quasiquote (Ast.L.Element (2), Env); + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; + end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + Env.Replace_With_Sub; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + elsif First.Symbol = Symbols.Names.Quasiquote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quasiquote: expects 1 argument"; + end if; + return Quasiquote (Ast.L.Element (2), Env); + elsif First.Symbol = Symbols.Names.Quote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quote: expects 1 argument"; end if; + return Ast.L.Element (2); + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); - end loop; - case First.Kind is - when Kind_Native => - return First.Native.all (Args); - when Kind_Function => - Env := Environments.Alloc (Outer => First.Environment); - Env.Set_Binds (First.Formals, Args); - Ast := First.Expression.Deref; + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + return First.Builtin.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.L.Element (I), Env); + end loop; + Env.Replace_With_Sub (First.Function_Value.Closure); + First.Function_Value.Set_Binds (Env, Args); + Ast := First.Function_Value.Expression; goto Restart; - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + end; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -240,87 +231,77 @@ procedure Step7_Quote is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; end Interactive_Loop; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T is (case Ast.Kind is - when Types.Kind_Vector => - (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Types.Kind_List => + when Kind_Vector => Quasiquote (Ast.L, Env), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Kind_List => (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Types.Kind_Symbol - and then Ast.L.Element (1).S = Names.Unquote + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote then Eval (Ast.L.Element (2), Env) - else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + else Quasiquote (Ast.L, Env)), when others => Ast); function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - is - use Types; - Buffer : Mal_Type_Vectors.Vector; - Elt : Mal_Type; + Env : in Environments.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); begin - for I in 1 .. List.Length loop - Elt := List.Element (I); - if Elt.Kind in Kind_List | Kind_Vector - and then 0 < Elt.L.Length - and then Elt.L.Element (1).Kind = Kind_Symbol - and then Elt.L.Element (1).S = Names.Splice_Unquote + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote then - pragma Assert (Elt.L.Length = 2); - Elt := Eval (Elt.L.Element (2), Env); - pragma Assert (Elt.Kind = Kind_List); - for J in 1 .. Elt.L.Length loop - Buffer.Append (Elt.L.Element (J)); - end loop; + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 argument"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; else - Buffer.Append (Quasiquote (Elt, Env)); + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); end if; end loop; - return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do - for I in 1 .. R.Length loop - R.Replace_Element (I, Buffer.Element (I)); - end loop; - end return; + return Lists.Concat (R); end Quasiquote; ---------------------------------------------------------------------- - use Types; - Argv : Mal_Type (Kind_List); - Repl : constant Environments.Ptr := Environments.Alloc; - function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is - (Eval (Args (Args'First), Repl)); + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; + use Ada.Command_Line; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, - Eval_Native'Unrestricted_Access)); - - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - Discard (Eval (Read ("(def! load-file (fn* (f) " - & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); - - if Ada.Command_Line.Argument_Count = 0 then - Repl.Set (Names.Argv, Argv); + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); + declare + Args : Mal.T_Array (2 .. Argument_Count); + begin + for I in Args'Range loop + Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + end loop; + Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + end; + if Argument_Count = 0 then Interactive_Loop (Repl); else - Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); - for I in 2 .. Ada.Command_Line.Argument_Count loop - Argv.L.Replace_Element (I - 1, - Mal_Type'(Kind_String, Atoms.No_Element, - Strings.Alloc (Ada.Command_Line.Argument (I)))); - end loop; - Repl.Set (Names.Argv, Argv); - Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) - & """)"), Repl)); + Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); end if; end Step7_Quote; diff --git a/ada2/step8_macros.adb b/ada2/step8_macros.adb index c85b0a3222..c73935b16d 100644 --- a/ada2/step8_macros.adb +++ b/ada2/step8_macros.adb @@ -1,282 +1,262 @@ -with Ada.Containers.Vectors; with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; use type Types.Kind_Type; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step8_Macros is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T; function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - with Inline; + Env : in Environments.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. + -- Mergeing quote and quasiquote into eval with a flag triggering + -- a different behaviour as done for macros in step8 would improve + -- the performances significantly, but Kanaka finds that it breaks + -- too much the step structure shared by all implementations. - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; - - -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; + procedure Interactive_Loop (Repl : in Environments.Ptr); - -- Eval, with a profile compatible with Native_Function_Access. - function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); - package Mal_Type_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, - Element_Type => Types.Mal_Type, - "=" => Types."="); + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - Ast : Types.Mal_Type := Rec_Ast; - Env : Environments.Ptr := Rec_Env; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Mal.T := Ast0; + Env : Environments.Ptr := Env0.Copy_Pointer; Macroexpanding : Boolean := False; - First : Mal_Type; + First : Mal.T; begin - <> + <> + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Defmacro then + if Ast.L.Length /= 3 then + raise Argument_Error with "defmacro!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "defmacro!: arg 1 must be a symbol"; + end if; + declare + F : constant Mal.T := Eval (Ast.L.Element (3), Env); + begin + if F.Kind /= Kind_Function then + raise Argument_Error with "defmacro!: expects a function"; + end if; + return R : constant Mal.T := F.Function_Value.New_Macro do + Env.Set (Ast.L.Element (2).Symbol, R); end return; - - elsif First.S = Names.Defmacro then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - F : constant Mal_Type := Eval (Ast.L.Element (3), Env); - pragma Assert (F.Kind = Kind_Function); - begin - return R : constant Mal_Type - := (Kind => Kind_Macro, - Meta => Atoms.No_Element, - Mac_Formals => F.Formals, - Mac_Expression => F.Expression) - do - Env.Set (Ast.L.Element (2).S, R); - end return; - end; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - Ast := Ast.L.Element (Ast.L.Length); - goto Restart; - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - Ast := Ast.L.Element (3); - goto Restart; - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - Ast := Ast.L.Element (4); - goto Restart; - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - begin - Env.Replace_With_Subenv; - Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), Env)); - end loop; + end; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then Ast := Ast.L.Element (3); goto Restart; - end; - - elsif First.S = Names.Macroexpand then - pragma Assert (Ast.L.Length = 2); - Macroexpanding := True; - Ast := Ast.L.Element (2); + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; + end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + Env.Replace_With_Sub; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); goto Restart; - - elsif First.S = Names.Quote then - pragma Assert (Ast.L.Length = 2); - return Ast.L.Element (2); - - elsif First.S = Names.Quasiquote then - pragma Assert (Ast.L.Length = 2); - return Quasiquote (Ast.L.Element (2), Env); + end; + elsif First.Symbol = Symbols.Names.Macroexpand then + if Ast.L.Length /= 2 then + raise Argument_Error with "macroexpand: expects 1 argument"; + end if; + Macroexpanding := True; + Ast := Ast.L.Element (2); + goto Restart; + elsif First.Symbol = Symbols.Names.Quasiquote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quasiquote: expects 1 argument"; + end if; + return Quasiquote (Ast.L.Element (2), Env); + elsif First.Symbol = Symbols.Names.Quote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quote: expects 1 argument"; end if; + return Ast.L.Element (2); + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - case First.Kind is - - when Kind_Native => + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - return First.Native.all (Args); - - when Kind_Function => + return First.Builtin.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env := Environments.Alloc (Outer => First.Environment); - Env.Set_Binds (First.Formals, Args); - Ast := First.Expression.Deref; + Env.Replace_With_Sub (First.Function_Value.Closure); + First.Function_Value.Set_Binds (Env, Args); + Ast := First.Function_Value.Expression; goto Restart; - - when Kind_Macro => - for I in Args'Range loop - Args (I) := Ast.L.Element (I); - end loop; - declare - New_Env : constant Environments.Ptr - := Environments.Alloc (Outer => Env); - begin - New_Env.Set_Binds (First.Mac_Formals, Args); - Ast := Eval (First.Mac_Expression.Deref, New_Env); - end; - if Macroexpanding then - return Ast; - end if; - goto Restart; - - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + end; + when Kind_Macro => + declare + New_Env : constant Environments.Ptr := Env.Sub; + begin + First.Function_Value.Set_Binds (New_Env, Ast.L); + Ast := Eval (First.Function_Value.Expression, New_Env); + end; + if Macroexpanding then + return Ast; + end if; + goto Restart; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -286,98 +266,88 @@ procedure Step8_Macros is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; end Interactive_Loop; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T is (case Ast.Kind is - when Types.Kind_Vector => - (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Types.Kind_List => + when Kind_Vector => Quasiquote (Ast.L, Env), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Kind_List => (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Types.Kind_Symbol - and then Ast.L.Element (1).S = Names.Unquote + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote then Eval (Ast.L.Element (2), Env) - else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + else Quasiquote (Ast.L, Env)), when others => Ast); function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - is - use Types; - Buffer : Mal_Type_Vectors.Vector; - Elt : Mal_Type; + Env : in Environments.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); begin - for I in 1 .. List.Length loop - Elt := List.Element (I); - if Elt.Kind in Kind_List | Kind_Vector - and then 0 < Elt.L.Length - and then Elt.L.Element (1).Kind = Kind_Symbol - and then Elt.L.Element (1).S = Names.Splice_Unquote + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote then - pragma Assert (Elt.L.Length = 2); - Elt := Eval (Elt.L.Element (2), Env); - pragma Assert (Elt.Kind = Kind_List); - for J in 1 .. Elt.L.Length loop - Buffer.Append (Elt.L.Element (J)); - end loop; + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 argument"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; else - Buffer.Append (Quasiquote (Elt, Env)); + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); end if; end loop; - return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do - for I in 1 .. R.Length loop - R.Replace_Element (I, Buffer.Element (I)); - end loop; - end return; + return Lists.Concat (R); end Quasiquote; ---------------------------------------------------------------------- - use Types; - Argv : Mal_Type (Kind_List); - Repl : constant Environments.Ptr := Environments.Alloc; - function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is - (Eval (Args (Args'First), Repl)); + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" + & "(defmacro! cond (fn* (& xs)" + & " (if (> (count xs) 0)" + & " (list 'if (first xs)" + & " (if (> (count xs) 1) (nth xs 1)" + & " (throw ""odd number of forms to cond""))" + & " (cons 'cond (rest (rest xs)))))))" + & "(defmacro! or (fn* (& xs)" + & " (if (empty? xs) nil" + & " (if (= 1 (count xs)) (first xs)" + & " `(let* (or_FIXME ~(first xs))" + & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; + use Ada.Command_Line; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, - Eval_Native'Unrestricted_Access)); - - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - Discard (Eval (Read ("(def! load-file (fn* (f) " - & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); - Discard (Eval (Read ("(defmacro! cond " - & "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) " - & "(if (> (count xs) 1) (nth xs 1) " - & "(throw ""odd number of forms to cond"")) " - & "(cons 'cond (rest (rest xs)))))))"), Repl)); - Discard (Eval (Read ("(defmacro! or (fn* (& xs) " - & "(if (empty? xs) nil " - & "(if (= 1 (count xs)) (first xs) " - & "`(let* (or_FIXME ~(first xs)) " - & "(if or_FIXME or_FIXME " - & "(or ~@(rest xs))))))))"), Repl)); - - if Ada.Command_Line.Argument_Count = 0 then - Repl.Set (Names.Argv, Argv); + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); + declare + Args : Mal.T_Array (2 .. Argument_Count); + begin + for I in Args'Range loop + Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + end loop; + Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + end; + if Argument_Count = 0 then Interactive_Loop (Repl); else - Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); - for I in 2 .. Ada.Command_Line.Argument_Count loop - Argv.L.Replace_Element (I - 1, - Mal_Type'(Kind_String, Atoms.No_Element, - Strings.Alloc (Ada.Command_Line.Argument (I)))); - end loop; - Repl.Set (Names.Argv, Argv); - Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) - & """)"), Repl)); + Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); end if; end Step8_Macros; diff --git a/ada2/step9_try.adb b/ada2/step9_try.adb index 6651b5ba30..33ba83923d 100644 --- a/ada2/step9_try.adb +++ b/ada2/step9_try.adb @@ -1,310 +1,303 @@ -with Ada.Containers.Vectors; with Ada.Command_Line; -with Ada.Exceptions; use type Ada.Exceptions.Exception_Id; +with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; use type Types.Kind_Type; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure Step9_Try is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T; function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - with Inline; + Env : in Environments.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. + -- Mergeing quote and quasiquote into eval with a flag triggering + -- a different behaviour as done for macros in step8 would improve + -- the performances significantly, but Kanaka finds that it breaks + -- too much the step structure shared by all implementations. - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + procedure Interactive_Loop (Repl : in Environments.Ptr); - -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; - - -- Eval, with a profile compatible with Native_Function_Access. - function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); - package Mal_Type_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, - Element_Type => Types.Mal_Type, - "=" => Types."="); + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - Ast : Types.Mal_Type := Rec_Ast; - Env : Environments.Ptr := Rec_Env; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Mal.T := Ast0; + Env : Environments.Ptr := Env0.Copy_Pointer; Macroexpanding : Boolean := False; - First : Mal_Type; + First : Mal.T; begin - <> + <> + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Defmacro then + if Ast.L.Length /= 3 then + raise Argument_Error with "defmacro!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "defmacro!: arg 1 must be a symbol"; + end if; + declare + F : constant Mal.T := Eval (Ast.L.Element (3), Env); + begin + if F.Kind /= Kind_Function then + raise Argument_Error with "defmacro!: expects a function"; + end if; + return R : constant Mal.T := F.Function_Value.New_Macro do + Env.Set (Ast.L.Element (2).Symbol, R); end return; - - elsif First.S = Names.Defmacro then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - F : constant Mal_Type := Eval (Ast.L.Element (3), Env); - pragma Assert (F.Kind = Kind_Function); - begin - return R : constant Mal_Type - := (Kind => Kind_Macro, - Meta => Atoms.No_Element, - Mac_Formals => F.Formals, - Mac_Expression => F.Expression) - do - Env.Set (Ast.L.Element (2).S, R); - end return; - end; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - Ast := Ast.L.Element (Ast.L.Length); - goto Restart; - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - Ast := Ast.L.Element (3); - goto Restart; - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - Ast := Ast.L.Element (4); - goto Restart; - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - begin - Env.Replace_With_Subenv; - Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), Env)); - end loop; + end; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then Ast := Ast.L.Element (3); goto Restart; - end; - - elsif First.S = Names.Macroexpand then - pragma Assert (Ast.L.Length = 2); - Macroexpanding := True; + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; + end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + Env.Replace_With_Sub; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + elsif First.Symbol = Symbols.Names.Macroexpand then + if Ast.L.Length /= 2 then + raise Argument_Error with "macroexpand: expects 1 argument"; + end if; + Macroexpanding := True; + Ast := Ast.L.Element (2); + goto Restart; + elsif First.Symbol = Symbols.Names.Quasiquote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quasiquote: expects 1 argument"; + end if; + return Quasiquote (Ast.L.Element (2), Env); + elsif First.Symbol = Symbols.Names.Quote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quote: expects 1 argument"; + end if; + return Ast.L.Element (2); + elsif First.Symbol = Symbols.Names.Try then + if Ast.L.Length = 2 then Ast := Ast.L.Element (2); goto Restart; - - elsif First.S = Names.Quote then - pragma Assert (Ast.L.Length = 2); - return Ast.L.Element (2); - - elsif First.S = Names.Quasiquote then - pragma Assert (Ast.L.Length = 2); - return Quasiquote (Ast.L.Element (2), Env); - - elsif First.S = Names.Try then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (3).Kind = Kind_List); - A3 : constant Lists.Ptr := Ast.L.Element (3).L; - pragma Assert (A3.Length = 3); - pragma Assert (A3.Element (1).Kind = Kind_Symbol); - pragma Assert (A3.Element (1).S = Names.Catch); - pragma Assert (A3.Element (2).Kind = Kind_Symbol); + elsif Ast.L.Length /= 3 then + raise Argument_Error with "try*: expects 1 or 2 arguments"; + elsif Ast.L.Element (3).Kind /= Kind_List then + raise Argument_Error with "try*: argument 2 must be a list"; + end if; + declare + A3 : constant Lists.Ptr := Ast.L.Element (3).L; + begin + if A3.Length /= 3 then + raise Argument_Error with "try*: arg 2 must have 3 elements"; + elsif A3.Element (1).Kind /= Kind_Symbol + or else A3.Element (1).Symbol /= Symbols.Names.Catch + then + raise Argument_Error with "try*: arg 2 must be a catch*"; + elsif A3.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "catch*: expects a symbol"; + end if; begin return Eval (Ast.L.Element (2), Env); exception - when E : others => - Env.Replace_With_Subenv; - if Ada.Exceptions.Exception_Identity (E) - = Core.Exception_Throwed'Identity - then - Env.Set (A3.Element (2).S, Core.Last_Exception); - Core.Last_Exception := (Kind_Nil, Atoms.No_Element); - else - Env.Set (A3.Element (2).S, Mal_Type' - (Kind_String, Atoms.No_Element, Strings.Alloc - (Ada.Exceptions.Exception_Message (E)))); - end if; + when E : Reader.Empty_Source | Argument_Error + | Reader.Reader_Error | Environments.Unknown_Key => + Env.Replace_With_Sub; + Env.Set (A3.Element (2).Symbol, + Mal.T'(Kind_String, ASU.To_Unbounded_String + (Ada.Exceptions.Exception_Message (E)))); Ast := A3.Element (3); goto Restart; + when Core.Exception_Throwed => + Env.Replace_With_Sub; + Env.Set (A3.Element (2).Symbol, Core.Last_Exception); + Core.Last_Exception := Mal.Nil; + Ast := A3.Element (3); + goto Restart; + -- Other exceptions are unexpected. end; - end if; + end; + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - case First.Kind is - - when Kind_Native => + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - return First.Native.all (Args); - - when Kind_Function => + return First.Builtin.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env := Environments.Alloc (Outer => First.Environment); - Env.Set_Binds (First.Formals, Args); - Ast := First.Expression.Deref; - goto Restart; - - when Kind_Macro => - for I in Args'Range loop - Args (I) := Ast.L.Element (I); - end loop; - declare - New_Env : constant Environments.Ptr - := Environments.Alloc (Outer => Env); - begin - New_Env.Set_Binds (First.Mac_Formals, Args); - Ast := Eval (First.Mac_Expression.Deref, New_Env); - end; - if Macroexpanding then - return Ast; - end if; + Env.Replace_With_Sub (First.Function_Value.Closure); + First.Function_Value.Set_Binds (Env, Args); + Ast := First.Function_Value.Expression; goto Restart; - - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + end; + when Kind_Macro => + declare + New_Env : constant Environments.Ptr := Env.Sub; + begin + First.Function_Value.Set_Binds (New_Env, Ast.L); + Ast := Eval (First.Function_Value.Expression, New_Env); + end; + if Macroexpanding then + return Ast; + end if; + goto Restart; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -314,98 +307,92 @@ procedure Step9_Try is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + when Core.Exception_Throwed => + Ada.Text_IO.Put ("User exception: "); + Ada.Text_IO.Unbounded_IO.Put_Line (Print (Core.Last_Exception)); + Core.Last_Exception := Mal.Nil; + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; end Interactive_Loop; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T is (case Ast.Kind is - when Types.Kind_Vector => - (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Types.Kind_List => + when Kind_Vector => Quasiquote (Ast.L, Env), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Kind_List => (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Types.Kind_Symbol - and then Ast.L.Element (1).S = Names.Unquote + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote then Eval (Ast.L.Element (2), Env) - else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + else Quasiquote (Ast.L, Env)), when others => Ast); function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - is - use Types; - Buffer : Mal_Type_Vectors.Vector; - Elt : Mal_Type; + Env : in Environments.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); begin - for I in 1 .. List.Length loop - Elt := List.Element (I); - if Elt.Kind in Kind_List | Kind_Vector - and then 0 < Elt.L.Length - and then Elt.L.Element (1).Kind = Kind_Symbol - and then Elt.L.Element (1).S = Names.Splice_Unquote + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote then - pragma Assert (Elt.L.Length = 2); - Elt := Eval (Elt.L.Element (2), Env); - pragma Assert (Elt.Kind = Kind_List); - for J in 1 .. Elt.L.Length loop - Buffer.Append (Elt.L.Element (J)); - end loop; + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 argument"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; else - Buffer.Append (Quasiquote (Elt, Env)); + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); end if; end loop; - return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do - for I in 1 .. R.Length loop - R.Replace_Element (I, Buffer.Element (I)); - end loop; - end return; + return Lists.Concat (R); end Quasiquote; ---------------------------------------------------------------------- - use Types; - Argv : Mal_Type (Kind_List); - Repl : constant Environments.Ptr := Environments.Alloc; - function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is - (Eval (Args (Args'First), Repl)); + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" + & "(defmacro! cond (fn* (& xs)" + & " (if (> (count xs) 0)" + & " (list 'if (first xs)" + & " (if (> (count xs) 1) (nth xs 1)" + & " (throw ""odd number of forms to cond""))" + & " (cons 'cond (rest (rest xs)))))))" + & "(defmacro! or (fn* (& xs)" + & " (if (empty? xs) nil" + & " (if (= 1 (count xs)) (first xs)" + & " `(let* (or_FIXME ~(first xs))" + & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; + use Ada.Command_Line; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, - Eval_Native'Unrestricted_Access)); - - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - Discard (Eval (Read ("(def! load-file (fn* (f) " - & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); - Discard (Eval (Read ("(defmacro! cond " - & "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) " - & "(if (> (count xs) 1) (nth xs 1) " - & "(throw ""odd number of forms to cond"")) " - & "(cons 'cond (rest (rest xs)))))))"), Repl)); - Discard (Eval (Read ("(defmacro! or (fn* (& xs) " - & "(if (empty? xs) nil " - & "(if (= 1 (count xs)) (first xs) " - & "`(let* (or_FIXME ~(first xs)) " - & "(if or_FIXME or_FIXME " - & "(or ~@(rest xs))))))))"), Repl)); - - if Ada.Command_Line.Argument_Count = 0 then - Repl.Set (Names.Argv, Argv); + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); + declare + Args : Mal.T_Array (2 .. Argument_Count); + begin + for I in Args'Range loop + Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + end loop; + Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + end; + if Argument_Count = 0 then Interactive_Loop (Repl); else - Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); - for I in 2 .. Ada.Command_Line.Argument_Count loop - Argv.L.Replace_Element (I - 1, - Mal_Type'(Kind_String, Atoms.No_Element, - Strings.Alloc (Ada.Command_Line.Argument (I)))); - end loop; - Repl.Set (Names.Argv, Argv); - Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) - & """)"), Repl)); + Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); end if; end Step9_Try; diff --git a/ada2/stepa_mal.adb b/ada2/stepa_mal.adb index a695b6e52e..5cbae9b21a 100644 --- a/ada2/stepa_mal.adb +++ b/ada2/stepa_mal.adb @@ -1,310 +1,312 @@ -with Ada.Containers.Vectors; with Ada.Command_Line; -with Ada.Exceptions; use type Ada.Exceptions.Exception_Id; +with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr; -with Atoms; +with Interfaces.C.Strings; + with Core; with Environments; -with Lists; -with Names; with Printer; with Reader; -with Strings; use type Strings.Ptr; -with Types; use type Types.Kind_Type; +with Types.Functions; +with Types.Lists; +with Types.Mal; +with Types.Maps; +with Types.Symbols.Names; procedure StepA_Mal is - function Read (Source : in String) return Types.Mal_Type + package ASU renames Ada.Strings.Unbounded; + use Types; + use type Symbols.Ptr; + + function Read (Source : in String) return Mal.T renames Reader.Read_Str; - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type; - Unable_To_Call : exception; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type; + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T; function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - with Inline; + Env : in Environments.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. + -- Mergeing quote and quasiquote into eval with a flag triggering + -- a different behaviour as done for macros in step8 would improve + -- the performances significantly, but Kanaka finds that it breaks + -- too much the step structure shared by all implementations. - function Print (Ast : in Types.Mal_Type; - Print_Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String + function Print (Ast : in Mal.T; + Readably : in Boolean := True) return ASU.Unbounded_String renames Printer.Pr_Str; function Rep (Source : in String; - Env : in Environments.Ptr) - return Ada.Strings.Unbounded.Unbounded_String - is (Print (Eval (Read (Source), Env))) - with Inline; + Env : in Environments.Ptr) return ASU.Unbounded_String + is (Print (Eval (Read (Source), Env))) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr) - with Inline; + procedure Interactive_Loop (Repl : in Environments.Ptr); - -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Types.Mal_Type) is null; - - -- Eval, with a profile compatible with Native_Function_Access. - function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type; + function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); - package Mal_Type_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, - Element_Type => Types.Mal_Type, - "=" => Types."="); + -- Convenient when the result of eval is of no interest. + procedure Discard (Ast : in Mal.T) is null; ---------------------------------------------------------------------- - function Eval (Rec_Ast : in Types.Mal_Type; - Rec_Env : in Environments.Ptr) return Types.Mal_Type - is - use Types; - Ast : Types.Mal_Type := Rec_Ast; - Env : Environments.Ptr := Rec_Env; + function Eval (Ast0 : in Mal.T; + Env0 : in Environments.Ptr) return Mal.T is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Mal.T := Ast0; + Env : Environments.Ptr := Env0.Copy_Pointer; Macroexpanding : Boolean := False; - First : Mal_Type; + First : Mal.T; begin - <> + <> + -- Ada.Text_IO.New_Line; + -- Ada.Text_IO.Put ("EVAL: "); + -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Environments.Dump_Stack; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native => - return Ast; - when Kind_Symbol => - return Env.Get (Ast.S); - + return Env.Get (Ast.Symbol); when Kind_Map => - declare - function F (X : Mal_Type) return Mal_Type is (Eval (X, Env)); - begin - return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access)); - end; - + return Eval_Elements (Ast.Map, Env); when Kind_Vector => - return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element, - Lists.Alloc (Ast.L.Length)) - do - for I in 1 .. Ast.L.Length loop - R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env)); - end loop; - end return; - + return (Kind_Vector, Eval_Elements (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); - -- Special forms - if First.Kind = Kind_Symbol then - - if First.S = Names.Def then - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).S, R); + if First.Kind /= Kind_Symbol then + -- Evaluate First, in the less frequent case where it is + -- not a symbol. + First := Eval (First, Env); + elsif First.Symbol = Symbols.Names.Def then + if Ast.L.Length /= 3 then + raise Argument_Error with "def!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "def!: arg 1 must be a symbol"; + end if; + return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do + Env.Set (Ast.L.Element (2).Symbol, R); + end return; + elsif First.Symbol = Symbols.Names.Defmacro then + if Ast.L.Length /= 3 then + raise Argument_Error with "defmacro!: expects 2 arguments"; + elsif Ast.L.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "defmacro!: arg 1 must be a symbol"; + end if; + declare + F : constant Mal.T := Eval (Ast.L.Element (3), Env); + begin + if F.Kind /= Kind_Function then + raise Argument_Error with "defmacro!: expects a function"; + end if; + return R : constant Mal.T := F.Function_Value.New_Macro do + Env.Set (Ast.L.Element (2).Symbol, R); end return; - - elsif First.S = Names.Defmacro then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol); - F : constant Mal_Type := Eval (Ast.L.Element (3), Env); - pragma Assert (F.Kind = Kind_Function); - begin - return R : constant Mal_Type - := (Kind => Kind_Macro, - Meta => Atoms.No_Element, - Mac_Formals => F.Formals, - Mac_Expression => F.Expression) - do - Env.Set (Ast.L.Element (2).S, R); - end return; - end; - - elsif First.S = Names.Mal_Do then - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); - end loop; - Ast := Ast.L.Element (Ast.L.Length); - goto Restart; - - elsif First.S = Names.Fn then - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol); - pragma Assert - (Ast.L.Element (2).L.Length < 1 - or else Names.Ampersand /= - Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S); - pragma Assert - (for all I in 1 .. Ast.L.Element (2).L.Length - 2 => - Ast.L.Element (2).L.Element (I).S /= Names.Ampersand); - return (Kind => Kind_Function, - Meta => Atoms.No_Element, - Formals => Ast.L.Element (2).L, - Expression => Atoms.Alloc (Ast.L.Element (3)), - Environment => Env); - - elsif First.S = Names.Mal_If then - declare - pragma Assert (Ast.L.Length in 3 .. 4); - Test : constant Mal_Type := Eval (Ast.L.Element (2), Env); - begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Boolean_Value, - when others => True) - then - Ast := Ast.L.Element (3); - goto Restart; - elsif Ast.L.Length = 3 then - return (Kind_Nil, Atoms.No_Element); - else - Ast := Ast.L.Element (4); - goto Restart; - end if; - end; - - elsif First.S = Names.Let then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert - (Ast.L.Element (2).Kind in Kind_List | Kind_Vector); - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - pragma Assert (Bindings.Length mod 2 = 0); - begin - Env.Replace_With_Subenv; - Env.Increase_Capacity (Bindings.Length / 2); - for I in 1 .. Bindings.Length / 2 loop - pragma Assert - (Bindings.Element (2 * I - 1).Kind = Kind_Symbol); - Env.Set (Bindings.Element (2 * I - 1).S, - Eval (Bindings.Element (2 * I), Env)); - end loop; + end; + elsif First.Symbol = Symbols.Names.Mal_Do then + if Ast.L.Length = 1 then + raise Argument_Error with "do: expects at least 1 argument"; + end if; + for I in 2 .. Ast.L.Length - 1 loop + Discard (Eval (Ast.L.Element (I), Env)); + end loop; + Ast := Ast.L.Element (Ast.L.Length); + goto Restart; + elsif First.Symbol = Symbols.Names.Fn then + if Ast.L.Length /= 3 then + raise Argument_Error with "fn*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "fn*: arg 1 must be a list or vector"; + elsif (for some F in 1 .. Ast.L.Element (2).L.Length => + Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + then + raise Argument_Error with "fn*: arg 2 must contain symbols"; + end if; + return Functions.New_Function (Ast.L.Element (2).L, + Ast.L.Element (3), Env.New_Closure); + elsif First.Symbol = Symbols.Names.Mal_If then + if Ast.L.Length not in 3 .. 4 then + raise Argument_Error with "if: expects 2 or 3 arguments"; + end if; + declare + Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + begin + if (case Test.Kind is + when Kind_Nil => False, + when Kind_Boolean => Test.Ada_Boolean, + when others => True) + then Ast := Ast.L.Element (3); goto Restart; - end; - - elsif First.S = Names.Macroexpand then - pragma Assert (Ast.L.Length = 2); - Macroexpanding := True; + elsif Ast.L.Length = 3 then + return Mal.Nil; + else + Ast := Ast.L.Element (4); + goto Restart; + end if; + end; + elsif First.Symbol = Symbols.Names.Let then + if Ast.L.Length /= 3 then + raise Argument_Error with "let*: expects 3 arguments"; + elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "let*: expects a list or vector"; + end if; + declare + Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + begin + if Bindings.Length mod 2 /= 0 then + raise Argument_Error with "let*: odd number of bindings"; + end if; + Env.Replace_With_Sub; + for I in 1 .. Bindings.Length / 2 loop + if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then + raise Argument_Error with "let*: keys must be symbols"; + end if; + Env.Set (Bindings.Element (2 * I - 1).Symbol, + Eval (Bindings.Element (2 * I), Env)); + end loop; + Ast := Ast.L.Element (3); + goto Restart; + end; + elsif First.Symbol = Symbols.Names.Macroexpand then + if Ast.L.Length /= 2 then + raise Argument_Error with "macroexpand: expects 1 argument"; + end if; + Macroexpanding := True; + Ast := Ast.L.Element (2); + goto Restart; + elsif First.Symbol = Symbols.Names.Quasiquote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quasiquote: expects 1 argument"; + end if; + return Quasiquote (Ast.L.Element (2), Env); + elsif First.Symbol = Symbols.Names.Quote then + if Ast.L.Length /= 2 then + raise Argument_Error with "quote: expects 1 argument"; + end if; + return Ast.L.Element (2); + elsif First.Symbol = Symbols.Names.Try then + if Ast.L.Length = 2 then Ast := Ast.L.Element (2); goto Restart; - - elsif First.S = Names.Quote then - pragma Assert (Ast.L.Length = 2); - return Ast.L.Element (2); - - elsif First.S = Names.Quasiquote then - pragma Assert (Ast.L.Length = 2); - return Quasiquote (Ast.L.Element (2), Env); - - elsif First.S = Names.Try then - declare - pragma Assert (Ast.L.Length = 3); - pragma Assert (Ast.L.Element (3).Kind = Kind_List); - A3 : constant Lists.Ptr := Ast.L.Element (3).L; - pragma Assert (A3.Length = 3); - pragma Assert (A3.Element (1).Kind = Kind_Symbol); - pragma Assert (A3.Element (1).S = Names.Catch); - pragma Assert (A3.Element (2).Kind = Kind_Symbol); + elsif Ast.L.Length /= 3 then + raise Argument_Error with "try*: expects 1 or 2 arguments"; + elsif Ast.L.Element (3).Kind /= Kind_List then + raise Argument_Error with "try*: argument 2 must be a list"; + end if; + declare + A3 : constant Lists.Ptr := Ast.L.Element (3).L; + begin + if A3.Length /= 3 then + raise Argument_Error with "try*: arg 2 must have 3 elements"; + elsif A3.Element (1).Kind /= Kind_Symbol + or else A3.Element (1).Symbol /= Symbols.Names.Catch + then + raise Argument_Error with "try*: arg 2 must be a catch*"; + elsif A3.Element (2).Kind /= Kind_Symbol then + raise Argument_Error with "catch*: expects a symbol"; + end if; begin return Eval (Ast.L.Element (2), Env); exception - when E : others => - Env.Replace_With_Subenv; - if Ada.Exceptions.Exception_Identity (E) - = Core.Exception_Throwed'Identity - then - Env.Set (A3.Element (2).S, Core.Last_Exception); - Core.Last_Exception := (Kind_Nil, Atoms.No_Element); - else - Env.Set (A3.Element (2).S, Mal_Type' - (Kind_String, Atoms.No_Element, Strings.Alloc - (Ada.Exceptions.Exception_Message (E)))); - end if; + when E : Reader.Empty_Source | Argument_Error + | Reader.Reader_Error | Environments.Unknown_Key => + Env.Replace_With_Sub; + Env.Set (A3.Element (2).Symbol, + Mal.T'(Kind_String, ASU.To_Unbounded_String + (Ada.Exceptions.Exception_Message (E)))); Ast := A3.Element (3); goto Restart; + when Core.Exception_Throwed => + Env.Replace_With_Sub; + Env.Set (A3.Element (2).Symbol, Core.Last_Exception); + Core.Last_Exception := Mal.Nil; + Ast := A3.Element (3); + goto Restart; + -- Other exceptions are unexpected. end; - end if; + end; + else + -- Equivalent to First := Eval (First, Env), except that + -- we already know enough to spare a recursive call in + -- this frequent case. + First := Env.Get (First.Symbol); end if; - - -- No special form has been found, attempt to apply the - -- first element to the rest of the list. - declare - Args : Mal_Type_Array (2 .. Ast.L.Length); - begin - First := Eval (First, Env); - case First.Kind is - - when Kind_Native => + -- Apply phase. + case First.Kind is + when Kind_Builtin => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - return First.Native.all (Args); - - when Kind_Function => + return First.Builtin.all (Args); + end; + when Kind_Builtin_With_Meta => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env := Environments.Alloc (Outer => First.Environment); - Env.Set_Binds (First.Formals, Args); - Ast := First.Expression.Deref; - goto Restart; - - when Kind_Macro => + return First.Builtin_With_Meta.Data.all (Args); + end; + when Kind_Function => + declare + Args : Mal.T_Array (2 .. Ast.L.Length); + begin for I in Args'Range loop - Args (I) := Ast.L.Element (I); + Args (I) := Eval (Ast.L.Element (I), Env); end loop; - declare - New_Env : constant Environments.Ptr - := Environments.Alloc (Outer => Env); - begin - New_Env.Set_Binds (First.Mac_Formals, Args); - Ast := Eval (First.Mac_Expression.Deref, New_Env); - end; - if Macroexpanding then - return Ast; - end if; + Env.Replace_With_Sub (First.Function_Value.Closure); + First.Function_Value.Set_Binds (Env, Args); + Ast := First.Function_Value.Expression; goto Restart; - - when others => - raise Unable_To_Call - with Ada.Strings.Unbounded.To_String (Print (First)); - end case; - end; + end; + when Kind_Macro => + declare + New_Env : constant Environments.Ptr := Env.Sub; + begin + First.Function_Value.Set_Binds (New_Env, Ast.L); + Ast := Eval (First.Function_Value.Expression, New_Env); + end; + if Macroexpanding then + return Ast; + end if; + goto Restart; + when others => + raise Argument_Error + with "cannot execute " & ASU.To_String (Print (First)); + end case; + when others => + return Ast; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) - is - - function Readline (Prompt : in Interfaces.C.char_array) - return Interfaces.C.Strings.chars_ptr + procedure Interactive_Loop (Repl : in Environments.Ptr) is + use Interfaces.C, Interfaces.C.Strings; + function Readline (Prompt : in char_array) return chars_ptr with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr) + procedure Add_History (Line : in chars_ptr) with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in Interfaces.C.Strings.chars_ptr) + procedure Free (Line : in chars_ptr) with Import, Convention => C, External_Name => "free"; - - Prompt : constant Interfaces.C.char_array - := Interfaces.C.To_C ("user> "); - C_Line : Interfaces.C.Strings.chars_ptr; + Prompt : constant char_array := To_C ("user> "); + C_Line : chars_ptr; begin loop C_Line := Readline (Prompt); - exit when C_Line = Interfaces.C.Strings.Null_Ptr; + exit when C_Line = Null_Ptr; declare - Line : constant String := Interfaces.C.Strings.Value (C_Line); + Line : constant String := Value (C_Line); begin if Line /= "" then Add_History (C_Line); @@ -314,104 +316,99 @@ procedure StepA_Mal is exception when Reader.Empty_Source => null; - when E : others => + when E : Argument_Error | Reader.Reader_Error + | Environments.Unknown_Key => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- but go on proceeding. + when Core.Exception_Throwed => + Ada.Text_IO.Put ("User exception: "); + Ada.Text_IO.Unbounded_IO.Put_Line (Print (Core.Last_Exception)); + Core.Last_Exception := Mal.Nil; + -- Other exceptions are unexpected. end; end loop; Ada.Text_IO.New_Line; end Interactive_Loop; - function Quasiquote (Ast : in Types.Mal_Type; - Env : in Environments.Ptr) return Types.Mal_Type + function Quasiquote (Ast : in Mal.T; + Env : in Environments.Ptr) return Mal.T is (case Ast.Kind is - when Types.Kind_Vector => - (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Types.Kind_List => + when Kind_Vector => Quasiquote (Ast.L, Env), + -- When the test is updated, replace Kind_List with Kind_Vector. + when Kind_List => (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Types.Kind_Symbol - and then Ast.L.Element (1).S = Names.Unquote + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote then Eval (Ast.L.Element (2), Env) - else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))), + else Quasiquote (Ast.L, Env)), when others => Ast); function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Lists.Ptr - is - use Types; - Buffer : Mal_Type_Vectors.Vector; - Elt : Mal_Type; + Env : in Environments.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); begin - for I in 1 .. List.Length loop - Elt := List.Element (I); - if Elt.Kind in Kind_List | Kind_Vector - and then 0 < Elt.L.Length - and then Elt.L.Element (1).Kind = Kind_Symbol - and then Elt.L.Element (1).S = Names.Splice_Unquote + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote then - pragma Assert (Elt.L.Length = 2); - Elt := Eval (Elt.L.Element (2), Env); - pragma Assert (Elt.Kind = Kind_List); - for J in 1 .. Elt.L.Length loop - Buffer.Append (Elt.L.Element (J)); - end loop; + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 argument"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; else - Buffer.Append (Quasiquote (Elt, Env)); + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); end if; end loop; - return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do - for I in 1 .. R.Length loop - R.Replace_Element (I, Buffer.Element (I)); - end loop; - end return; + return Lists.Concat (R); end Quasiquote; ---------------------------------------------------------------------- - use Types; - Argv : Mal_Type (Kind_List); - Repl : constant Environments.Ptr := Environments.Alloc; - function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is - (Eval (Args (Args'First), Repl)); + Startup : constant String := "(do" + & "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" + & "(defmacro! cond (fn* (& xs)" + & " (if (> (count xs) 0)" + & " (list 'if (first xs)" + & " (if (> (count xs) 1) (nth xs 1)" + & " (throw ""odd number of forms to cond""))" + & " (cons 'cond (rest (rest xs)))))))" + & "(def! *gensym-counter* (atom 0))" + & "(def! gensym (fn* [] " + & " (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))" + & "(defmacro! or (fn* (& xs)" + & " (if (empty? xs) nil" + & " (if (= 1 (count xs)) (first xs)" + & " (let* (condvar (gensym))" + & " `(let* (~condvar ~(first xs))" + & " (if ~condvar ~condvar (or ~@(rest xs)))))))))" + & "(def! *host-language* ""ada2"")" + & ")"; + Repl : Environments.Ptr renames Environments.Repl; + use Ada.Command_Line; begin - Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access); - Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element, - Eval_Native'Unrestricted_Access)); - - Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl)); - Discard (Eval (Read ("(def! load-file (fn* (f) " - & "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl)); - Discard (Eval (Read ("(defmacro! cond " - & "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) " - & "(if (> (count xs) 1) (nth xs 1) " - & "(throw ""odd number of forms to cond"")) " - & "(cons 'cond (rest (rest xs)))))))"), Repl)); - Discard (Eval (Read ("(def! *gensym-counter* (atom 0))"), Repl)); - Discard (Eval (Read ("(def! gensym (fn* [] (symbol (str ""G__"" " - & "(swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"), Repl)); - Discard (Eval (Read ("(defmacro! or (fn* (& xs) (if (empty? xs) nil " - & "(if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) " - & "`(let* (~condvar ~(first xs)) (if ~condvar ~condvar " - & "(or ~@(rest xs)))))))))"), Repl)); - - Repl.Set (Names.Host_Language, - Mal_Type'(Kind_Symbol, Atoms.No_Element, Names.Ada2)); - - if Ada.Command_Line.Argument_Count = 0 then - Repl.Set (Names.Argv, Argv); + Core.Eval_Ref := Eval'Unrestricted_Access; + Discard (Eval (Read (Startup), Repl)); + declare + Args : Mal.T_Array (2 .. Argument_Count); + begin + for I in Args'Range loop + Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + end loop; + Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + end; + if Argument_Count = 0 then Discard (Eval (Read ("(println (str ""Mal ["" *host-language* ""]""))"), Repl)); Interactive_Loop (Repl); else - Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1); - for I in 2 .. Ada.Command_Line.Argument_Count loop - Argv.L.Replace_Element (I - 1, - Mal_Type'(Kind_String, Atoms.No_Element, - Strings.Alloc (Ada.Command_Line.Argument (I)))); - end loop; - Repl.Set (Names.Argv, Argv); - Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1) - & """)"), Repl)); + Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); end if; end StepA_Mal; diff --git a/ada2/strings.adb b/ada2/strings.adb deleted file mode 100644 index 6cee7acf03..0000000000 --- a/ada2/strings.adb +++ /dev/null @@ -1,62 +0,0 @@ -with Ada.Strings.Hash; - -package body Strings is - - Dict : Sets.Set; - Empty_Hash : constant Ada.Containers.Hash_Type := Ada.Strings.Hash (""); - - ---------------------------------------------------------------------- - - procedure Adjust (Object : in out Ptr) is - begin - if Sets.Has_Element (Object.Position) then - Dict (Object.Position).Refs := Dict (Object.Position).Refs + 1; - end if; - end Adjust; - - function Alloc (Source : in String) return Ptr - is - Inserted : Boolean; - Position : Sets.Cursor; - begin - if Source /= "" then - Sets.Insert (Dict, - (Data => Source, - Hash => Ada.Strings.Hash (Source), - Last => Source'Length, - Refs => 1), - Position, - Inserted); - if not Inserted then - Dict (Position).Refs := Dict (Position).Refs + 1; - end if; - end if; - return (Ada.Finalization.Controlled with Position => Position); - end Alloc; - - function Deref (Source : in Ptr) return String is - (if Sets.Has_Element (Source.Position) - then Dict (Source.Position).Data - else ""); - - procedure Finalize (Object : in out Ptr) - is - Refs : Positive; - begin - if Sets.Has_Element (Object.Position) then - Refs := Dict (Object.Position).Refs; - if 1 < Refs then - Dict (Object.Position).Refs := Refs - 1; - Object.Position := Sets.No_Element; - else - Sets.Delete (Dict, Object.Position); - end if; - end if; - end Finalize; - - function Hash (Source : in Ptr) return Ada.Containers.Hash_Type is - (if Sets.Has_Element (Source.Position) - then Dict (Source.Position).Hash - else Empty_Hash); - -end Strings; diff --git a/ada2/strings.ads b/ada2/strings.ads deleted file mode 100644 index aeb8222725..0000000000 --- a/ada2/strings.ads +++ /dev/null @@ -1,65 +0,0 @@ -with Ada.Containers; -private with Ada.Containers.Indefinite_Hashed_Sets; -private with Ada.Finalization; - -package Strings is - - pragma Elaborate_Body; - - -- An abstraction similar to Ada.Strings.Unbounded, except that - -- the type is immutable, and that only one instance is allocated - -- with a given content. This avoids many allocations and - -- deallocations, since symbols and keywords are expected to be - -- used many times. Using this for all strings even if they are - -- not used as keys in maps should not hurt. - - -- As a side effect, some frequent string comparisons (with "def!" - -- or "fn*" for example) will become a bit more efficient because - -- comparing pointers is faster than comparing strings. - - type Ptr is tagged private; - Empty_String : constant Ptr; -- The default value. - - function Alloc (Source : in String) return Ptr; - - function Deref (Source : in Ptr) return String - with Inline; - - -- We make the hash value visible so that environments and maps do - -- not need to recompute it. - function Hash (Source : in Ptr) return Ada.Containers.Hash_Type - with Inline; - -private - - type Element_Type (Last : Positive) is record - Data : String (1 .. Last); - Hash : Ada.Containers.Hash_Type; - Refs : Positive; - end record; - - function Hash (Element : Element_Type) return Ada.Containers.Hash_Type - is (Element.Hash) - with Inline; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean - is (Left.Data = Right.Data) - with Inline; - - package Sets is new Ada.Containers.Indefinite_Hashed_Sets - (Element_Type => Element_Type, - Hash => Hash, - Equivalent_Elements => Equivalent_Elements, - "=" => "="); - - type Ptr is new Ada.Finalization.Controlled with record - Position : Sets.Cursor := Sets.No_Element; - end record; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - -- Predefined equality is fine. - - Empty_String : constant Ptr - := (Ada.Finalization.Controlled with Position => Sets.No_Element); - -end Strings; diff --git a/ada2/types-atoms.adb b/ada2/types-atoms.adb new file mode 100644 index 0000000000..6f0afb76ed --- /dev/null +++ b/ada2/types-atoms.adb @@ -0,0 +1,62 @@ +with Ada.Unchecked_Deallocation; + +with Types.Mal; + +package body Types.Atoms is + + type Rec is limited record + Refs : Natural; + Data : Mal.T; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + + ---------------------------------------------------------------------- + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Atom (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "atom: expects 1 argument" + else + (Kind => Kind_Atom, + Atom => (Ada.Finalization.Controlled with + Ref => new Rec'(Data => Args (Args'First), + Refs => 1)))); + + function Deref (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "deref: expects 1 argument" + elsif Args (Args'First).Kind /= Kind_Atom then + raise Argument_Error with "deref: expects an atom" + else + (Args (Args'First).Atom.Ref.all.Data)); + + procedure Finalize (Object : in out Ptr) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + function Reset (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 2 then + raise Argument_Error with "reset: expects 2 arguments"; + elsif Args (Args'First).Kind /= Kind_Atom then + raise Argument_Error with "reset: first argument must be an atom"; + else + Args (Args'First).Atom.Ref.all.Data := Args (Args'Last); + return Args (Args'Last); + end if; + end Reset; + +end Types.Atoms; diff --git a/ada2/types-atoms.ads b/ada2/types-atoms.ads new file mode 100644 index 0000000000..2ed928abc0 --- /dev/null +++ b/ada2/types-atoms.ads @@ -0,0 +1,35 @@ +private with Ada.Finalization; + +limited with Types.Mal; + +package Types.Atoms is + + type Ptr is private; + -- A wrapper for a pointer counting references. + + -- The default value is invalid, new variables must be assigned + -- immediately (a hidden discriminant would prevent this type to + -- become a field inside Types.Mal.T, so we check this with a + -- private invariant a fallback, an invariant in the private part + -- checks that any created object is affected before use. + + -- Assignment give another reference to the same storage. + + -- Built-in functions. + function Atom (Args : in Mal.T_Array) return Mal.T; + function Deref (Args : in Mal.T_Array) return Mal.T; + function Reset (Args : in Mal.T_Array) return Mal.T; + +private + + type Rec; + type Acc is access Rec; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Acc := null; + end record + with Invariant => Ref /= null; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + pragma Finalize_Storage_Only (Ptr); + +end Types.Atoms; diff --git a/ada2/types-builtins.adb b/ada2/types-builtins.adb new file mode 100644 index 0000000000..fa939a7da2 --- /dev/null +++ b/ada2/types-builtins.adb @@ -0,0 +1,53 @@ +with Ada.Unchecked_Deallocation; + +with Types.Mal; + +package body Types.Builtins is + + type Rec is limited record + Data : Ptr; + Refs : Natural; + Meta : Mal.T; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + + ---------------------------------------------------------------------- + + procedure Adjust (Object : in out Ptr_With_Meta) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Data (Item : in Ptr_With_Meta) return Ptr + is (Item.Ref.all.Data); + + procedure Finalize (Object : in out Ptr_With_Meta) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + function Meta (Item : in Ptr_With_Meta) return Mal.T + is (Item.Ref.all.Meta); + + function With_Meta (Data : in Ptr; + Meta : in Mal.T) return Mal.T + is (Kind_Builtin_With_Meta, (Ada.Finalization.Controlled with new Rec' + (Data => Data, + Meta => Meta, + Refs => 1))); + + function With_Meta (Data : in Ptr_With_Meta; + Meta : in Mal.T) return Mal.T + -- Do not try to reuse the memory. We can hope that this kind of + -- nonsense will be rare. + is (With_Meta (Data.Data, Meta)); + +end Types.Builtins; diff --git a/ada2/types-builtins.ads b/ada2/types-builtins.ads new file mode 100644 index 0000000000..abb118e30b --- /dev/null +++ b/ada2/types-builtins.ads @@ -0,0 +1,46 @@ +private with Ada.Finalization; + +limited with Types.Mal; + +package Types.Builtins is + + type Ptr is access function (Args : in Mal.T_Array) return Mal.T; + -- This access type is efficient and sufficient for most purposes, + -- as counting references is a waste of time for native functions, + -- which are often used as atomic elements. The controlled type + -- below is only useful when one has the silly idea to add + -- metadata to a built-in. + + type Ptr_With_Meta is tagged private; + -- A wrapper for a pointer counting references. + + -- The default value is invalid, new variables must be assigned + -- immediately (a hidden discriminant would prevent this type to + -- become a field inside Types.Mal.T, so we check this with a + -- private invariant a fallback, an invariant in the private part + -- checks that any created object is affected before use. + + -- Assignment give another reference to the same storage. + + function With_Meta (Data : in Ptr; + Meta : in Mal.T) return Mal.T with Inline; + function With_Meta (Data : in Ptr_With_Meta; + Meta : in Mal.T) return Mal.T with Inline; + function Meta (Item : in Ptr_With_Meta) return Mal.T with Inline; + function Data (Item : in Ptr_With_Meta) return Ptr with Inline; + +private + + -- See README for the implementation of reference counting. + + type Rec; + type Acc is access Rec; + type Ptr_With_Meta is new Ada.Finalization.Controlled with record + Ref : Acc := null; + end record + with Invariant => Ref /= null; + overriding procedure Adjust (Object : in out Ptr_With_Meta) with Inline; + overriding procedure Finalize (Object : in out Ptr_With_Meta) with Inline; + pragma Finalize_Storage_Only (Ptr_With_Meta); + +end Types.Builtins; diff --git a/ada2/types-functions.adb b/ada2/types-functions.adb new file mode 100644 index 0000000000..5360d83144 --- /dev/null +++ b/ada2/types-functions.adb @@ -0,0 +1,171 @@ +with Ada.Strings.Unbounded; +with Ada.Unchecked_Deallocation; + +with Environments; +with Printer; +with Types.Lists; +with Types.Mal; +with Types.Symbols.Names; + +package body Types.Functions is + + subtype AFC is Ada.Finalization.Controlled; + package ASU renames Ada.Strings.Unbounded; + use type Types.Symbols.Ptr; + + type Rec is limited record + Refs : Natural := 1; + Args : Lists.Ptr; + Expr : Mal.T; + Env : Environments.Closure_Ptr; + Varargs : Boolean; + Meta : Mal.T := Mal.Nil; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + + ---------------------------------------------------------------------- + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Closure (Item : in Ptr) return Environments.Closure_Ptr + is (Item.Ref.all.Env); + + function Expression (Item : in Ptr) return Mal.T + is (Item.Ref.all.Expr); + + procedure Finalize (Object : in out Ptr) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + function Formals (Item : in Ptr) return Lists.Ptr + is (Item.Ref.all.Args); + + function Meta (Item : in Ptr) return Mal.T + is (Item.Ref.all.Meta); + + function New_Function (Formals : in Lists.Ptr; + Expression : in Mal.T; + Environment : in Environments.Closure_Ptr) + return Mal.T + is (Kind_Function, + (AFC with new Rec' + (Args => Formals, + Expr => Expression, + Env => Environment, + Varargs => 1 < Formals.Length + and then Formals.Element (Formals.Length - 1).Symbol + = Symbols.Names.Ampersand, + others => <>))); + + function New_Macro (Item : in Ptr) return Mal.T is + Old : Rec renames Item.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Item.Ref; + Old.Refs := 2; + Old.Env := Environments.Null_Closure; + -- Finalize the previous closure. + Old.Meta := Mal.Nil; + else + Ref := new Rec'(Args => Item.Ref.all.Args, + Expr => Item.Ref.all.Expr, + Varargs => Item.Ref.all.Varargs, + others => <>); + end if; + return (Kind_Macro, (AFC with Ref)); + end New_Macro; + + procedure Set_Binds (Item : in Ptr; + Env : in Environments.Ptr; + Args : in Mal.T_Array) is + R : Rec renames Item.Ref.all; + begin + if R.Varargs then + if Args'Length < R.Args.Length - 2 then + raise Argument_Error with "expected " + & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) + & ", got" & Args'Length'Img; + end if; + for I in 1 .. R.Args.Length - 2 loop + Env.Set (R.Args.Element (I).Symbol, Args (Args'First + I - 1)); + end loop; + Env.Set (R.Args.Element (R.Args.Length).Symbol, + Lists.List (Args (Args'First + R.Args.Length - 2 .. Args'Last))); + else + if Args'Length /= R.Args.Length then + raise Argument_Error with "expected " + & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) + & ", got" & Args'Length'Img; + end if; + for I in 1 .. R.Args.Length loop + Env.Set (R.Args.Element (I).Symbol, Args (Args'First + I - 1)); + end loop; + end if; + end Set_Binds; + + procedure Set_Binds (Item : in Ptr; + Env : in Environments.Ptr; + Args : in Lists.Ptr) is + R : Rec renames Item.Ref.all; + begin + if R.Varargs then + if Args.Length - 1 < R.Args.Length - 2 then + raise Argument_Error with "expected " + & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) + & ", got" & Natural'Image (Args.Length - 1); + end if; + for I in 1 .. R.Args.Length - 2 loop + Env.Set (R.Args.Element (I).Symbol, Args.Element (1 + I)); + end loop; + Env.Set (R.Args.Element (R.Args.Length).Symbol, + Lists.Slice (Args, R.Args.Length)); + else + if Args.Length - 1 /= R.Args.Length then + raise Argument_Error with "expected " + & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) + & ", got" & Natural'Image (Args.Length - 1); + end if; + for I in 1 .. R.Args.Length loop + Env.Set (R.Args.Element (I).Symbol, Args.Element (1 + I)); + end loop; + end if; + end Set_Binds; + + function With_Meta (Data : in Ptr; + Meta : in Mal.T) + return Mal.T is + Old : Rec renames Data.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Data.Ref; + Old.Refs := 2; + Old.Meta := Meta; + else + Ref := new Rec'(Args => Data.Ref.all.Args, + Expr => Data.Ref.all.Expr, + Env => Data.Ref.all.Env, + Varargs => Data.Ref.all.Varargs, + Meta => Meta, + others => <>); + + end if; + return (Kind_Function, (AFC with Ref)); + end With_Meta; + +end Types.Functions; diff --git a/ada2/types-functions.ads b/ada2/types-functions.ads new file mode 100644 index 0000000000..35aabee2c3 --- /dev/null +++ b/ada2/types-functions.ads @@ -0,0 +1,67 @@ +private with Ada.Finalization; + +limited with Environments; +limited with Types.Lists; +limited with Types.Mal; + +package Types.Functions is + + type Ptr is tagged private; + -- A wrapper for a pointer counting references. + + -- The default value is invalid, new variables must be assigned + -- immediately (a hidden discriminant would prevent this type to + -- become a field inside Types.Mal.T, so we check this with a + -- private invariant a fallback, an invariant in the private part + -- checks that any created object is affected before use. + + -- Assignment give another reference to the same storage. + + function New_Function (Formals : in Lists.Ptr; + Expression : in Mal.T; + Environment : in Environments.Closure_Ptr) + return Mal.T + with Inline; + + -- Equivalent to a sequence of Set with the formal parameters and + -- Args elements, except for the handling of "&". + -- May raise Argument_Count. + -- For functions. + procedure Set_Binds (Item : in Ptr; + Env : in Environments.Ptr; + Args : in Mal.T_Array); + + function New_Macro (Item : in Ptr) return Mal.T with Inline; + -- Set_Binds for macros. + -- It skips the first element of Args. + procedure Set_Binds (Item : in Ptr; + Env : in Environments.Ptr; + Args : in Lists.Ptr); + + -- Used when printing, or applying with specific requirements, + -- like allowing tail call optimization or macros. + function Formals (Item : in Ptr) return Lists.Ptr with Inline; + function Expression (Item : in Ptr) return Mal.T with Inline; + function Closure (Item : in Ptr) return Environments.Closure_Ptr + with Inline; + + function Meta (Item : in Ptr) return Mal.T with inline; + function With_Meta (Data : in Ptr; + Meta : in Mal.T) + return Mal.T with Inline; + +private + + -- See README for the implementation of reference counting. + + type Rec; + type Acc is access Rec; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Acc := null; + end record + with Invariant => Ref /= null; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + pragma Finalize_Storage_Only (Ptr); + +end Types.Functions; diff --git a/ada2/types-lists.adb b/ada2/types-lists.adb new file mode 100644 index 0000000000..a20ba3e8a6 --- /dev/null +++ b/ada2/types-lists.adb @@ -0,0 +1,260 @@ +with Ada.Unchecked_Deallocation; + +with Types.Mal; + +package body Types.Lists is + + subtype AFC is Ada.Finalization.Controlled; + use type Mal.T_Array; + + type Rec (Last : Natural) is limited record + Refs : Natural := 1; + Meta : Mal.T := Mal.Nil; + Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil); + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in Ptr) return Boolean is + -- Should become Left.Ref.all.Data = Right.Ref.all.Data when + -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. + use type Mal.T; + L : Rec renames Left.Ref.all; + R : Rec renames Right.Ref.all; + begin + return L.Last = R.Last + and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I)); + end "="; + + function "&" (Left : in Mal.T_Array; + Right : in Ptr) return Mal.T_Array + is (Left & Right.Ref.all.Data); + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Concat (Args : in Mal.T_Array) return Mal.T is + Sum : Natural := 0; + Ref : Acc; + begin + for Arg of Args loop + if Arg.Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "concat: expects lists or vectors"; + end if; + Sum := Sum + Arg.L.Ref.all.Last; + end loop; + Ref := new Rec (Sum); + for Arg of reverse Args loop + Ref.all.Data (Sum - Arg.L.Ref.all.Last + 1 .. Sum) + := Arg.L.Ref.all.Data; + Sum := Sum - Arg.L.Ref.all.Last; + end loop; + pragma Assert (Sum = 0); + return (Kind_List, (AFC with Ref)); + end Concat; + + function Conj (Args : in Mal.T_Array) return Mal.T is + Ref : Acc; + begin + if Args'Length = 0 then + raise Argument_Error with "conj: expects at least 1 argument"; + end if; + case Args (Args'First).Kind is + when Kind_List => + Ref := new Rec + (Args'Length - 1 + Args (Args'First).L.Ref.all.Last); + Ref.all.Data (Args'Length .. Ref.all.Last) + := Args (Args'First).L.Ref.all.Data; + for I in 1 .. Args'Length - 1 loop + Ref.all.Data (I) := Args (Args'Last - I + 1); + end loop; + return (Kind_List, (AFC with Ref)); + when Kind_Vector => + return (Kind_Vector, (AFC with new Rec' + (Last => Args'Length - 1 + Args (Args'First).L.Ref.all.Last, + Data => Args (Args'First).L.Ref.all.Data + & Args (Args'First + 1 .. Args'Last), + others => <>))); + when others => + raise Argument_Error with "conj: first arg must be list or vector"; + end case; + end Conj; + + function Cons (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 2 then + raise Argument_Error with "cons: expects 2 arguments"; + end if; + case Args (Args'Last).Kind is + when Kind_List | Kind_Vector => + return (Kind_List, (AFC with new Rec' + (Last => 1 + Args (Args'Last).L.Ref.all.Last, + Data => Args (Args'First) & Args (Args'Last).L.Ref.all.Data, + others => <>))); + when others => + raise Argument_Error with "cons: last arg must be list or vector"; + end case; + end Cons; + + function Count (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "count: expects 1 argument" + else + (case Args (Args'First).Kind is + when Kind_Nil => + (Kind_Number, 0), + when Kind_List | Kind_Vector => + (Kind_Number, Args (Args'First).L.Ref.all.Last), + when others => + raise Argument_Error with "count: expects a list or vector")); + + function Element (Container : in Ptr; + Index : in Positive) return Mal.T + is (Container.Ref.all.Data (Index)); + + procedure Finalize (Object : in out Ptr) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + function First (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "first: expects 1 argument" + else + (case Args (Args'First).Kind is + when Kind_Nil => + Mal.Nil, + when Kind_List | Kind_Vector => + (if Args (Args'First).L.Ref.all.Last = 0 then + Mal.Nil + else + Args (Args'First).L.Ref.all.Data (1)), + when others => + raise Argument_Error with "first: expects a list or vector")); + + function Generic_Eval (Container : in Ptr; + Env : in Env_Type) + return Ptr is + -- Take care that automatic deallocation happens if an + -- exception is propagated by user code. + Old : Rec renames Container.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Container.Ref; + Old.Refs := 2; + Old.Meta := Mal.Nil; + else + Ref := new Rec (Old.Last); + end if; + return R : constant Ptr := (AFC with Ref) do + for I in Old.Data'Range loop + Ref.all.Data (I) := Eval (Old.Data (I), Env); + end loop; + end return; + end Generic_Eval; + + function Is_Empty (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 1 then + raise Argument_Error with "empty?: expects 1 argument" + else + (case Args (Args'First).Kind is + when Kind_List | Kind_Vector => + (Kind_Boolean, Args (Args'First).L.Ref.all.Last = 0), + when others => + raise Argument_Error with "empty?: expects a list or vector")); + + function Length (Source : in Ptr) return Natural + is (Source.Ref.all.Last); + + function List (Args : in Mal.T_Array) return Mal.T + is (Kind_List, (AFC with new Rec'(Data => Args, + Last => Args'Length, + others => <>))); + + function Meta (Item : in Ptr) return Mal.T + is (Item.Ref.all.Meta); + + function Nth (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 2 then + raise Argument_Error with "nth: expects 2 arguments" + else + (case Args (Args'First).Kind is + when Kind_List | Kind_Vector => + (if Args (Args'First + 1).Kind /= Kind_Number then + raise Argument_Error with "nth: last arg must be a number" + elsif 1 + Args (Args'Last).Ada_Number + in Args (Args'First).L.Ref.all.Data'Range + then + Args (Args'First).L.Ref.all.Data + (1 + Args (Args'Last).Ada_Number) + else + raise Argument_Error with "nth: index out of bounds"), + when others => + raise Argument_Error with "nth: expects a list or vector")); + + function Rest (Args : in Mal.T_Array) return Mal.T + is (Kind_List, (AFC with + (if Args'Length /= 1 then + raise Argument_Error with "rest: expects 1 argument" + else + (case Args (Args'First).Kind is + when Kind_Nil => + new Rec (0), + when Kind_List | Kind_Vector => + (if Args (Args'First).L.Ref.all.Last = 0 then + new Rec (0) + else + new Rec'(Last => Args (Args'First).L.Ref.all.Last - 1, + Data => Args (Args'First).L.Ref.all.Data + (2 .. Args (Args'First).L.Ref.all.Last), + others => <>)), + when others => + raise Argument_Error with "rest: expects a list or vector")))); + + function Slice (Item : in Ptr; + Start : in Positive) + return Mal.T + is (Kind_List, (AFC with new Rec' + (Last => Item.Ref.all.Last - Start + 1, + Data => Item.Ref.all.Data (Start .. Item.Ref.all.Last), + others => <>))); + + function Vector (Args : in Mal.T_Array) return Mal.T + is (Kind_Vector, (AFC with new Rec'(Data => Args, + Last => Args'Length, + others => <>))); + + function With_Meta (Data : in Ptr; + Meta : in Mal.T) + return Ptr is + Old : Rec renames Data.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Data.Ref; + Old.Refs := 2; + Old.Meta := Meta; + else + Ref := new Rec'(Last => Old.Last, + Data => Old.Data, + Meta => Meta, + others => <>); + end if; + return (AFC with Ref); + end With_Meta; + +end Types.Lists; diff --git a/ada2/types-lists.ads b/ada2/types-lists.ads new file mode 100644 index 0000000000..b8678f2f1c --- /dev/null +++ b/ada2/types-lists.ads @@ -0,0 +1,83 @@ +private with Ada.Finalization; + +limited with Types.Mal; + +package Types.Lists is + + type Ptr is tagged private; + -- A wrapper for a pointer counting references. + + -- The default value is invalid, new variables must be assigned + -- immediately (a hidden discriminant would prevent this type to + -- become a field inside Types.Mal.T, so we check this with a + -- private invariant a fallback, an invariant in the private part + -- checks that any created object is affected before use. + + -- Assignment give another reference to the same storage. + + -- Built-in functions. + function Concat (Args : in Mal.T_Array) return Mal.T; + function Conj (Args : in Mal.T_Array) return Mal.T; + function Cons (Args : in Mal.T_Array) return Mal.T; + function Count (Args : in Mal.T_Array) return Mal.T; + function First (Args : in Mal.T_Array) return Mal.T; + function Is_Empty (Args : in Mal.T_Array) return Mal.T; + function List (Args : in Mal.T_Array) return Mal.T; + function Nth (Args : in Mal.T_Array) return Mal.T; + function Rest (Args : in Mal.T_Array) return Mal.T; + function Vector (Args : in Mal.T_Array) return Mal.T; + + function Length (Source : in Ptr) return Natural with Inline; + + function Element (Container : in Ptr; + Index : in Positive) return Mal.T + with Inline; + Index_Error : exception; + + function "&" (Left : in Mal.T_Array; + Right : in Ptr) return Mal.T_Array; + -- Used to implement Core.Apply. + + -- Used to evaluate each element of a list/vector. + -- Eval is generic because units cannot depend on each other. + generic + type Env_Type (<>) is limited private; + with function Eval (Ast : in Mal.T; + Env : in Env_Type) + return Mal.T; + function Generic_Eval (Container : in Ptr; + Env : in Env_Type) + return Ptr; + + -- Used to spare an intermediate copy for & in macro arguments. + function Slice (Item : in Ptr; + Start : in Positive) + return Mal.T; + + function Meta (Item : in Ptr) return Mal.T with Inline; + function With_Meta (Data : in Ptr; + Meta : in Mal.T) + return Ptr; + +private + + -- It is tempting to use null to represent an empty list, but the + -- performance is not improved much, and the code is more complex. + -- In addition, the empty list may want to carry metadata. + + -- Similarly, always providing a default value like a pointer to a + -- static empty list would not gain much, and probably hide some + -- bugs. + + type Rec; + type Acc is access Rec; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Acc := null; + end record + with Invariant => Ref /= null; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + overriding function "=" (Left, Right : in Ptr) return Boolean; + pragma Finalize_Storage_Only (Ptr); + +end Types.Lists; diff --git a/ada2/types-mal.adb b/ada2/types-mal.adb new file mode 100644 index 0000000000..7e613d4172 --- /dev/null +++ b/ada2/types-mal.adb @@ -0,0 +1,31 @@ +package body Types.Mal is + + use type Ada.Strings.Unbounded.Unbounded_String; + use type Lists.Ptr; + use type Maps.Ptr; + use type Symbols.Ptr; + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in T) return Boolean + is (case Left.Kind is + when Kind_Nil => + Right.Kind = Kind_Nil, + when Kind_Boolean => + Right.Kind = Kind_Boolean + and then Left.Ada_Boolean = Right.Ada_Boolean, + when Kind_Number => + Right.Kind = Kind_Number and then Left.Ada_Number = Right.Ada_Number, + when Kind_Symbol => + Right.Kind = Kind_Symbol and then Left.Symbol = Right.Symbol, + -- Here is the part that differs from the predefined equality. + when Kind_Keyword | Kind_String => + Right.Kind = Left.Kind and then Left.S = Right.S, + when Kind_List | Kind_Vector => + Right.Kind in Kind_List | Kind_Vector and then Left.L = Right.L, + when Kind_Map => + Right.Kind = Kind_Map and then Left.Map = Right.Map, + when others => + False); + +end Types.Mal; diff --git a/ada2/types-mal.ads b/ada2/types-mal.ads new file mode 100644 index 0000000000..d7aec36428 --- /dev/null +++ b/ada2/types-mal.ads @@ -0,0 +1,84 @@ +with Ada.Strings.Unbounded; + +with Types.Atoms; +with Types.Builtins; +with Types.Functions; +with Types.Lists; +with Types.Maps; +with Types.Symbols; + +package Types.Mal is + + -- A type with a default value for the discriminant is the Ada + -- equivalent of a C union. It uses a fixed size, and allows + -- efficient arrays. A class hierarchy would make this impossible, + -- for little gain. + -- Native types may seem to consume too much memory, but + -- 1/ they require no allocation/deallocation. + -- 2/ the overhead would actually be higher with an intermediate + -- reference (the size of the pointer plus the size of the native + -- type, while an union uses the minimum of both and a single + -- memory area ). + -- Each instance has the size required for the largest possible + -- value, so subtypes should attempt to reduce their size when + -- possible (see Types.Symbols for such a compromise). + + -- The idea is inspired from the Haskell and OCaml interpreters, + -- which use a bit to distinguish pointers from integers. Ada + -- allows to specify the bit position of each component, but + -- generating such architecture-dependent definitions seems a lot + -- of work for MAL. + + -- The Ada tradition is to give explicit names to types, but this + -- one will be used very often, and almost each package declares + -- an "use Types;" clause, so Mal.T will do. + + -- The only problem with a hidden discriminant is that "in out" + -- parameters cannot be reaffected with a different discriminant. + -- Eval would be more efficient with "in out" parameters than with + -- "in" parameters and a result, because lots of reference + -- counting would be spared, and the implementation would be able + -- to reuse dynamic memory more efficiently. Environments, and + -- some list/map operations already attempt such reuse behind the + -- curtain. + + -- This would obfuscate the implementation of a functional + -- language, and require deep changes (the discriminant can be + -- changed for an in out or access parameter). + + type T (Kind : Kind_Type := Kind_Nil) is record + case Kind is + when Kind_Nil => + null; + when Kind_Boolean => + Ada_Boolean : Boolean; + when Kind_Number => + Ada_Number : Integer; + when Kind_Atom => + Atom : Atoms.Ptr; + when Kind_Keyword | Kind_String => + S : Ada.Strings.Unbounded.Unbounded_String; + when Kind_Symbol => + Symbol : Symbols.Ptr; + when Kind_List | Kind_Vector => + L : Lists.Ptr; + when Kind_Map => + Map : Maps.Ptr; + when Kind_Builtin => + Builtin : Builtins.Ptr; + when Kind_Builtin_With_Meta => + Builtin_With_Meta : Builtins.Ptr_With_Meta; + when Kind_Function | Kind_Macro => + Function_Value : Functions.Ptr; + end case; + end record; + + -- Useful for recursive automatic definition of equality for + -- composite types like the array type below. + function "=" (Left, Right : in T) return Boolean with Inline; + + Nil : constant T := (Kind => Kind_Nil); + + type T_Array is array (Positive range <>) of T; + +end Types.Mal; diff --git a/ada2/types-maps.adb b/ada2/types-maps.adb new file mode 100644 index 0000000000..9f70440b50 --- /dev/null +++ b/ada2/types-maps.adb @@ -0,0 +1,266 @@ +with Ada.Containers.Hashed_Maps; +with Ada.Strings.Unbounded.Hash; +with Ada.Unchecked_Deallocation; + +with Types.Lists; +with Types.Mal; + +package body Types.Maps is + + subtype AFC is Ada.Finalization.Controlled; + use type Ada.Containers.Count_Type; + + function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type + with Inline, Pre => Item.Kind in Kind_Keyword | Kind_String; + + package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T, + Element_Type => Mal.T, + Hash => Hash, + Equivalent_Keys => Mal."=", + "=" => Mal."="); + use type HM.Map; + + type Rec is limited record + Refs : Natural := 1; + Data : HM.Map := HM.Empty_Map; + Meta : Mal.T := Mal.Nil; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in Ptr) return Boolean + is (Left.Ref.all.Data = Right.Ref.all.Data); + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Assoc (Args : in Mal.T_Array) return Mal.T is + Binds : constant Natural := Args'Length / 2; + begin + if Args'Length mod 2 /= 1 then + raise Argument_Error with "assoc: expects an odd argument count"; + elsif Args (Args'First).Kind /= Kind_Map then + raise Argument_Error with "assoc: first argument must be a map"; + elsif (for some I in 1 .. Binds => Args (Args'First + 2 * I - 1).Kind + not in Kind_Keyword | Kind_String) + then + raise Argument_Error with "assoc: keys must be strings or symbols"; + end if; + declare + Old : Rec renames Args (Args'First).Map.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Args (Args'First).Map.Ref; + Old.Refs := 2; + Old.Meta := Mal.Nil; + else + Ref := new Rec'(Data => Old.Data, others => <>); + end if; + for I in 1 .. Binds loop + Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1), + New_Item => Args (Args'First + 2 * I)); + end loop; + return (Kind_Map, (AFC with Ref)); + end; + end Assoc; + + function Contains (Args : in Mal.T_Array) return Mal.T + is (if Args'Length /= 2 then + raise Argument_Error with "contains: expects 2 arguments" + elsif Args (Args'First).Kind /= Kind_Map then + raise Argument_Error with "contains: first arguement must be a map" + else (Kind_Boolean, + Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)))); + + function Dissoc (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length = 0 then + raise Argument_Error with "dissoc: expects at least 1 argument"; + elsif Args (Args'First).Kind /= Kind_Map then + raise Argument_Error with "dissoc: first argument must be a map"; + elsif (for some I in Args'First + 1 .. Args'Last => + Args (I).Kind not in Kind_Keyword | Kind_String) + then + raise Argument_Error with "dissoc: keys must be strings or symbols"; + end if; + declare + Old : Rec renames Args (Args'First).Map.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Args (Args'First).Map.Ref; + Old.Refs := 2; + Old.Meta := Mal.Nil; + else + Ref := new Rec'(Data => Old.Data, others => <>); + end if; + for I in Args'First + 1 .. Args'Last loop + Ref.all.Data.Exclude (Args (I)); + end loop; + return (Kind_Map, (AFC with Ref)); + end; + end Dissoc; + + procedure Finalize (Object : in out Ptr) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Free (Object.Ref); + end if; + end if; + end Finalize; + + function Generic_Eval (Container : in Ptr; + Env : in Env_Type) + return Mal.T is + -- Copy the whole hash in order to avoid recomputing the hash + -- for each key, even if it implies unneeded calls to adjust + -- and finalize for Mal_Type values. + Old : Rec renames Container.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Container.Ref; + Old.Refs := 2; + Old.Meta := Mal.Nil; + else + Ref := new Rec'(Data => Container.Ref.all.Data, others => <>); + end if; + -- Prepare a valid structure before running user code. In case + -- an exception is raised, we want memory to be deallocated. + return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do + for Position in Ref.all.Data.Iterate loop + Ref.all.Data.Replace_Element (Position, + Eval (HM.Element (Position), Env)); + end loop; + end return; + end Generic_Eval; + + function Get (Args : in Mal.T_Array) return Mal.T is + Position : HM.Cursor; + begin + if Args'Length /= 2 then + raise Argument_Error with "get: expects 2 arguments"; + elsif Args (Args'Last).Kind not in Kind_Keyword | Kind_String then + raise Argument_Error with "get: key must be a keyword or string"; + end if; + case Args (Args'First).Kind is + when Kind_Nil => + return Mal.Nil; + when Kind_Map => + Position + := Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last)); + if HM.Has_Element (Position) then + return HM.Element (Position); + else + return Mal.Nil; + end if; + when others => + raise Argument_Error with "get: first argument must be a map"; + end case; + end Get; + + function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type + is (Ada.Strings.Unbounded.Hash (Item.S)); + + function Hash_Map (Args : in Mal.T_Array) return Mal.T is + Binds : constant Natural := Args'Length / 2; + Ref : Acc; + begin + if Args'Length mod 2 /= 0 then + raise Argument_Error with "hash-map: expects an even argument count"; + elsif (for some I in 0 .. Binds - 1 => Args (Args'First + 2 * I).Kind + not in Kind_Keyword | Kind_String) + then + raise Argument_Error with "hash-map: keys must be strings or symbols"; + end if; + Ref := new Rec; + Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds)); + for I in 0 .. Binds - 1 loop + Ref.all.Data.Include (Key => Args (Args'First + 2 * I), + New_Item => Args (Args'First + 2 * I + 1)); + end loop; + return (Kind_Map, (AFC with Ref)); + end Hash_Map; + + procedure Iterate (Container : in Ptr) is + begin + for Position in Container.Ref.all.Data.Iterate loop + Process (HM.Key (Position), HM.Element (Position)); + end loop; + end Iterate; + + function Keys (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 1 then + raise Argument_Error with "keys: expects 1 argument"; + elsif Args (Args'First).Kind /= Kind_Map then + raise Argument_Error with "keys: first argument must a map"; + end if; + declare + A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; + R : Mal.T_Array (1 .. Natural (A1.Length)); + I : Positive := 1; + begin + for Position in A1.Iterate loop + R (I) := HM.Key (Position); + I := I + 1; + end loop; + return Lists.List (R); + end; + end Keys; + + function Meta (Container : in Ptr) return Mal.T + is (Container.Ref.all.Meta); + + function Vals (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 1 then + raise Argument_Error with "vals: expects 1 argument"; + elsif Args (Args'First).Kind /= Kind_Map then + raise Argument_Error with "vals: first argument must be a map"; + end if; + declare + A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; + R : Mal.T_Array (1 .. Natural (A1.Length)); + I : Positive := 1; + begin + for Element of A1 loop + R (I) := Element; + I := I + 1; + end loop; + return Lists.List (R); + end; + end Vals; + + function With_Meta (Data : in Ptr; + Meta : in Mal.T) + return Mal.T is + Old : Rec renames Data.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Data.Ref; + Old.Refs := 2; + Old.Meta := Meta; + else + Ref := new Rec'(Data => Old.Data, + Meta => Meta, + others => <>); + end if; + return (Kind_Map, (AFC with Ref)); + end With_Meta; + +end Types.Maps; diff --git a/ada2/types-maps.ads b/ada2/types-maps.ads new file mode 100644 index 0000000000..7de5d954ba --- /dev/null +++ b/ada2/types-maps.ads @@ -0,0 +1,68 @@ +private with Ada.Finalization; + +limited with Types.Mal; + +package Types.Maps is + + type Ptr is tagged private; + -- A wrapper for a pointer counting references. + + -- The default value is invalid, new variables must be assigned + -- immediately (a hidden discriminant would prevent this type to + -- become a field inside Types.Mal.T, so we check this with a + -- private invariant a fallback, an invariant in the private part + -- checks that any created object is affected before use. + + -- Assignment give another reference to the same storage. + + -- Built-in functions. + function Assoc (Args : in Mal.T_Array) return Mal.T; + function Contains (Args : in Mal.T_Array) return Mal.T; + function Dissoc (Args : in Mal.T_Array) return Mal.T; + function Get (Args : in Mal.T_Array) return Mal.T; + function Hash_Map (Args : in Mal.T_Array) return Mal.T; + function Keys (Args : in Mal.T_Array) return Mal.T; + function Vals (Args : in Mal.T_Array) return Mal.T; + + -- A generic is better than an access to function because of + -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159 + + -- Used to evaluate each element of a map. + -- Eval is generic because units cannot depend on each other. + generic + type Env_Type (<>) is limited private; + with function Eval (Ast : in Mal.T; + Env : in Env_Type) + return Mal.T; + function Generic_Eval (Container : in Ptr; + Env : in Env_Type) + return Mal.T; + + -- Used to print a map. + generic + with procedure Process (Key : in Mal.T; + Element : in Mal.T); + procedure Iterate (Container : in Ptr); + + function Meta (Container : in Ptr) return Mal.T with Inline; + + function With_Meta (Data : in Ptr; + Meta : in Mal.T) + return Mal.T; + +private + + -- See README for the implementation of reference counting. + + type Rec; + type Acc is access Rec; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Acc := null; + end record + with Invariant => Ref /= null; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + overriding function "=" (Left, Right : in Ptr) return Boolean with Inline; + pragma Finalize_Storage_Only (Ptr); + +end Types.Maps; diff --git a/ada2/types-symbols-names.ads b/ada2/types-symbols-names.ads new file mode 100644 index 0000000000..543f5e2d73 --- /dev/null +++ b/ada2/types-symbols-names.ads @@ -0,0 +1,31 @@ +package Types.Symbols.Names is + + -- These symbols are used once by Read/Eval/Print cycle. Declare + -- them here in order to avoid an allocation and a desallocation + -- during each call of eval. + -- The built-in functions declared in Core will remain allocated + -- during the lifetime of the program and do not require this. + + -- A separate package is required because the constructor must be + -- callable, and a child package makes sense because without this + -- problem, these definition would be in Symbols. + Ampersand : constant Ptr := Constructor ("&"); + Catch : constant Ptr := Constructor ("catch*"); + Def : constant Ptr := Constructor ("def!"); + Defmacro : constant Ptr := Constructor ("defmacro!"); + Fn : constant Ptr := Constructor ("fn*"); + Let : constant Ptr := Constructor ("let*"); + Macroexpand : constant Ptr := Constructor ("macroexpand"); + Mal_Do : constant Ptr := Constructor ("do"); + Mal_If : constant Ptr := Constructor ("if"); + Quasiquote : constant Ptr := Constructor ("quasiquote"); + Quote : constant Ptr := Constructor ("quote"); + Splice_Unquote : constant Ptr := Constructor ("splice-unquote"); + Try : constant Ptr := Constructor ("try*"); + Unquote : constant Ptr := Constructor ("unquote"); + + -- These are used by both Core and Reader. Spare a search. + Deref : constant Ptr := Constructor ("deref"); + With_Meta : constant Ptr := Constructor ("with-meta"); + +end Types.Symbols.Names; diff --git a/ada2/types-symbols.adb b/ada2/types-symbols.adb new file mode 100644 index 0000000000..91c013b249 --- /dev/null +++ b/ada2/types-symbols.adb @@ -0,0 +1,90 @@ +with Ada.Containers.Ordered_Sets; +with Ada.Strings.Hash; +with Ada.Unchecked_Deallocation; + +package body Types.Symbols is + + -- For the global dictionnary of symbols, an ordered set seems + -- better than a hash map. + + type Rec (Last : Positive) is limited record + Refs : Natural; + Hash : Ada.Containers.Hash_Type; + Data : String (1 .. Last); + end record; + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + + function "<" (Left, Right : in Acc) return Boolean with Inline; + function Eq (Left, Right : in Acc) return Boolean with Inline; + -- It would be unwise to name this function "=" and override the + -- predefined equality for Acc. + -- We only search by key and insert new elements, so this should + -- always return False. + package Sets is new Ada.Containers.Ordered_Sets (Element_Type => Acc, + "<" => "<", + "=" => Eq); + + function Key (Item : in Acc) return String with Inline; + package Keys is new Sets.Generic_Keys (Key_Type => String, + Key => Key, + "<" => Standard."<"); + + Dict : Sets.Set; + + ---------------------------------------------------------------------- + + function "<" (Left, Right : in Acc) return Boolean + is (Left.all.Data < Right.all.Data); + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + end Adjust; + + function Constructor (Source : in String) return Ptr is + Position : constant Sets.Cursor := Keys.Find (Dict, Source); + Ref : Acc; + begin + if Sets.Has_Element (Position) then + Ref := Sets.Element (Position); + Ref.all.Refs := Ref.all.Refs + 1; + else + Ref := new Rec'(Data => Source, + Hash => Ada.Strings.Hash (Source), + Last => Source'Length, + Refs => 1); + Dict.Insert (Ref); + end if; + return (Ada.Finalization.Controlled with Ref); + end Constructor; + + function Eq (Left, Right : in Acc) return Boolean is + begin + pragma Assert (Left /= Right); + pragma Assert (Left.all.Data /= Right.all.Data); + return False; + end Eq; + + procedure Finalize (Object : in out Ptr) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Dict.Delete (Object.Ref); + Free (Object.Ref); + end if; + end if; + end Finalize; + + function Hash (Item : in Ptr) return Ada.Containers.Hash_Type + is (Item.Ref.all.Hash); + + function Key (Item : in Acc) return String + is (Item.all.Data); + + function To_String (Item : in Ptr) return String + is (Item.Ref.all.Data); + +end Types.Symbols; diff --git a/ada2/types-symbols.ads b/ada2/types-symbols.ads new file mode 100644 index 0000000000..b1368f1479 --- /dev/null +++ b/ada2/types-symbols.ads @@ -0,0 +1,59 @@ +with Ada.Containers; +private with Ada.Finalization; + +package Types.Symbols with Preelaborate is + + type Ptr is tagged private; + -- A wrapper for a pointer counting references. + + -- The default value is invalid, new variables must be assigned + -- immediately (a hidden discriminant would prevent this type to + -- become a field inside Types.Mal.T, so we check this with a + -- private invariant a fallback, an invariant in the private part + -- checks that any created object is affected before use. + + -- Assignment give another reference to the same storage. + + function Constructor (Source : in String) return Ptr with Inline; + -- The only way to assign a valid value. + + function To_String (Item : in Ptr) return String with Inline; + + -- The hash value is made available because symbols have a high + -- probability to end up as keys in an environment. + function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline; + + -- Equality compares the contents. + +private + + -- Only one instance is allocated with a given content. This + -- avoids many allocations and deallocations, since symbols are + -- expected to be used many times. + + -- Tests seem to show that this solution is a few percents faster + -- than Ada.Strings.Unbounded. + + -- As a side effect, some frequent string comparisons (with "def!" + -- or "fn*" for example) will become a bit more efficient because + -- comparing pointers is faster than comparing strings. + + -- It would be natural to store a Cursor from the global + -- dictionnary into Ptr, but this actually reduces the speed, + -- probably because it significantly increases the size of + -- Mal_Type. + + -- See README for the implementation of reference counting. + + type Rec; + type Acc is access Rec; + type Ptr is new Ada.Finalization.Controlled with record + Ref : Acc := null; + end record + with Invariant => Ref /= null; + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + -- Predefined equality is fine. + pragma Finalize_Storage_Only (Ptr); + +end Types.Symbols; diff --git a/ada2/types.adb b/ada2/types.adb deleted file mode 100644 index d87297f3c8..0000000000 --- a/ada2/types.adb +++ /dev/null @@ -1,37 +0,0 @@ -package body Types is - - function "=" (Left, Right : in Mal_Type) return Boolean is - (case Left.Kind is - when Kind_Nil => - Right.Kind = Kind_Nil, - when Kind_Atom => - Right.Kind = Kind_Atom - and then Atoms."=" (Left.Reference, Right.Reference), - when Kind_Boolean => - Right.Kind = Kind_Boolean - and then Left.Boolean_Value = Right.Boolean_Value, - when Kind_Number => - Right.Kind = Kind_Number - and then Left.Integer_Value = Right.Integer_Value, - when Kind_String | Kind_Keyword | Kind_Symbol => - Right.Kind = Left.Kind - and then Strings."=" (Left.S, Right.S), - when Kind_List | Kind_Vector => - Right.Kind in Kind_List | Kind_Vector - and then Lists."=" (Left.L, Right.L), - when Kind_Map => - Right.Kind = Kind_Map - and then Maps."=" (Left.Map, Right.Map), - when Kind_Function => - Right.Kind = Kind_Function - and then Lists."=" (Left.Formals, Right.Formals) - and then Atoms."=" (Left.Expression, Right.Expression) - and then Environments."=" (Left.Environment, Right.Environment), - when Kind_Native => - Right.Kind = Kind_Native and then Left.Native = Right.Native, - when Kind_Macro => - Right.Kind = Kind_Macro - and then Atoms."=" (Left.Mac_Expression, Right.Mac_Expression) - and then Lists."=" (Left.Mac_Formals, Right.Mac_Formals)); - -end Types; diff --git a/ada2/types.ads b/ada2/types.ads index 24c4d51e03..3e549a9b24 100644 --- a/ada2/types.ads +++ b/ada2/types.ads @@ -1,17 +1,7 @@ -with Atoms; -with Environments; -with Lists; -with Maps; -with Strings; +package Types with Pure is -package Types is - - type Mal_Type; - type Mal_Type_Array; - type Native_Function_Access is not null access - function (Arguments : in Mal_Type_Array) return Mal_Type; - - -- Make similar kinds consecutive for efficient case statements. + -- Similar kinds should be consecutive for efficient case + -- statements. type Kind_Type is (Kind_Nil, Kind_Atom, @@ -20,40 +10,11 @@ package Types is Kind_String, Kind_Symbol, Kind_Keyword, Kind_List, Kind_Vector, Kind_Map, - Kind_Macro, Kind_Function, Kind_Native); - - type Mal_Type (Kind : Kind_Type := Kind_Nil) is record - Meta : Atoms.Ptr; - case Kind is - when Kind_Nil => - null; - when Kind_Boolean => - Boolean_Value : Boolean; - when Kind_Number => - Integer_Value : Integer; - when Kind_Atom => - Reference : Atoms.Ptr; - when Kind_String | Kind_Keyword | Kind_Symbol => - S : Strings.Ptr; - when Kind_List | Kind_Vector => - L : Lists.Ptr; - when Kind_Map => - Map : Maps.Ptr; - when Kind_Native => - Native : Native_Function_Access; - when Kind_Function => - Formals : Lists.Ptr; - Expression : Atoms.Ptr; - Environment : Environments.Ptr; - when Kind_Macro => - Mac_Formals : Lists.Ptr; - Mac_Expression : Atoms.Ptr; - end case; - end record; - - function "=" (Left, Right : in Mal_Type) return Boolean; - -- By default, a list /= a vector. + Kind_Macro, Kind_Function, Kind_Builtin_With_Meta, Kind_Builtin); - type Mal_Type_Array is array (Positive range <>) of Types.Mal_Type; + -- Raised when a program attempts to execute something else than a + -- function or a macro, or when a builtin receives a bad argument + -- count, type or value. + Argument_Error : exception; end Types; From 6e2b7ddffea6e23d9e94654c7c2b69241a653a3f Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 3 Mar 2019 18:07:18 +0100 Subject: [PATCH 0486/1998] Various cosmetic improvements inspired by adacontrol. In Printer, Reader and Quasiquote: move subsubprogram into the subprogram calling it: this improves the readability and spares some adjust/finalizations. Force elaboration of Environments and Symbols before Core. Move some use clauses to the minimal scope requiring them. Remove some name clashes. Format more consistently. Add comments to distant 'begin' keywords. Give explicit list of remaining choices in crucial case statements. Remove unneeded parenthesis. Avoid unneeded exceptions. Explicit some initial values. --- ada2/Makefile | 2 +- ada2/core.adb | 112 +++++++++------- ada2/core.ads | 2 +- ada2/environments.adb | 30 ++--- ada2/environments.ads | 10 +- ada2/printer.adb | 269 +++++++++++++++++++-------------------- ada2/reader.adb | 79 ++++++------ ada2/step2_eval.adb | 14 +- ada2/step3_env.adb | 14 +- ada2/step4_if_fn_do.adb | 16 ++- ada2/step5_tco.adb | 19 +-- ada2/step6_file.adb | 19 +-- ada2/step7_quote.adb | 100 ++++++++------- ada2/step8_macros.adb | 103 ++++++++------- ada2/step9_try.adb | 103 ++++++++------- ada2/stepa_mal.adb | 103 ++++++++------- ada2/types-builtins.adb | 12 +- ada2/types-builtins.ads | 8 +- ada2/types-functions.adb | 18 +-- ada2/types-functions.ads | 6 +- ada2/types-lists.adb | 13 +- ada2/types-lists.ads | 4 +- ada2/types-maps.adb | 14 +- ada2/types-maps.ads | 4 +- 24 files changed, 578 insertions(+), 496 deletions(-) diff --git a/ada2/Makefile b/ada2/Makefile index a74b81ff2d..20cc5692aa 100644 --- a/ada2/Makefile +++ b/ada2/Makefile @@ -30,7 +30,7 @@ steps := $(step0) $(step13) $(step49) $(stepa) .PHONY: all clean all: $(steps) clean: - $(RM) *~ *.ali *.o b~*.ad[bs] gmon.out $(steps) + $(RM) *~ *.adt *.ali *.o b~*.ad[bs] gmon.out $(steps) # Tell Make how to detect out-of-date executables, and let gnatmake do # the rest when it must be executed. diff --git a/ada2/core.adb b/ada2/core.adb index 5027457f7f..cbbef7f4d5 100644 --- a/ada2/core.adb +++ b/ada2/core.adb @@ -1,31 +1,30 @@ -with Ada.Calendar; use type Ada.Calendar.Time; +with Ada.Calendar; with Ada.Characters.Latin_1; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Environments; +with Environments; pragma Elaborate_All (Environments); with Types.Atoms; with Types.Builtins; with Types.Functions; with Types.Lists; with Types.Maps; -with Types.Symbols.Names; +with Types.Symbols.Names; pragma Elaborate_All (Types.Symbols); with Printer; with Reader; package body Core is - package ASU renames Ada.Strings.Unbounded; use Types; - use Types.Lists; use type Mal.T; - use type Mal.T_Array; + + package ASU renames Ada.Strings.Unbounded; Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; - function Apply (Func : in Mal.T; - Args : in Mal.T_Array; - Name : in String) return Mal.T with Inline; + function Apply_Helper (Func : in Mal.T; + Args : in Mal.T_Array; + Name : in String) return Mal.T with Inline; -- If Func is not executable, report an exception using "name" as -- the built-in function name. @@ -107,10 +106,10 @@ package body Core is ---------------------------------------------------------------------- - function Apply (Func : in Mal.T; - Args : in Mal.T_Array; - Name : in String) - return Mal.T is + function Apply_Helper (Func : in Mal.T; + Args : in Mal.T_Array; + Name : in String) return Mal.T + is begin case Func.Kind is when Kind_Builtin => @@ -119,26 +118,34 @@ package body Core is return Func.Builtin_With_Meta.Data.all (Args); when Kind_Function => declare - Env : constant Environments.Ptr := Func.Function_Value.Closure.Sub; + Env : constant Environments.Ptr + := Func.Function_Value.Closure.Closure_Sub; begin Func.Function_Value.Set_Binds (Env, Args); return Eval_Ref.all (Func.Function_Value.Expression, Env); end; - when others => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Symbol | Kind_Keyword | Kind_List | Kind_Vector | Kind_Map + | Kind_Macro => raise Argument_Error with Name & ": cannot execute " & ASU.To_String (Printer.Pr_Str (Func)); end case; - end Apply; + end Apply_Helper; - function Apply (Args : in Mal.T_Array) return Mal.T - is (if Args'Length < 2 then - raise Argument_Error with "apply: expects at least 2 arguments" - elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "apply: last arg must a be list or vector" - else - Apply (Args (Args'First), - Args (Args'First + 1 .. Args'Last - 1) & Args (Args'Last).L, - "apply")); + function Apply (Args : in Mal.T_Array) return Mal.T is + use type Lists.Ptr; + begin + if Args'Length < 2 then + raise Argument_Error with "apply: expects at least 2 arguments"; + elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "apply: last arg must a be list or vector"; + else + return Apply_Helper (Args (Args'First), + Args (Args'First + 1 .. Args'Last - 1) + & Args (Args'Last).L, + "apply"); + end if; + end Apply; function Equals (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 2 then @@ -150,7 +157,7 @@ package body Core is is (if Args'Length /= 1 then raise Argument_Error with "eval: expects 1 argument" else - (Eval_Ref.all (Args (Args'First), Environments.Repl))); + Eval_Ref.all (Args (Args'First), Environments.Repl)); function Is_False (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then @@ -197,9 +204,9 @@ package body Core is R : Mal.T_Array (1 .. Args (Args'Last).L.Length); begin for I in R'Range loop - R (I) := Apply (Args (Args'First), - Mal.T_Array'(1 => Args (Args'Last).L.Element (I)), - "map"); + R (I) := Apply_Helper (Args (Args'First), + Mal.T_Array'(1 => Args (Args'Last).L.Element (I)), + "map"); end loop; return Lists.List (R); end; @@ -218,8 +225,12 @@ package body Core is Args (Args'First).Function_Value.Meta, when Kind_Builtin_With_Meta => Args (Args'First).Builtin_With_Meta.Meta, - when others => - Mal.Nil)); + when Kind_Builtin => + Mal.Nil, + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | + Kind_String | Kind_Symbol | Kind_Keyword | Kind_Macro => + raise Argument_Error + with "meta: expects a list, vector, map or function")); function Pr_Str (Args : in Mal.T_Array) return Mal.T is begin @@ -269,11 +280,12 @@ package body Core is raise Argument_Error with "readline: expects a keyword or string"; else Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S); - return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line); + if Ada.Text_IO.End_Of_File then + return Mal.Nil; + else + return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line); + end if; end if; - exception - when Ada.Text_IO.End_Error => - return Mal.Nil; end Readline; function Read_String (Args : in Mal.T_Array) return Mal.T @@ -358,10 +370,11 @@ package body Core is raise Argument_Error with "swap!: arg 1 must be an atom"; end if; declare + use type Mal.T_Array; X : Mal.T renames Atoms.Deref (Args (Args'First .. Args'First)); - FX : Mal.T renames Apply (Args (Args'First + 1), - X & Args (Args'First + 2 .. Args'Last), - "swap!"); + FX : Mal.T renames Apply_Helper (Args (Args'First + 1), + X & Args (Args'First + 2 .. Args'Last), + "swap!"); begin return Atoms.Reset (Mal.T_Array'(Args (Args'First), FX)); end; @@ -378,18 +391,21 @@ package body Core is begin if Args'Length /= 1 then raise Argument_Error with "throw: expects 1 argument"; - else - Last_Exception := Args (Args'First); - raise Exception_Throwed; - return Mal.Nil; -- GNAT wants a return. end if; + Last_Exception := Args (Args'First); + raise Exception_Throwed; + return Mal.Nil; -- GNAT wants a return end Throw; - function Time_Ms (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 0 then - raise Argument_Error with "time: expects no argument" - else - (Kind_Number, Integer (1000.0 * (Ada.Calendar.Clock - Start_Time)))); + function Time_Ms (Args : in Mal.T_Array) return Mal.T is + use type Ada.Calendar.Time; + begin + if 0 < Args'Length then + raise Argument_Error with "time: expects no argument"; + end if; + return (Kind_Number, + Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); + end Time_Ms; function With_Meta (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 2 then @@ -413,7 +429,7 @@ package body Core is use Symbols; R : Environments.Ptr renames Environments.Repl; B : Kind_Type renames Kind_Builtin; -begin +begin -- Core R.Set (Constructor ("+"), (B, Addition'Access)); R.Set (Constructor ("apply"), (B, Apply'Access)); R.Set (Constructor ("assoc"), (B, Maps.Assoc'Access)); diff --git a/ada2/core.ads b/ada2/core.ads index eb1d8dd008..1326d71857 100644 --- a/ada2/core.ads +++ b/ada2/core.ads @@ -12,7 +12,7 @@ package Core with Elaborate_Body is -- Set by the main program at startup. Exception_Throwed : exception; - Last_Exception : Types.Mal.T; + Last_Exception : Types.Mal.T := (Kind => Types.Kind_Nil); -- When the exception is throwed, Last_Exception is set with the -- related Data. diff --git a/ada2/environments.adb b/ada2/environments.adb index 75fef4b67c..d0e0802c69 100644 --- a/ada2/environments.adb +++ b/ada2/environments.adb @@ -72,6 +72,18 @@ package body Environments is end if; end Adjust; + function Closure_Sub (Outer : in Closure_Ptr'Class) return Ptr is + begin + Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + Top := Top + 1; + pragma Assert (Stack (Top).Data.Is_Empty); + pragma Assert (Stack (Top).Alias = null); + Stack (Top) := (Outer_On_Stack => False, + Outer_Ref => Outer.Ref, + others => <>); + return (Ada.Finalization.Limited_Controlled with Top); + end Closure_Sub; + function Copy_Pointer (Env : in Ptr) return Ptr is begin Stack (Env.Index).Refs := Stack (Env.Index).Refs + 1; @@ -279,8 +291,8 @@ package body Environments is -- unreferenced alias if any. end Replace_With_Sub; - procedure Replace_With_Sub (Env : in out Ptr; - Outer : in Closure_Ptr'Class) is + procedure Replace_With_Closure_Sub (Env : in out Ptr; + Outer : in Closure_Ptr'Class) is begin Finalize (Env); Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; @@ -291,7 +303,7 @@ package body Environments is Outer_Ref => Outer.Ref, others => <>); Env.Index := Top; - end Replace_With_Sub; + end Replace_With_Closure_Sub; procedure Set (Env : in Ptr; Key : in Symbols.Ptr; @@ -300,18 +312,6 @@ package body Environments is Stack (Env.Index).Data.Include (Key, New_Element); end Set; - function Sub (Outer : in Closure_Ptr'Class) return Ptr is - begin - Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; - Top := Top + 1; - pragma Assert (Stack (Top).Data.Is_Empty); - pragma Assert (Stack (Top).Alias = null); - Stack (Top) := (Outer_On_Stack => False, - Outer_Ref => Outer.Ref, - others => <>); - return (Ada.Finalization.Limited_Controlled with Top); - end Sub; - function Sub (Outer : in Ptr) return Ptr is R : Stack_Record renames Stack (Outer.Index); begin diff --git a/ada2/environments.ads b/ada2/environments.ads index 5ef4561372..c49c9cd78f 100644 --- a/ada2/environments.ads +++ b/ada2/environments.ads @@ -55,13 +55,11 @@ package Environments with Elaborate_Body is type Closure_Ptr is tagged private; Null_Closure : constant Closure_Ptr; - function Sub (Outer : in Closure_Ptr'Class) return Ptr; + function Closure_Sub (Outer : in Closure_Ptr'Class) return Ptr; - procedure Replace_With_Sub (Env : in out Ptr; - Outer : in Closure_Ptr'Class); - -- Like Env := Sub (Outer => Outer); except that Env is finalized - -- *before* the assignement, so its memory can be reused by the - -- new environment. This is important for tail call optimization. + procedure Replace_With_Closure_Sub (Env : in out Ptr; + Outer : in Closure_Ptr'Class); + -- Like Env := Closure_Sub (Outer); except that the type is limited. function New_Closure (Env : in Ptr'Class) return Closure_Ptr; -- The class-wide argument does not make much sense, but avoids diff --git a/ada2/printer.adb b/ada2/printer.adb index e768f05bbd..f9bee1745c 100644 --- a/ada2/printer.adb +++ b/ada2/printer.adb @@ -7,156 +7,145 @@ with Types.Maps; package body Printer is - use Ada.Strings.Unbounded; - use Types; + function Pr_Str (Ast : in Types.Mal.T; + Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String + is - procedure Print_Form (Buffer : in out Unbounded_String; - Ast : in Mal.T; - Readably : in Boolean); - procedure Print_List (Buffer : in out Unbounded_String; - List : in Lists.Ptr; - Readably : in Boolean) with Inline; - procedure Print_Function (Buffer : in out Unbounded_String; - Fn : in Functions.Ptr; - Readably : in Boolean) with Inline; - procedure Print_Map (Buffer : in out Unbounded_String; - Map : in Maps.Ptr; - Readably : in Boolean) with Inline; + use Ada.Strings.Unbounded; + use Types; - ---------------------------------------------------------------------- + Buffer : Unbounded_String := Null_Unbounded_String; + -- is appended the result character after character. - procedure Print_Form (Buffer : in out Unbounded_String; - Ast : in Mal.T; - Readably : in Boolean) is - begin - case Ast.Kind is - when Kind_Nil => - Append (Buffer, "nil"); - when Kind_Boolean => - if Ast.Ada_Boolean then - Append (Buffer, "true"); - else - Append (Buffer, "false"); + procedure Print_Form (Form_Ast : in Mal.T); + -- The recursive function traversing Ast for Pr_Str. + -- Form_Ast is the current node. + + ---------------------------------------------------------------------- + + procedure Print_Form (Form_Ast : in Mal.T) is + + procedure Print_List (List : in Lists.Ptr) with Inline; + -- An helper for Print_Form. + + procedure Print_List (List : in Lists.Ptr) is + begin + if 0 < List.Length then + Print_Form (List.Element (1)); + for I in 2 .. List.Length loop + Append (Buffer, ' '); + Print_Form (List.Element (I)); + end loop; end if; - when Kind_Symbol => - Append (Buffer, Ast.Symbol.To_String); - when Kind_Number => - declare - Img : constant String := Ast.Ada_Number'Img; - F : Positive := Img'First; - begin - if Img (F) = ' ' then - F := F + 1; + end Print_List; + + begin -- Print_Form + case Form_Ast.Kind is + when Kind_Nil => + Append (Buffer, "nil"); + when Kind_Boolean => + if Form_Ast.Ada_Boolean then + Append (Buffer, "true"); + else + Append (Buffer, "false"); end if; - Append (Buffer, Img (F .. Img'Last)); - end; - when Kind_Keyword => - Append (Buffer, ':'); - Append (Buffer, Ast.S); - when Kind_String => - if Readably then - Append (Buffer, '"'); + when Kind_Symbol => + Append (Buffer, Form_Ast.Symbol.To_String); + when Kind_Number => declare - C : Character; + Img : constant String := Integer'Image (Form_Ast.Ada_Number); + F : Positive := Img'First; begin - for I in 1 .. Length (Ast.S) loop - C := Element (Ast.S, I); - case C is - when '"' | '\' => - Append (Buffer, '\'); - Append (Buffer, C); - when Ada.Characters.Latin_1.LF => - Append (Buffer, "\n"); - when others => - Append (Buffer, C); - end case; - end loop; + if Img (F) = ' ' then + F := F + 1; + end if; + Append (Buffer, Img (F .. Img'Last)); end; - Append (Buffer, '"'); - else - Append (Buffer, Ast.S); - end if; - when Kind_List => - Append (Buffer, '('); - Print_List (Buffer, Ast.L, Readably); - Append (Buffer, ')'); - when Kind_Vector => - Append (Buffer, '['); - Print_List (Buffer, Ast.L, Readably); - Append (Buffer, ']'); - when Kind_Map => - Print_Map (Buffer, Ast.Map, Readably); - when Kind_Builtin | Kind_Builtin_With_Meta => - Append (Buffer, "#"); - when Kind_Function => - Append (Buffer, "#'); - when Kind_Macro => - Append (Buffer, "#'); - when Kind_Atom => - Append (Buffer, "(atom "); - Print_Form (Buffer, Atoms.Deref (Mal.T_Array'(1 => Ast)), - Readably); - Append (Buffer, ')'); - end case; - end Print_Form; - - procedure Print_Function (Buffer : in out Unbounded_String; - Fn : in Functions.Ptr; - Readably : in Boolean) is - begin - Print_List (Buffer, Fn.Formals, Readably); - Append (Buffer, " -> "); - Print_Form (Buffer, Fn.Expression, Readably); - end Print_Function; - - procedure Print_List (Buffer : in out Unbounded_String; - List : in Lists.Ptr; - Readably : in Boolean) is - begin - if 0 < List.Length then - Print_Form (Buffer, List.Element (1), Readably); - for I in 2 .. List.Length loop - Append (Buffer, ' '); - Print_Form (Buffer, List.Element (I), Readably); - end loop; - end if; - end Print_List; + when Kind_Keyword => + Append (Buffer, ':'); + Append (Buffer, Form_Ast.S); + when Kind_String => + if Readably then + declare + C : Character; + begin + Append (Buffer, '"'); + for I in 1 .. Length (Form_Ast.S) loop + C := Element (Form_Ast.S, I); + case C is + when '"' | '\' => + Append (Buffer, '\'); + Append (Buffer, C); + when Ada.Characters.Latin_1.LF => + Append (Buffer, "\n"); + when others => + Append (Buffer, C); + end case; + end loop; + Append (Buffer, '"'); + end; + else + Append (Buffer, Form_Ast.S); + end if; + when Kind_List => + Append (Buffer, '('); + Print_List (Form_Ast.L); + Append (Buffer, ')'); + when Kind_Vector => + Append (Buffer, '['); + Print_List (Form_Ast.L); + Append (Buffer, ']'); + when Kind_Map => + Append (Buffer, '{'); + declare + Is_First : Boolean := True; + procedure Process (Key : in Mal.T; + Element : in Mal.T); + procedure Iterate is new Maps.Iterate (Process); + procedure Process (Key : in Mal.T; + Element : in Mal.T) + is + begin + if Is_First then + Is_First := False; + else + Append (Buffer, ' '); + end if; + Print_Form (Key); + Append (Buffer, ' '); + Print_Form (Element); + end Process; + begin + Iterate (Form_Ast.Map); + end; + Append (Buffer, '}'); + when Kind_Builtin | Kind_Builtin_With_Meta => + Append (Buffer, "#"); + when Kind_Function => + Append (Buffer, "# "); + Print_Form (Form_Ast.Function_Value.Expression); + Append (Buffer, '>'); + when Kind_Macro => + Append (Buffer, "# "); + Print_Form (Form_Ast.Function_Value.Expression); + Append (Buffer, '>'); + when Kind_Atom => + Append (Buffer, "(atom "); + Print_Form (Atoms.Deref (Mal.T_Array'(1 => Form_Ast))); + Append (Buffer, ')'); + end case; + end Print_Form; - procedure Print_Map (Buffer : in out Unbounded_String; - Map : in Maps.Ptr; - Readably : in Boolean) is - Is_First : Boolean := True; - procedure Process (Key : in Mal.T; - Element : in Mal.T); - procedure Iterate is new Maps.Iterate (Process); - procedure Process (Key : in Mal.T; - Element : in Mal.T) is - begin - if Is_First then - Is_First := False; - else - Append (Buffer, ' '); - end if; - Print_Form (Buffer, Key, Readably); - Append (Buffer, ' '); - Print_Form (Buffer, Element, Readably); - end Process; - begin - Append (Buffer, '{'); - Iterate (Map); - Append (Buffer, '}'); - end Print_Map; + ---------------------------------------------------------------------- - function Pr_Str (Ast : in Mal.T; - Readably : in Boolean := True) return Unbounded_String is - begin - return Buffer : Unbounded_String do - Print_Form (Buffer, Ast, Readably); - end return; + begin -- Pr_Str + Print_Form (Form_Ast => Ast); + return Buffer; end Pr_Str; end Printer; diff --git a/ada2/reader.adb b/ada2/reader.adb index 36521eef21..776f60f9b5 100644 --- a/ada2/reader.adb +++ b/ada2/reader.adb @@ -7,13 +7,15 @@ with Types.Symbols.Names; package body Reader is - use Types; + function Read_Str (Source : in String) return Types.Mal.T is + + use Types; - function Read_Str (Source : in String) return Mal.T is First : Positive; Last : Natural := Source'First - 1; function Read_Form return Mal.T; + -- The recursive part of Read_Str. procedure Find_Next_Token; -- Search next token from index Last + 1. @@ -21,15 +23,8 @@ package body Reader is -- Find_Next_Token is normally invoked right before Read_Form, -- allowing the caller to check whether First <= Source'Last. - -- Helpers: - - -- Read_Atom has been merged into the same case/switch - -- statement, for clarity and efficiency. - function Read_List (Ending : in Character) return Mal.T_Array - with Inline; - function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline; - ---------------------------------------------------------------------- + procedure Find_Next_Token is use Ada.Characters.Latin_1; @@ -97,8 +92,43 @@ package body Reader is end Find_Next_Token; function Read_Form return Mal.T is + + -- Read_Atom has been merged into the same case/switch + -- statement, for clarity and efficiency. + function Read_List (Ending : in Character) return Mal.T_Array + with Inline; + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T + with Inline; + + function Read_List (Ending : in Character) return Mal.T_Array is + -- Using big arrays on the stack is faster than doing + -- repeated dynamic reallocations. + Buffer : Mal.T_Array (First + 1 .. Source'Last); + B_Last : Natural := Buffer'First - 1; + begin + loop + Find_Next_Token; + if Source'Last < First then + raise Reader_Error with "unbalanced '" & Ending & "'"; + end if; + exit when Source (First) = Ending; + B_Last := B_Last + 1; + Buffer (B_Last) := Read_Form; + end loop; + return Buffer (Buffer'First .. B_Last); + end Read_List; + + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is + begin + Find_Next_Token; + if Source'Last < First then + raise Reader_Error with "Unfinished '" & Symbol.To_String & "'"; + end if; + return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form)); + end Read_Quote; + use Ada.Strings.Unbounded; - begin + begin -- Read_Form. case Source (First) is when '(' => return Lists.List (Read_List (')')); @@ -188,33 +218,6 @@ package body Reader is end case; end Read_Form; - function Read_List (Ending : in Character) return Mal.T_Array is - -- Using big arrays on the stack is faster than doing - -- repeated dynamic reallocations. - Buffer : Mal.T_Array (First + 1 .. Source'Last); - B_Last : Natural := Buffer'First - 1; - begin - loop - Find_Next_Token; - if Source'Last < First then - raise Reader_Error with "unbalanced '" & Ending & "'"; - end if; - exit when Source (First) = Ending; - B_Last := B_Last + 1; - Buffer (B_Last) := Read_Form; - end loop; - return Buffer (Buffer'First .. B_Last); - end Read_List; - - function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is - begin - Find_Next_Token; - if Source'Last < First then - raise Reader_Error with "Unfinished '" & Symbol.To_String & "'"; - end if; - return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form)); - end Read_Quote; - ---------------------------------------------------------------------- begin diff --git a/ada2/step2_eval.adb b/ada2/step2_eval.adb index e37de05889..9010bb2c4f 100644 --- a/ada2/step2_eval.adb +++ b/ada2/step2_eval.adb @@ -45,8 +45,8 @@ procedure Step2_Eval is with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_Elements is new Lists.Generic_Eval (Environments.Map, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Map, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Map, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Map, Eval); ---------------------------------------------------------------------- @@ -58,6 +58,10 @@ procedure Step2_Eval is -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => declare S : constant String := Ast.Symbol.To_String; @@ -71,9 +75,9 @@ procedure Step2_Eval is end if; end; when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -94,8 +98,6 @@ procedure Step2_Eval is raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; diff --git a/ada2/step3_env.adb b/ada2/step3_env.adb index 224248e0ac..1b4448bfe2 100644 --- a/ada2/step3_env.adb +++ b/ada2/step3_env.adb @@ -37,8 +37,8 @@ procedure Step3_Env is with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); ---------------------------------------------------------------------- @@ -51,12 +51,16 @@ procedure Step3_Env is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -119,8 +123,6 @@ procedure Step3_Env is raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; diff --git a/ada2/step4_if_fn_do.adb b/ada2/step4_if_fn_do.adb index b4ed93798c..bce010d3dd 100644 --- a/ada2/step4_if_fn_do.adb +++ b/ada2/step4_if_fn_do.adb @@ -35,8 +35,8 @@ procedure Step4_If_Fn_Do is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -52,12 +52,16 @@ procedure Step4_If_Fn_Do is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -159,7 +163,7 @@ procedure Step4_If_Fn_Do is declare Args : Mal.T_Array (2 .. Ast.L.Length); New_Env : constant Environments.Ptr - := First.Function_Value.Closure.Sub; + := First.Function_Value.Closure.Closure_Sub; begin for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); @@ -171,8 +175,6 @@ procedure Step4_If_Fn_Do is raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; diff --git a/ada2/step5_tco.adb b/ada2/step5_tco.adb index 1a865079cf..c9182356b3 100644 --- a/ada2/step5_tco.adb +++ b/ada2/step5_tco.adb @@ -35,8 +35,8 @@ procedure Step5_Tco is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -44,7 +44,8 @@ procedure Step5_Tco is ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T is + Env0 : in Environments.Ptr) return Mal.T + is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; @@ -57,12 +58,16 @@ procedure Step5_Tco is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -171,7 +176,7 @@ procedure Step5_Tco is for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env.Replace_With_Sub (First.Function_Value.Closure); + Env.Replace_With_Closure_Sub (First.Function_Value.Closure); First.Function_Value.Set_Binds (Env, Args); Ast := First.Function_Value.Expression; goto Restart; @@ -180,8 +185,6 @@ procedure Step5_Tco is raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; diff --git a/ada2/step6_file.adb b/ada2/step6_file.adb index 85795d77bb..b5051634f5 100644 --- a/ada2/step6_file.adb +++ b/ada2/step6_file.adb @@ -36,8 +36,8 @@ procedure Step6_File is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -45,7 +45,8 @@ procedure Step6_File is ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T is + Env0 : in Environments.Ptr) return Mal.T + is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; @@ -58,12 +59,16 @@ procedure Step6_File is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -172,7 +177,7 @@ procedure Step6_File is for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env.Replace_With_Sub (First.Function_Value.Closure); + Env.Replace_With_Closure_Sub (First.Function_Value.Closure); First.Function_Value.Set_Binds (Env, Args); Ast := First.Function_Value.Expression; goto Restart; @@ -181,8 +186,6 @@ procedure Step6_File is raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; diff --git a/ada2/step7_quote.adb b/ada2/step7_quote.adb index c2b5438ff8..819ee88dc1 100644 --- a/ada2/step7_quote.adb +++ b/ada2/step7_quote.adb @@ -28,9 +28,6 @@ procedure Step7_Quote is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T; - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T with Inline; - -- Handle vectors and lists not starting with unquote. -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks @@ -46,8 +43,8 @@ procedure Step7_Quote is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -55,7 +52,8 @@ procedure Step7_Quote is ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T is + Env0 : in Environments.Ptr) return Mal.T + is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; @@ -68,12 +66,16 @@ procedure Step7_Quote is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -192,7 +194,7 @@ procedure Step7_Quote is for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env.Replace_With_Sub (First.Function_Value.Closure); + Env.Replace_With_Closure_Sub (First.Function_Value.Closure); First.Function_Value.Set_Binds (Env, Args); Ast := First.Function_Value.Expression; goto Restart; @@ -201,8 +203,6 @@ procedure Step7_Quote is raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; @@ -242,41 +242,55 @@ procedure Step7_Quote is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T - is (case Ast.Kind is - when Kind_Vector => Quasiquote (Ast.L, Env), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Kind_List => - (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote - then Eval (Ast.L.Element (2), Env) - else Quasiquote (Ast.L, Env)), - when others => Ast); + is - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); - begin - for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote - then - if R (I).L.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 argument"; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + -- Handle vectors and lists not starting with unquote. + + function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); + begin + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol + = Symbols.Names.Splice_Unquote + then + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 arg"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; + else + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), + Env))); end if; - R (I) := Eval (R (I).L.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; + end loop; + return Lists.Concat (R); + end Quasiquote_List; + + begin -- Quasiquote + case Ast.Kind is + when Kind_Vector => + -- When the test is updated, replace Kind_List with Kind_Vector. + return Quasiquote_List (Ast.L); + when Kind_List => + if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + then + return Eval (Ast.L.Element (2), Env); + else + return Quasiquote_List (Ast.L); end if; - else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); - end if; - end loop; - return Lists.Concat (R); + when others => + return Ast; + end case; end Quasiquote; ---------------------------------------------------------------------- diff --git a/ada2/step8_macros.adb b/ada2/step8_macros.adb index c73935b16d..c8712face3 100644 --- a/ada2/step8_macros.adb +++ b/ada2/step8_macros.adb @@ -28,9 +28,6 @@ procedure Step8_Macros is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T; - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T with Inline; - -- Handle vectors and lists not starting with unquote. -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks @@ -46,8 +43,8 @@ procedure Step8_Macros is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -55,7 +52,8 @@ procedure Step8_Macros is ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T is + Env0 : in Environments.Ptr) return Mal.T + is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; @@ -69,12 +67,16 @@ procedure Step8_Macros is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -216,7 +218,7 @@ procedure Step8_Macros is for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env.Replace_With_Sub (First.Function_Value.Closure); + Env.Replace_With_Closure_Sub (First.Function_Value.Closure); First.Function_Value.Set_Binds (Env, Args); Ast := First.Function_Value.Expression; goto Restart; @@ -230,14 +232,13 @@ procedure Step8_Macros is end; if Macroexpanding then return Ast; + else + goto Restart; end if; - goto Restart; when others => raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; @@ -277,41 +278,55 @@ procedure Step8_Macros is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T - is (case Ast.Kind is - when Kind_Vector => Quasiquote (Ast.L, Env), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Kind_List => - (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote - then Eval (Ast.L.Element (2), Env) - else Quasiquote (Ast.L, Env)), - when others => Ast); + is - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); - begin - for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote - then - if R (I).L.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 argument"; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + -- Handle vectors and lists not starting with unquote. + + function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); + begin + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol + = Symbols.Names.Splice_Unquote + then + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 arg"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; + else + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), + Env))); end if; - R (I) := Eval (R (I).L.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; + end loop; + return Lists.Concat (R); + end Quasiquote_List; + + begin -- Quasiquote + case Ast.Kind is + when Kind_Vector => + -- When the test is updated, replace Kind_List with Kind_Vector. + return Quasiquote_List (Ast.L); + when Kind_List => + if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + then + return Eval (Ast.L.Element (2), Env); + else + return Quasiquote_List (Ast.L); end if; - else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); - end if; - end loop; - return Lists.Concat (R); + when others => + return Ast; + end case; end Quasiquote; ---------------------------------------------------------------------- diff --git a/ada2/step9_try.adb b/ada2/step9_try.adb index 33ba83923d..2fa414f0ef 100644 --- a/ada2/step9_try.adb +++ b/ada2/step9_try.adb @@ -28,9 +28,6 @@ procedure Step9_Try is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T; - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T with Inline; - -- Handle vectors and lists not starting with unquote. -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks @@ -46,8 +43,8 @@ procedure Step9_Try is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -55,7 +52,8 @@ procedure Step9_Try is ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T is + Env0 : in Environments.Ptr) return Mal.T + is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; @@ -69,12 +67,16 @@ procedure Step9_Try is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -257,7 +259,7 @@ procedure Step9_Try is for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env.Replace_With_Sub (First.Function_Value.Closure); + Env.Replace_With_Closure_Sub (First.Function_Value.Closure); First.Function_Value.Set_Binds (Env, Args); Ast := First.Function_Value.Expression; goto Restart; @@ -271,14 +273,13 @@ procedure Step9_Try is end; if Macroexpanding then return Ast; + else + goto Restart; end if; - goto Restart; when others => raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; @@ -322,41 +323,55 @@ procedure Step9_Try is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T - is (case Ast.Kind is - when Kind_Vector => Quasiquote (Ast.L, Env), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Kind_List => - (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote - then Eval (Ast.L.Element (2), Env) - else Quasiquote (Ast.L, Env)), - when others => Ast); + is - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); - begin - for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote - then - if R (I).L.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 argument"; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + -- Handle vectors and lists not starting with unquote. + + function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); + begin + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol + = Symbols.Names.Splice_Unquote + then + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 arg"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; + else + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), + Env))); end if; - R (I) := Eval (R (I).L.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; + end loop; + return Lists.Concat (R); + end Quasiquote_List; + + begin -- Quasiquote + case Ast.Kind is + when Kind_Vector => + -- When the test is updated, replace Kind_List with Kind_Vector. + return Quasiquote_List (Ast.L); + when Kind_List => + if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + then + return Eval (Ast.L.Element (2), Env); + else + return Quasiquote_List (Ast.L); end if; - else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); - end if; - end loop; - return Lists.Concat (R); + when others => + return Ast; + end case; end Quasiquote; ---------------------------------------------------------------------- diff --git a/ada2/stepa_mal.adb b/ada2/stepa_mal.adb index 5cbae9b21a..b660e17753 100644 --- a/ada2/stepa_mal.adb +++ b/ada2/stepa_mal.adb @@ -28,9 +28,6 @@ procedure StepA_Mal is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T; - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T with Inline; - -- Handle vectors and lists not starting with unquote. -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks @@ -46,8 +43,8 @@ procedure StepA_Mal is procedure Interactive_Loop (Repl : in Environments.Ptr); - function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); -- Convenient when the result of eval is of no interest. procedure Discard (Ast : in Mal.T) is null; @@ -55,7 +52,8 @@ procedure StepA_Mal is ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T is + Env0 : in Environments.Ptr) return Mal.T + is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; @@ -69,12 +67,16 @@ procedure StepA_Mal is -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); -- Environments.Dump_Stack; case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => - return Eval_Elements (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_Elements (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); when Kind_List => if Ast.L.Length = 0 then return Ast; @@ -266,7 +268,7 @@ procedure StepA_Mal is for I in Args'Range loop Args (I) := Eval (Ast.L.Element (I), Env); end loop; - Env.Replace_With_Sub (First.Function_Value.Closure); + Env.Replace_With_Closure_Sub (First.Function_Value.Closure); First.Function_Value.Set_Binds (Env, Args); Ast := First.Function_Value.Expression; goto Restart; @@ -280,14 +282,13 @@ procedure StepA_Mal is end; if Macroexpanding then return Ast; + else + goto Restart; end if; - goto Restart; when others => raise Argument_Error with "cannot execute " & ASU.To_String (Print (First)); end case; - when others => - return Ast; end case; end Eval; @@ -331,41 +332,55 @@ procedure StepA_Mal is function Quasiquote (Ast : in Mal.T; Env : in Environments.Ptr) return Mal.T - is (case Ast.Kind is - when Kind_Vector => Quasiquote (Ast.L, Env), - -- When the test is updated, replace Kind_List with Kind_Vector. - when Kind_List => - (if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote - then Eval (Ast.L.Element (2), Env) - else Quasiquote (Ast.L, Env)), - when others => Ast); + is - function Quasiquote (List : in Lists.Ptr; - Env : in Environments.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); - begin - for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol = Symbols.Names.Splice_Unquote - then - if R (I).L.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 argument"; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + -- Handle vectors and lists not starting with unquote. + + function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + -- The final return concatenates these lists. + R : Mal.T_Array (1 .. List.Length); + begin + for I in R'Range loop + R (I) := List.Element (I); + if R (I).Kind in Kind_List | Kind_Vector + and then 0 < R (I).L.Length + and then R (I).L.Element (1).Kind = Kind_Symbol + and then R (I).L.Element (1).Symbol + = Symbols.Names.Splice_Unquote + then + if R (I).L.Length /= 2 then + raise Argument_Error with "splice-unquote: expects 1 arg"; + end if; + R (I) := Eval (R (I).L.Element (2), Env); + if R (I).Kind /= Kind_List then + raise Argument_Error with "splice-unquote: expects a list"; + end if; + else + R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), + Env))); end if; - R (I) := Eval (R (I).L.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; + end loop; + return Lists.Concat (R); + end Quasiquote_List; + + begin -- Quasiquote + case Ast.Kind is + when Kind_Vector => + -- When the test is updated, replace Kind_List with Kind_Vector. + return Quasiquote_List (Ast.L); + when Kind_List => + if 0 < Ast.L.Length + and then Ast.L.Element (1).Kind = Kind_Symbol + and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + then + return Eval (Ast.L.Element (2), Env); + else + return Quasiquote_List (Ast.L); end if; - else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env))); - end if; - end loop; - return Lists.Concat (R); + when others => + return Ast; + end case; end Quasiquote; ---------------------------------------------------------------------- diff --git a/ada2/types-builtins.adb b/ada2/types-builtins.adb index fa939a7da2..7f1dd79db0 100644 --- a/ada2/types-builtins.adb +++ b/ada2/types-builtins.adb @@ -37,17 +37,17 @@ package body Types.Builtins is function Meta (Item : in Ptr_With_Meta) return Mal.T is (Item.Ref.all.Meta); - function With_Meta (Data : in Ptr; - Meta : in Mal.T) return Mal.T + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Mal.T is (Kind_Builtin_With_Meta, (Ada.Finalization.Controlled with new Rec' (Data => Data, - Meta => Meta, + Meta => Metadata, Refs => 1))); - function With_Meta (Data : in Ptr_With_Meta; - Meta : in Mal.T) return Mal.T + function With_Meta (Data : in Ptr_With_Meta; + Metadata : in Mal.T) return Mal.T -- Do not try to reuse the memory. We can hope that this kind of -- nonsense will be rare. - is (With_Meta (Data.Data, Meta)); + is (With_Meta (Data.Data, Metadata)); end Types.Builtins; diff --git a/ada2/types-builtins.ads b/ada2/types-builtins.ads index abb118e30b..7ad35db427 100644 --- a/ada2/types-builtins.ads +++ b/ada2/types-builtins.ads @@ -22,10 +22,10 @@ package Types.Builtins is -- Assignment give another reference to the same storage. - function With_Meta (Data : in Ptr; - Meta : in Mal.T) return Mal.T with Inline; - function With_Meta (Data : in Ptr_With_Meta; - Meta : in Mal.T) return Mal.T with Inline; + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Mal.T with Inline; + function With_Meta (Data : in Ptr_With_Meta; + Metadata : in Mal.T) return Mal.T with Inline; function Meta (Item : in Ptr_With_Meta) return Mal.T with Inline; function Data (Item : in Ptr_With_Meta) return Ptr with Inline; diff --git a/ada2/types-functions.adb b/ada2/types-functions.adb index 5360d83144..b40914767c 100644 --- a/ada2/types-functions.adb +++ b/ada2/types-functions.adb @@ -17,7 +17,7 @@ package body Types.Functions is Refs : Natural := 1; Args : Lists.Ptr; Expr : Mal.T; - Env : Environments.Closure_Ptr; + Env : Environments.Closure_Ptr := Environments.Null_Closure; Varargs : Boolean; Meta : Mal.T := Mal.Nil; end record; @@ -91,7 +91,8 @@ package body Types.Functions is procedure Set_Binds (Item : in Ptr; Env : in Environments.Ptr; - Args : in Mal.T_Array) is + Args : in Mal.T_Array) + is R : Rec renames Item.Ref.all; begin if R.Varargs then @@ -119,7 +120,8 @@ package body Types.Functions is procedure Set_Binds (Item : in Ptr; Env : in Environments.Ptr; - Args : in Lists.Ptr) is + Args : in Lists.Ptr) + is R : Rec renames Item.Ref.all; begin if R.Varargs then @@ -145,9 +147,9 @@ package body Types.Functions is end if; end Set_Binds; - function With_Meta (Data : in Ptr; - Meta : in Mal.T) - return Mal.T is + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Mal.T + is Old : Rec renames Data.Ref.all; Ref : Acc; begin @@ -155,13 +157,13 @@ package body Types.Functions is if Old.Refs = 1 then Ref := Data.Ref; Old.Refs := 2; - Old.Meta := Meta; + Old.Meta := Metadata; else Ref := new Rec'(Args => Data.Ref.all.Args, Expr => Data.Ref.all.Expr, Env => Data.Ref.all.Env, Varargs => Data.Ref.all.Varargs, - Meta => Meta, + Meta => Metadata, others => <>); end if; diff --git a/ada2/types-functions.ads b/ada2/types-functions.ads index 35aabee2c3..ec996b38be 100644 --- a/ada2/types-functions.ads +++ b/ada2/types-functions.ads @@ -45,9 +45,9 @@ package Types.Functions is function Closure (Item : in Ptr) return Environments.Closure_Ptr with Inline; - function Meta (Item : in Ptr) return Mal.T with inline; - function With_Meta (Data : in Ptr; - Meta : in Mal.T) + function Meta (Item : in Ptr) return Mal.T with Inline; + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Mal.T with Inline; private diff --git a/ada2/types-lists.adb b/ada2/types-lists.adb index a20ba3e8a6..7f25702915 100644 --- a/ada2/types-lists.adb +++ b/ada2/types-lists.adb @@ -145,7 +145,8 @@ package body Types.Lists is function Generic_Eval (Container : in Ptr; Env : in Env_Type) - return Ptr is + return Ptr + is -- Take care that automatic deallocation happens if an -- exception is propagated by user code. Old : Rec renames Container.Ref.all; @@ -237,9 +238,9 @@ package body Types.Lists is Last => Args'Length, others => <>))); - function With_Meta (Data : in Ptr; - Meta : in Mal.T) - return Ptr is + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Ptr + is Old : Rec renames Data.Ref.all; Ref : Acc; begin @@ -247,11 +248,11 @@ package body Types.Lists is if Old.Refs = 1 then Ref := Data.Ref; Old.Refs := 2; - Old.Meta := Meta; + Old.Meta := Metadata; else Ref := new Rec'(Last => Old.Last, Data => Old.Data, - Meta => Meta, + Meta => Metadata, others => <>); end if; return (AFC with Ref); diff --git a/ada2/types-lists.ads b/ada2/types-lists.ads index b8678f2f1c..1e9906315d 100644 --- a/ada2/types-lists.ads +++ b/ada2/types-lists.ads @@ -55,8 +55,8 @@ package Types.Lists is return Mal.T; function Meta (Item : in Ptr) return Mal.T with Inline; - function With_Meta (Data : in Ptr; - Meta : in Mal.T) + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Ptr; private diff --git a/ada2/types-maps.adb b/ada2/types-maps.adb index 9f70440b50..b0c333ff4a 100644 --- a/ada2/types-maps.adb +++ b/ada2/types-maps.adb @@ -122,7 +122,8 @@ package body Types.Maps is function Generic_Eval (Container : in Ptr; Env : in Env_Type) - return Mal.T is + return Mal.T + is -- Copy the whole hash in order to avoid recomputing the hash -- for each key, even if it implies unneeded calls to adjust -- and finalize for Mal_Type values. @@ -244,9 +245,10 @@ package body Types.Maps is end; end Vals; - function With_Meta (Data : in Ptr; - Meta : in Mal.T) - return Mal.T is + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) + return Mal.T + is Old : Rec renames Data.Ref.all; Ref : Acc; begin @@ -254,10 +256,10 @@ package body Types.Maps is if Old.Refs = 1 then Ref := Data.Ref; Old.Refs := 2; - Old.Meta := Meta; + Old.Meta := Metadata; else Ref := new Rec'(Data => Old.Data, - Meta => Meta, + Meta => Metadata, others => <>); end if; return (Kind_Map, (AFC with Ref)); diff --git a/ada2/types-maps.ads b/ada2/types-maps.ads index 7de5d954ba..3fd07b459e 100644 --- a/ada2/types-maps.ads +++ b/ada2/types-maps.ads @@ -46,8 +46,8 @@ package Types.Maps is function Meta (Container : in Ptr) return Mal.T with Inline; - function With_Meta (Data : in Ptr; - Meta : in Mal.T) + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Mal.T; private From 11932a6c8928b0776c360509eece5a5d0042afbc Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Wed, 6 Mar 2019 19:48:51 +0100 Subject: [PATCH 0487/1998] Improve conformity with the MAL process, performance and readability. Conformity: Move readline to readline.ads and drop the Interactive_Loop subprogram. Let the main Read and Print functions do input/output. Rename environments.ads to envs.ads (the name of the eval parameter seems more important). Move association of formal and actual parameters to the env "constructor". Use the documentation names whenever possible (especially, make calls to Eval where they are expected and explicit the parameters). Iterate on a NS structure provided by Core, as per the process. Use similar method names for Envs.Ptr and Envs.Closure_Ptr, as the difference is an implementation detail. Performance: Move Map into list methods, swap into atom methods. Pass formal parameters as an array of symbols on the stack, instead of a MAL list. Readability: Replace some one-letter names. Use renamings when the lines become too long. Split Pr_Str in small subprograms. Declare the access to built-in functions in Types.Mal. Consistent names. Move redundant comments into README. --- ada2/Makefile | 23 +- ada2/README | 20 +- ada2/core.adb | 430 +++++++++++++--------------- ada2/core.ads | 24 +- ada2/{environments.adb => envs.adb} | 131 +++++++-- ada2/{environments.ads => envs.ads} | 56 ++-- ada2/eval_cb.ads | 11 + ada2/printer.adb | 194 +++++++------ ada2/printer.ads | 5 + ada2/reader.adb | 3 +- ada2/readline.adb | 32 +++ ada2/readline.ads | 7 + ada2/step0_repl.adb | 64 ++--- ada2/step1_read_print.adb | 77 ++--- ada2/step2_eval.adb | 124 ++++---- ada2/step3_env.adb | 145 +++++----- ada2/step4_if_fn_do.adb | 189 ++++++------ ada2/step5_tco.adb | 190 ++++++------ ada2/step6_file.adb | 194 +++++++------ ada2/step7_quote.adb | 230 +++++++-------- ada2/step8_macros.adb | 256 +++++++++-------- ada2/step9_try.adb | 279 +++++++++--------- ada2/stepa_mal.adb | 289 ++++++++++--------- ada2/types-atoms.adb | 48 +++- ada2/types-atoms.ads | 13 +- ada2/types-builtins.adb | 28 +- ada2/types-builtins.ads | 39 +-- ada2/types-functions.adb | 173 +++++------ ada2/types-functions.ads | 58 ++-- ada2/types-lists.adb | 170 +++++++---- ada2/types-lists.ads | 10 +- ada2/types-mal.adb | 4 +- ada2/types-mal.ads | 14 +- ada2/types-maps.ads | 11 - ada2/types-symbols.adb | 22 ++ ada2/types-symbols.ads | 19 +- 36 files changed, 1858 insertions(+), 1724 deletions(-) rename ada2/{environments.adb => envs.adb} (74%) rename ada2/{environments.ads => envs.ads} (65%) create mode 100644 ada2/eval_cb.ads create mode 100644 ada2/readline.adb create mode 100644 ada2/readline.ads diff --git a/ada2/Makefile b/ada2/Makefile index 20cc5692aa..4bbee5d0c9 100644 --- a/ada2/Makefile +++ b/ada2/Makefile @@ -35,9 +35,11 @@ clean: # Tell Make how to detect out-of-date executables, and let gnatmake do # the rest when it must be executed. TYPES := \ - environments.ads environments.adb \ + envs.ads envs.adb \ + eval_cb.ads \ printer.ads printer.adb \ reader.ads reader.adb \ + readline.ads \ types-atoms.ads types-atoms.adb \ types-builtins.ads types-builtins.adb \ types-functions.ads types-functions.adb \ @@ -59,12 +61,13 @@ $(steps) : .PHONY: steps.diff steps.diff: - diff -u step1*.adb step2*.adb; \ - diff -u step2*.adb step3*.adb; \ - diff -u step3*.adb step4*.adb; \ - diff -u step4*.adb step5*.adb; \ - diff -u step5*.adb step6*.adb; \ - diff -u step6*.adb step7*.adb; \ - diff -u step7*.adb step8*.adb; \ - diff -u step8*.adb step9*.adb; \ - diff -u step9*.adb stepa*.adb || true + diff -u step0_*.adb step1_*.adb || true + diff -u step1_*.adb step2_*.adb || true + diff -u step2_*.adb step3_*.adb || true + diff -u step3_*.adb step4_*.adb || true + diff -u step4_*.adb step5_*.adb || true + diff -u step5_*.adb step6_*.adb || true + diff -u step6_*.adb step7_*.adb || true + diff -u step7_*.adb step8_*.adb || true + diff -u step8_*.adb step9_*.adb || true + diff -u step9_*.adb stepa_*.adb || true diff --git a/ada2/README b/ada2/README index 1593347ac3..c2d8e560b7 100644 --- a/ada2/README +++ b/ada2/README @@ -1,15 +1,15 @@ Comparison with the first Ada implementation. The first implementation was deliberately compatible with all Ada -compilers, while this one illustrates various Ada 2012 features, like +compilers, while this one illustrates various Ada 2012 features: assertions, preconditions, invariants, initial assignment for limited types, limited imports... The variant MAL type is implemented with a discriminant instead of object-style dispatching. This allows more static and dynamic checks, but also two crucial performance improvements: -* Nil, boolean and integers are passed by value without dynamic - allocation. +* Nil, boolean, integers and built-in functions are passed by value + without dynamic allocation. * Lists are implemented as C-style arrays, and most of them can be allocated on the stack. @@ -24,18 +24,24 @@ bounds and discriminant consistency are only enabled during tests). There are also similarities with the first implementation. For example, both rely on user-defined finalization to handle recursive -structures without garbage collecting. +structures without garbage collecting. Also, most pointer types are +wrapped into a finalized type counting references. +Some remarks if anyone works on this. -About reference reference counting. +* The default value for such wrapped pointers is invalid, new + variables must be assigned immediately. This is usually enforced by + a hidden discriminant, but this would prevent the type to become a + field inside Types.Mal.T. So we usse a private invariant as a a + fallback. * The finalize procedure may be called twice, so it does nothing when the reference count is zero, meaning that we are reaching Finalize recursively. + * In implementations, a consistent object (that will be deallocated automatically) must be built before any exception is raised by user - code (for example 'map' may run user functions). - + code (for example the 'map' built-in function may run user code). Known bugs: the third step of the perf^ada2 target fails during the final storage deallocation when the executable is built with -gnatp. I diff --git a/ada2/core.adb b/ada2/core.adb index cbbef7f4d5..03e2ccc150 100644 --- a/ada2/core.adb +++ b/ada2/core.adb @@ -3,65 +3,63 @@ with Ada.Characters.Latin_1; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Environments; pragma Elaborate_All (Environments); +with Envs; +with Eval_Cb; with Types.Atoms; with Types.Builtins; with Types.Functions; with Types.Lists; with Types.Maps; -with Types.Symbols.Names; pragma Elaborate_All (Types.Symbols); +with Types.Symbols.Names; with Printer; with Reader; package body Core is use Types; - use type Mal.T; - package ASU renames Ada.Strings.Unbounded; + -- Used by time_ms. Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; - function Apply_Helper (Func : in Mal.T; - Args : in Mal.T_Array; - Name : in String) return Mal.T with Inline; - -- If Func is not executable, report an exception using "name" as - -- the built-in function name. + -- In the following helpers, "name" is the one reported by error + -- messages. generic Kind : in Kind_Type; Name : in String; function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T; function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 - then raise Argument_Error with Name & ": expects 1 argument" - else (Kind_Boolean, Args (Args'First).Kind = Kind)); + is (if Args'Length /= 1 then + raise Argument_Error with Name & ": expects 1 argument" + else + (Kind_Boolean, Args (Args'First).Kind = Kind)); generic with function Ada_Operator (Left, Right : in Integer) return Integer; Name : in String; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 - then raise Argument_Error with Name & ": expects 2 arguments" - elsif (for some A of Args => A.Kind /= Kind_Number) - then raise Argument_Error with Name & ": expects numbers" - else (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number, - Args (Args'Last).Ada_Number))); - + is (if Args'Length /= 2 then + raise Argument_Error with Name & ": expects 2 arguments" + elsif (for some A of Args => A.Kind /= Kind_Number) then + raise Argument_Error with Name & ": expects numbers" + else + (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number))); generic with function Ada_Operator (Left, Right : in Integer) return Boolean; Name : in String; function Generic_Comparison (Args : in Mal.T_Array) return Mal.T; function Generic_Comparison (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 - then raise Argument_Error with Name & ": expects 2 arguments" - elsif (for some A of Args => A.Kind /= Kind_Number) - then raise Argument_Error with Name & ": expects numbers" - else (Kind_Boolean, Ada_Operator (Args (Args'First).Ada_Number, - Args (Args'Last).Ada_Number))); - - -- Built-in functions from this package. + is (if Args'Length /= 2 then + raise Argument_Error with Name & ": expects 2 arguments" + elsif (for some A of Args => A.Kind /= Kind_Number) then + raise Argument_Error with Name & ": expects numbers" + else + (Kind_Boolean, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number))); + function Addition is new Generic_Mal_Operator ("+", "+"); function Apply (Args : in Mal.T_Array) return Mal.T; function Division is new Generic_Mal_Operator ("/", "/"); @@ -86,7 +84,6 @@ package body Core is function Keyword (Args : in Mal.T_Array) return Mal.T; function Less_Equal is new Generic_Comparison ("<=", "<="); function Less_Than is new Generic_Comparison ("<", "<"); - function Map (Args : in Mal.T_Array) return Mal.T; function Meta (Args : in Mal.T_Array) return Mal.T; function Pr_Str (Args : in Mal.T_Array) return Mal.T; function Println (Args : in Mal.T_Array) return Mal.T; @@ -98,7 +95,6 @@ package body Core is function Slurp (Args : in Mal.T_Array) return Mal.T; function Str (Args : in Mal.T_Array) return Mal.T; function Subtraction is new Generic_Mal_Operator ("-", "-"); - function Swap (Args : in Mal.T_Array) return Mal.T; function Symbol (Args : in Mal.T_Array) return Mal.T; function Throw (Args : in Mal.T_Array) return Mal.T; function Time_Ms (Args : in Mal.T_Array) return Mal.T; @@ -106,58 +102,49 @@ package body Core is ---------------------------------------------------------------------- - function Apply_Helper (Func : in Mal.T; - Args : in Mal.T_Array; - Name : in String) return Mal.T - is - begin - case Func.Kind is - when Kind_Builtin => - return Func.Builtin.all (Args); - when Kind_Builtin_With_Meta => - return Func.Builtin_With_Meta.Data.all (Args); - when Kind_Function => - declare - Env : constant Environments.Ptr - := Func.Function_Value.Closure.Closure_Sub; - begin - Func.Function_Value.Set_Binds (Env, Args); - return Eval_Ref.all (Func.Function_Value.Expression, Env); - end; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Symbol | Kind_Keyword | Kind_List | Kind_Vector | Kind_Map - | Kind_Macro => - raise Argument_Error with Name & ": cannot execute " - & ASU.To_String (Printer.Pr_Str (Func)); - end case; - end Apply_Helper; - function Apply (Args : in Mal.T_Array) return Mal.T is use type Lists.Ptr; begin if Args'Length < 2 then raise Argument_Error with "apply: expects at least 2 arguments"; elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "apply: last arg must a be list or vector"; - else - return Apply_Helper (Args (Args'First), - Args (Args'First + 1 .. Args'Last - 1) - & Args (Args'Last).L, - "apply"); + raise Argument_Error with "apply: last arg must be a list or vector"; end if; + declare + F : Mal.T renames Args (Args'First); + A : constant Mal.T_Array + := Args (Args'First + 1 .. Args'Last - 1) & Args (Args'Last).List; + begin + case F.Kind is + when Kind_Builtin => + return F.Builtin.all (A); + when Kind_Builtin_With_Meta => + return F.Builtin_With_Meta.Builtin.all (A); + when Kind_Function => + return F.Fn.Apply (A); + when others => + raise Argument_Error + with "apply: cannot call " & Printer.Img (F); + end case; + end; end Apply; - function Equals (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 then - raise Argument_Error with "=: expects 2 arguments" - else - (Kind_Boolean, Args (Args'First) = Args (Args'Last))); + function Equals (Args : in Mal.T_Array) return Mal.T is + use type Mal.T; + begin + if Args'Length /= 2 then + raise Argument_Error with "=: expects 2 arguments"; + else + return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); + end if; + end Equals; function Eval (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then raise Argument_Error with "eval: expects 1 argument" else - Eval_Ref.all (Args (Args'First), Environments.Repl)); + Eval_Cb.Cb.all (Ast => Args (Args'First), + Env => Envs.Repl)); function Is_False (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then @@ -193,81 +180,136 @@ package body Core is else (Kind_Keyword, Args (Args'First).S)); - function Map (Args : in Mal.T_Array) return Mal.T is + function Meta (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 2 then - raise Argument_Error with "map: expects 2 arguments"; - elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "map: arg 2 must be a list or vector"; + if Args'Length /= 1 then + raise Argument_Error with "meta: expects 1 argument"; end if; declare - R : Mal.T_Array (1 .. Args (Args'Last).L.Length); + A1 : Mal.T renames Args (Args'First); begin - for I in R'Range loop - R (I) := Apply_Helper (Args (Args'First), - Mal.T_Array'(1 => Args (Args'Last).L.Element (I)), - "map"); - end loop; - return Lists.List (R); - end; - end Map; - - function Meta (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "meta: expects 1 argument" - else - (case Args (Args'First).Kind is + case A1.Kind is when Kind_List | Kind_Vector => - Args (Args'First).L.Meta, + return A1.List.Meta; when Kind_Map => - Args (Args'First).Map.Meta, + return A1.Map.Meta; when Kind_Function => - Args (Args'First).Function_Value.Meta, + return A1.Fn.Meta; when Kind_Builtin_With_Meta => - Args (Args'First).Builtin_With_Meta.Meta, + return A1.Builtin_With_Meta.Meta; when Kind_Builtin => - Mal.Nil, - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | - Kind_String | Kind_Symbol | Kind_Keyword | Kind_Macro => + return Mal.Nil; + when others => raise Argument_Error - with "meta: expects a list, vector, map or function")); + with "meta: expects a list, vector, map or function"; + end case; + end; + end Meta; + + function Ns return Binding_List + is ((Symbols.Constructor ("+"), Addition'Access), + (Symbols.Constructor ("apply"), Apply'Access), + (Symbols.Constructor ("assoc"), Maps.Assoc'Access), + (Symbols.Constructor ("atom"), Atoms.Atom'Access), + (Symbols.Constructor ("concat"), Lists.Concat'Access), + (Symbols.Constructor ("conj"), Lists.Conj'Access), + (Symbols.Constructor ("cons"), Lists.Cons'Access), + (Symbols.Constructor ("contains?"), Maps.Contains'Access), + (Symbols.Constructor ("count"), Lists.Count'Access), + (Symbols.Names.Deref, Atoms.Deref'Access), + (Symbols.Constructor ("dissoc"), Maps.Dissoc'Access), + (Symbols.Constructor ("/"), Division'Access), + (Symbols.Constructor ("="), Equals'Access), + (Symbols.Constructor ("eval"), Eval'Access), + (Symbols.Constructor ("first"), Lists.First'Access), + (Symbols.Constructor ("get"), Maps.Get'Access), + (Symbols.Constructor (">="), Greater_Equal'Access), + (Symbols.Constructor (">"), Greater_Than'Access), + (Symbols.Constructor ("hash-map"), Maps.Hash_Map'Access), + (Symbols.Constructor ("atom?"), Is_Atom'Access), + (Symbols.Constructor ("empty?"), Lists.Is_Empty'Access), + (Symbols.Constructor ("false?"), Is_False'Access), + (Symbols.Constructor ("fn?"), Is_Function'Access), + (Symbols.Constructor ("keyword?"), Is_Keyword'Access), + (Symbols.Constructor ("list?"), Is_List'Access), + (Symbols.Constructor ("macro?"), Is_Macro'Access), + (Symbols.Constructor ("map?"), Is_Map'Access), + (Symbols.Constructor ("nil?"), Is_Nil'Access), + (Symbols.Constructor ("number?"), Is_Number'Access), + (Symbols.Constructor ("sequential?"), Is_Sequential'Access), + (Symbols.Constructor ("string?"), Is_String'Access), + (Symbols.Constructor ("symbol?"), Is_Symbol'Access), + (Symbols.Constructor ("true?"), Is_True'Access), + (Symbols.Constructor ("vector?"), Is_Vector'Access), + (Symbols.Constructor ("keys"), Maps.Keys'Access), + (Symbols.Constructor ("keyword"), Keyword'Access), + (Symbols.Constructor ("<="), Less_Equal'Access), + (Symbols.Constructor ("<"), Less_Than'Access), + (Symbols.Constructor ("list"), Lists.List'Access), + (Symbols.Constructor ("map"), Lists.Map'Access), + (Symbols.Constructor ("meta"), Meta'Access), + (Symbols.Constructor ("nth"), Lists.Nth'Access), + (Symbols.Constructor ("pr-str"), Pr_Str'Access), + (Symbols.Constructor ("println"), Println'Access), + (Symbols.Constructor ("prn"), Prn'Access), + (Symbols.Constructor ("*"), Product'Access), + (Symbols.Constructor ("read-string"), Read_String'Access), + (Symbols.Constructor ("readline"), Readline'Access), + (Symbols.Constructor ("reset!"), Atoms.Reset'Access), + (Symbols.Constructor ("rest"), Lists.Rest'Access), + (Symbols.Constructor ("seq"), Seq'Access), + (Symbols.Constructor ("slurp"), Slurp'Access), + (Symbols.Constructor ("str"), Str'Access), + (Symbols.Constructor ("-"), Subtraction'Access), + (Symbols.Constructor ("swap!"), Atoms.Swap'Access), + (Symbols.Constructor ("symbol"), Symbol'Access), + (Symbols.Constructor ("throw"), Throw'Access), + (Symbols.Constructor ("time-ms"), Time_Ms'Access), + (Symbols.Constructor ("vals"), Maps.Vals'Access), + (Symbols.Constructor ("vector"), Lists.Vector'Access), + (Symbols.Names.With_Meta, With_Meta'Access)); function Pr_Str (Args : in Mal.T_Array) return Mal.T is + R : ASU.Unbounded_String := ASU.Null_Unbounded_String; + Started : Boolean := False; begin - return R : Mal.T := (Kind_String, ASU.Null_Unbounded_String) do - if 0 < Args'Length then - ASU.Append (R.S, Printer.Pr_Str (Args (Args'First))); - for I in Args'First + 1 .. Args'Last loop - ASU.Append (R.S, ' '); - ASU.Append (R.S, Printer.Pr_Str (Args (I))); - end loop; + for A of Args loop + if Started then + ASU.Append (R, ' '); + else + Started := True; end if; - end return; + ASU.Append (R, Printer.Pr_Str (A)); + end loop; + return (Kind_String, R); end Pr_Str; function Println (Args : in Mal.T_Array) return Mal.T is - use Ada.Text_IO.Unbounded_IO; + Started : Boolean := False; begin - if 0 < Args'Length then - Put (Printer.Pr_Str (Args (Args'First), Readably => False)); - for I in Args'First + 1 .. Args'Last loop + for A of Args loop + if Started then Ada.Text_IO.Put (' '); - Put (Printer.Pr_Str (Args (I), Readably => False)); - end loop; - end if; + else + Started := True; + end if; + Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (A, Readably => False)); + end loop; Ada.Text_IO.New_Line; return Mal.Nil; end Println; function Prn (Args : in Mal.T_Array) return Mal.T is + Started : Boolean := False; begin - if 0 < Args'Length then - Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (Args'First))); - for I in Args'First + 1 .. Args'Last loop + for A of Args loop + if Started then Ada.Text_IO.Put (' '); - Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (I))); - end loop; - end if; + else + Started := True; + end if; + Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (A)); + end loop; Ada.Text_IO.New_Line; return Mal.Nil; end Prn; @@ -278,13 +320,12 @@ package body Core is raise Argument_Error with "readline: expects 1 argument"; elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then raise Argument_Error with "readline: expects a keyword or string"; + end if; + Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S); + if Ada.Text_IO.End_Of_File then + return Mal.Nil; else - Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S); - if Ada.Text_IO.End_Of_File then - return Mal.Nil; - else - return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line); - end if; + return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line); end if; end Readline; @@ -319,10 +360,10 @@ package body Core is end; end if; when Kind_List | Kind_Vector => - if Args (Args'First).L.Length = 0 then + if Args (Args'First).List.Length = 0 then return Mal.Nil; else - return (Kind_List, Args (Args'First).L); + return (Kind_List, Args (Args'First).List); end if; when others => raise Argument_Error with "seq: expects a string, list or vector"; @@ -354,32 +395,14 @@ package body Core is end Slurp; function Str (Args : in Mal.T_Array) return Mal.T is + R : ASU.Unbounded_String := ASU.Null_Unbounded_String; begin - return R : Mal.T := (Kind_String, ASU.Null_Unbounded_String) do - for Arg of Args loop - ASU.Append (R.S, Printer.Pr_Str (Arg, Readably => False)); - end loop; - end return; + for A of Args loop + ASU.Append (R, Printer.Pr_Str (A, Readably => False)); + end loop; + return (Kind_String, R); end Str; - function Swap (Args : in Mal.T_Array) return Mal.T is - begin - if Args'Length < 2 then - raise Argument_Error with "swap!: expects at least 2 arguments"; - elsif Args (Args'First).Kind /= Kind_Atom then - raise Argument_Error with "swap!: arg 1 must be an atom"; - end if; - declare - use type Mal.T_Array; - X : Mal.T renames Atoms.Deref (Args (Args'First .. Args'First)); - FX : Mal.T renames Apply_Helper (Args (Args'First + 1), - X & Args (Args'First + 2 .. Args'Last), - "swap!"); - begin - return Atoms.Reset (Mal.T_Array'(Args (Args'First), FX)); - end; - end Swap; - function Symbol (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then raise Argument_Error with "symbol?: expects 1 argument" @@ -407,88 +430,33 @@ package body Core is Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); end Time_Ms; - function With_Meta (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 then - raise Argument_Error with "with-meta: expects 2 arguments" - else (case Args (Args'First).Kind is - when Kind_Builtin_With_Meta => - Args (Args'First).Builtin_With_Meta.With_Meta (Args (Args'Last)), - when Kind_Builtin => - Builtins.With_Meta (Args (Args'First).Builtin, Args (Args'Last)), - when Kind_List => - (Kind_List, Args (Args'First).L.With_Meta (Args (Args'Last))), - when Kind_Vector => - (Kind_Vector, Args (Args'First).L.With_Meta (Args (Args'Last))), - when Kind_Map => - Args (Args'First).Map.With_Meta (Args (Args'Last)), - when Kind_Function => - Args (Args'First).Function_Value.With_Meta (Args (Args'Last)), - when others => - Args (Args'First))); - - use Symbols; - R : Environments.Ptr renames Environments.Repl; - B : Kind_Type renames Kind_Builtin; -begin -- Core - R.Set (Constructor ("+"), (B, Addition'Access)); - R.Set (Constructor ("apply"), (B, Apply'Access)); - R.Set (Constructor ("assoc"), (B, Maps.Assoc'Access)); - R.Set (Constructor ("atom"), (B, Atoms.Atom'Access)); - R.Set (Constructor ("concat"), (B, Lists.Concat'Access)); - R.Set (Constructor ("conj"), (B, Lists.Conj'Access)); - R.Set (Constructor ("cons"), (B, Lists.Cons'Access)); - R.Set (Constructor ("contains?"), (B, Maps.Contains'Access)); - R.Set (Constructor ("count"), (B, Lists.Count'Access)); - R.Set (Names.Deref, (B, Atoms.Deref'Access)); - R.Set (Constructor ("dissoc"), (B, Maps.Dissoc'Access)); - R.Set (Constructor ("/"), (B, Division'Access)); - R.Set (Constructor ("="), (B, Equals'Access)); - R.Set (Constructor ("eval"), (B, Eval'Access)); - R.Set (Constructor ("first"), (B, Lists.First'Access)); - R.Set (Constructor ("get"), (B, Maps.Get'Access)); - R.Set (Constructor (">="), (B, Greater_Equal'Access)); - R.Set (Constructor (">"), (B, Greater_Than'Access)); - R.Set (Constructor ("hash-map"), (B, Maps.Hash_Map'Access)); - R.Set (Constructor ("atom?"), (B, Is_Atom'Access)); - R.Set (Constructor ("empty?"), (B, Lists.Is_Empty'Access)); - R.Set (Constructor ("false?"), (B, Is_False'Access)); - R.Set (Constructor ("fn?"), (B, Is_Function'Access)); - R.Set (Constructor ("keyword?"), (B, Is_Keyword'Access)); - R.Set (Constructor ("list?"), (B, Is_List'Access)); - R.Set (Constructor ("macro?"), (B, Is_Macro'Access)); - R.Set (Constructor ("map?"), (B, Is_Map'Access)); - R.Set (Constructor ("nil?"), (B, Is_Nil'Access)); - R.Set (Constructor ("number?"), (B, Is_Number'Access)); - R.Set (Constructor ("sequential?"), (B, Is_Sequential'Access)); - R.Set (Constructor ("string?"), (B, Is_String'Access)); - R.Set (Constructor ("symbol?"), (B, Is_Symbol'Access)); - R.Set (Constructor ("true?"), (B, Is_True'Access)); - R.Set (Constructor ("vector?"), (B, Is_Vector'Access)); - R.Set (Constructor ("keys"), (B, Maps.Keys'Access)); - R.Set (Constructor ("keyword"), (B, Keyword'Access)); - R.Set (Constructor ("<="), (B, Less_Equal'Access)); - R.Set (Constructor ("<"), (B, Less_Than'Access)); - R.Set (Constructor ("list"), (B, Lists.List'Access)); - R.Set (Constructor ("map"), (B, Map'Access)); - R.Set (Constructor ("meta"), (B, Meta'Access)); - R.Set (Constructor ("nth"), (B, Lists.Nth'Access)); - R.Set (Constructor ("pr-str"), (B, Pr_Str'Access)); - R.Set (Constructor ("println"), (B, Println'Access)); - R.Set (Constructor ("prn"), (B, Prn'Access)); - R.Set (Constructor ("*"), (B, Product'Access)); - R.Set (Constructor ("read-string"), (B, Read_String'Access)); - R.Set (Constructor ("readline"), (B, Readline'Access)); - R.Set (Constructor ("reset!"), (B, Atoms.Reset'Access)); - R.Set (Constructor ("rest"), (B, Lists.Rest'Access)); - R.Set (Constructor ("seq"), (B, Seq'Access)); - R.Set (Constructor ("slurp"), (B, Slurp'Access)); - R.Set (Constructor ("str"), (B, Str'Access)); - R.Set (Constructor ("-"), (B, Subtraction'Access)); - R.Set (Constructor ("swap!"), (B, Swap'Access)); - R.Set (Constructor ("symbol"), (B, Symbol'Access)); - R.Set (Constructor ("throw"), (B, Throw'Access)); - R.Set (Constructor ("time-ms"), (B, Time_Ms'Access)); - R.Set (Constructor ("vals"), (B, Maps.Vals'Access)); - R.Set (Constructor ("vector"), (B, Lists.Vector'Access)); - R.Set (Names.With_Meta, (B, With_Meta'Access)); + function With_Meta (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 2 then + raise Argument_Error with "with-meta: expects 2 arguments"; + end if; + declare + A1 : Mal.T renames Args (Args'First); + A2 : Mal.T renames Args (Args'Last); + begin + case A1.Kind is + when Kind_Builtin_With_Meta => + return A1.Builtin_With_Meta.With_Meta (A2); + when Kind_Builtin => + return Builtins.With_Meta (A1.Builtin, A2); + when Kind_List => + return (Kind_List, A1.List.With_Meta (A2)); + when Kind_Vector => + return (Kind_Vector, A1.List.With_Meta (A2)); + when Kind_Map => + return A1.Map.With_Meta (A2); + when Kind_Function => + return A1.Fn.With_Meta (A2); + when others => + raise Argument_Error + with "with-meta: expects a list, vector, map or function"; + end case; + end; + end With_Meta; + end Core; diff --git a/ada2/core.ads b/ada2/core.ads index 1326d71857..b276093cd0 100644 --- a/ada2/core.ads +++ b/ada2/core.ads @@ -1,19 +1,23 @@ -limited with Environments; +with Types.Symbols; with Types.Mal; package Core with Elaborate_Body is - -- Initialization of this package fills Environments.Repl with - -- built-in functions. + type Binding is record + Symbol : Types.Symbols.Ptr; + Builtin : Types.Mal.Builtin_Ptr; + end record; - Eval_Ref : access function (Ast : in Types.Mal.T; - Env : in Environments.Ptr) - return Types.Mal.T; - -- Set by the main program at startup. + type Binding_List is array (Positive range <>) of Binding; + + function Ns return Binding_List; + -- A list of built-in symbols and functionse. + -- A constant would make sense, but + -- * implementing it in the private part Exception_Throwed : exception; - Last_Exception : Types.Mal.T := (Kind => Types.Kind_Nil); - -- When the exception is throwed, Last_Exception is set with the - -- related Data. + Last_Exception : Types.Mal.T := Types.Mal.Nil; + -- When the "throw" builtin is executed, it assigns its argument + -- to Last_Exception, then raises this Ada exception. end Core; diff --git a/ada2/environments.adb b/ada2/envs.adb similarity index 74% rename from ada2/environments.adb rename to ada2/envs.adb index d0e0802c69..ae197eea1d 100644 --- a/ada2/environments.adb +++ b/ada2/envs.adb @@ -1,7 +1,9 @@ with Ada.Containers.Hashed_Maps; with Ada.Unchecked_Deallocation; -package body Environments is +with Types.Symbols.Names; + +package body Envs is use Types; @@ -63,6 +65,18 @@ package body Environments is procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access); procedure Unreference (Reference : in out Heap_Access); + procedure Set_Binds (M : in out HM.Map; + Binds : in Symbols.Symbol_Array; + Exprs : in Mal.T_Array) + with Inline; + procedure Set_Binds_Macro (M : in out HM.Map; + Binds : in Symbols.Symbol_Array; + Exprs : in Lists.Ptr) + with Inline; + -- These two procedures are redundant, but sharing the code would + -- be ugly or inefficient. They are separated as inline procedures + -- in order to ease comparison, though. + ---------------------------------------------------------------------- procedure Adjust (Object : in out Closure_Ptr) is @@ -72,18 +86,6 @@ package body Environments is end if; end Adjust; - function Closure_Sub (Outer : in Closure_Ptr'Class) return Ptr is - begin - Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; - Top := Top + 1; - pragma Assert (Stack (Top).Data.Is_Empty); - pragma Assert (Stack (Top).Alias = null); - Stack (Top) := (Outer_On_Stack => False, - Outer_Ref => Outer.Ref, - others => <>); - return (Ada.Finalization.Limited_Controlled with Top); - end Closure_Sub; - function Copy_Pointer (Env : in Ptr) return Ptr is begin Stack (Env.Index).Refs := Stack (Env.Index).Refs + 1; @@ -231,10 +233,10 @@ package body Environments is end if; end Finalize; - function Get (Env : in Ptr; - Key : in Symbols.Ptr) - return Mal.T is - Index : Stack_Index := Env.Index; + function Get (Evt : in Ptr; + Key : in Symbols.Ptr) return Mal.T + is + Index : Stack_Index := Evt.Index; Ref : Heap_Access; Definition : HM.Cursor; begin @@ -291,9 +293,16 @@ package body Environments is -- unreferenced alias if any. end Replace_With_Sub; - procedure Replace_With_Closure_Sub (Env : in out Ptr; - Outer : in Closure_Ptr'Class) is + procedure Replace_With_Sub (Env : in out Ptr; + Outer : in Closure_Ptr'Class; + Binds : in Symbols.Symbol_Array; + Exprs : in Mal.T_Array) + is begin + -- Finalize Env before creating the new environment, in case + -- this is the last reference and it can be forgotten. + -- Automatic assignment would construct the new value before + -- finalizing the old one (because this is safer in general). Finalize (Env); Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; Top := Top + 1; @@ -303,7 +312,9 @@ package body Environments is Outer_Ref => Outer.Ref, others => <>); Env.Index := Top; - end Replace_With_Closure_Sub; + -- Now we can afford raising exceptions. + Set_Binds (Stack (Top).Data, Binds, Exprs); + end Replace_With_Sub; procedure Set (Env : in Ptr; Key : in Symbols.Ptr; @@ -312,7 +323,61 @@ package body Environments is Stack (Env.Index).Data.Include (Key, New_Element); end Set; - function Sub (Outer : in Ptr) return Ptr is + procedure Set_Binds (M : in out HM.Map; + Binds : in Symbols.Symbol_Array; + Exprs : in Mal.T_Array) + is + use type Symbols.Ptr; + Varargs : constant Boolean := 1 < Binds'Length and then + Binds (Binds'Last - 1) = Symbols.Names.Ampersand; + begin + if (if Varargs then + Exprs'Length < Binds'Length - 2 + else + Exprs'Length /= Binds'Length) + then + raise Argument_Error with "user function expected " + & Symbols.To_String (Binds) & ", got" + & Integer'Image (Exprs'Length) & " actual parameters"; + end if; + for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop + M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I)); + end loop; + if Varargs then + M.Include (Binds (Binds'Last), + Lists.List (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); + end if; + end Set_Binds; + + procedure Set_Binds_Macro (M : in out HM.Map; + Binds : in Symbols.Symbol_Array; + Exprs : in Lists.Ptr) + is + use type Symbols.Ptr; + Varargs : constant Boolean := 1 < Binds'Length and then + Binds (Binds'Last - 1) = Symbols.Names.Ampersand; + begin + if (if Varargs then + Exprs.Length - 1 < Binds'Length - 2 + else + Exprs.Length - 1 /= Binds'Length) + then + raise Argument_Error with "macro expected " + & Symbols.To_String (Binds) & ", got" + & Integer'Image (Exprs.Length - 1) & "actual parameters"; + end if; + for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop + M.Include (Binds (Binds'First + I), Exprs.Element (2 + I)); + end loop; + if Varargs then + M.Include (Binds (Binds'Last), Exprs.Slice (Start => Binds'Length)); + end if; + end Set_Binds_Macro; + + function Sub (Outer : in Ptr; + Binds : in Symbols.Symbol_Array; + Exprs : in Lists.Ptr) return Ptr + is R : Stack_Record renames Stack (Outer.Index); begin R.Refs := R.Refs + 1; @@ -321,9 +386,31 @@ package body Environments is pragma Assert (Stack (Top).Alias = null); Stack (Top) := (Outer_Index => Outer.Index, others => <>); + Set_Binds_Macro (Stack (Top).Data, Binds, Exprs); return (Ada.Finalization.Limited_Controlled with Top); end Sub; + function Sub (Outer : in Closure_Ptr'Class; + Binds : in Symbols.Symbol_Array; + Exprs : in Mal.T_Array) return Ptr + is + begin + Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + Top := Top + 1; + pragma Assert (Stack (Top).Data.Is_Empty); + pragma Assert (Stack (Top).Alias = null); + Stack (Top) := (Outer_On_Stack => False, + Outer_Ref => Outer.Ref, + others => <>); + -- Take care to construct the result before raising any + -- exception, so that it is finalized correctly. + return R : constant Ptr := (Ada.Finalization.Limited_Controlled with Top) + do + -- Now we can afford raising exceptions. + Set_Binds (Stack (Top).Data, Binds, Exprs); + end return; + end Sub; + procedure Unreference (Reference : in out Heap_Access) is Ref : Heap_Access := Reference; begin @@ -345,4 +432,4 @@ package body Environments is end loop; end Unreference; -end Environments; +end Envs; diff --git a/ada2/environments.ads b/ada2/envs.ads similarity index 65% rename from ada2/environments.ads rename to ada2/envs.ads index c49c9cd78f..b7082a6c17 100644 --- a/ada2/environments.ads +++ b/ada2/envs.ads @@ -1,9 +1,14 @@ private with Ada.Finalization; +with Types.Lists; with Types.Mal; with Types.Symbols; -package Environments with Elaborate_Body is +package Envs with Elaborate_Body is + + -- This package should be named Env, but Ada does not allow formal + -- parameters to be named like a package dependency, and it seems + -- that readability inside Eval is more important. -- This implementation relies on the fact that the caller only -- ever references environments in its execution stack. @@ -32,22 +37,24 @@ package Environments with Elaborate_Body is -- The top environment. function Copy_Pointer (Env : in Ptr) return Ptr with Inline; - - function Sub (Outer : in Ptr) return Ptr with Inline; + -- Allows assignment to a freshly created variable. This is + -- required for tail call optimization, but should be avoided + -- elsewhere. procedure Replace_With_Sub (Env : in out Ptr) with Inline; - -- Like Env := Sub (Outer => Env); except that Env is finalized - -- *before* the assignement, so its memory may be reused by the - -- new environment. + -- Equivalent to Env := Sub (Outer => Env, empty Binds and Exprs), + -- except that such an assignment is forbidden for performance + -- reasons. procedure Set (Env : in Ptr; Key : in Types.Symbols.Ptr; New_Element : in Types.Mal.T) with Inline; - function Get (Env : in Ptr; - Key : in Types.Symbols.Ptr) - return Types.Mal.T; + -- The Find method is merged into the Get method. + + function Get (Evt : in Ptr; + Key : in Types.Symbols.Ptr) return Types.Mal.T; Unknown_Key : exception; -- Function closures. @@ -55,16 +62,33 @@ package Environments with Elaborate_Body is type Closure_Ptr is tagged private; Null_Closure : constant Closure_Ptr; - function Closure_Sub (Outer : in Closure_Ptr'Class) return Ptr; - - procedure Replace_With_Closure_Sub (Env : in out Ptr; - Outer : in Closure_Ptr'Class); - -- Like Env := Closure_Sub (Outer); except that the type is limited. - function New_Closure (Env : in Ptr'Class) return Closure_Ptr; -- The class-wide argument does not make much sense, but avoids -- the compiler wondering on which type is should dispatch. + function Sub (Outer : in Closure_Ptr'Class; + Binds : in Types.Symbols.Symbol_Array; + Exprs : in Types.Mal.T_Array) return Ptr; + -- Construct a new environment with the given closure as outer parent. + -- Then call Set with the paired elements of Binds and Exprs, + -- handling the "&" special formal parameter if present. + -- May raise Argument_Count. + + procedure Replace_With_Sub (Env : in out Ptr; + Outer : in Closure_Ptr'Class; + Binds : in Types.Symbols.Symbol_Array; + Exprs : in Types.Mal.T_Array); + -- Equivalent to Env := Sub (Outer, Binds, Expr); except that such + -- an assignment is forbidden for performance reasons. + + function Sub (Outer : in Ptr; + Binds : in Types.Symbols.Symbol_Array; + Exprs : in Types.Lists.Ptr) return Ptr; + -- Like Sub above, but dedicated to macros. + -- * The Outer parameter is the current environment, not a closure. + -- * The Exprs argument is a list. + -- * Its first element is skipped. + private -- There must be a reference level so that functions may keep @@ -110,4 +134,4 @@ private Null_Closure : constant Closure_Ptr := (Ada.Finalization.Controlled with null); -end Environments; +end Envs; diff --git a/ada2/eval_cb.ads b/ada2/eval_cb.ads new file mode 100644 index 0000000000..9319f3b2a2 --- /dev/null +++ b/ada2/eval_cb.ads @@ -0,0 +1,11 @@ +with Envs; +with Types.Mal; + +package Eval_Cb is + + Cb : access function (Ast : in Types.Mal.T; + Env : in Envs.Ptr) return Types.Mal.T; + -- The main program must register this global callback to the main + -- eval function before some built-in functions are executed. + +end Eval_Cb; diff --git a/ada2/printer.adb b/ada2/printer.adb index f9bee1745c..11b9b9b5e2 100644 --- a/ada2/printer.adb +++ b/ada2/printer.adb @@ -2,45 +2,37 @@ with Ada.Characters.Latin_1; with Types.Atoms; with Types.Functions; +with Types.Symbols; with Types.Lists; with Types.Maps; package body Printer is - function Pr_Str (Ast : in Types.Mal.T; - Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String - is - - use Ada.Strings.Unbounded; - use Types; + use Ada.Strings.Unbounded; + use Types; - Buffer : Unbounded_String := Null_Unbounded_String; - -- is appended the result character after character. + function Pr_Str (Ast : in Mal.T; + Readably : in Boolean := True) return Unbounded_String + is procedure Print_Form (Form_Ast : in Mal.T); -- The recursive function traversing Ast for Pr_Str. -- Form_Ast is the current node. - ---------------------------------------------------------------------- - - procedure Print_Form (Form_Ast : in Mal.T) is + -- Helpers for Print_Form. + procedure Print_Number (Number : in Integer) with Inline; + procedure Print_List (List : in Lists.Ptr) with Inline; + procedure Print_Map (Map : in Maps.Ptr) with Inline; + procedure Print_Readably (S : in Unbounded_String) with Inline; + procedure Print_Symbols (List : in Symbols.Symbol_Array) with Inline; - procedure Print_List (List : in Lists.Ptr) with Inline; - -- An helper for Print_Form. + Buffer : Unbounded_String := Null_Unbounded_String; + -- is appended the result character after character. - procedure Print_List (List : in Lists.Ptr) is - begin - if 0 < List.Length then - Print_Form (List.Element (1)); - for I in 2 .. List.Length loop - Append (Buffer, ' '); - Print_Form (List.Element (I)); - end loop; - end if; - end Print_List; + ---------------------------------------------------------------------- - begin -- Print_Form + procedure Print_Form (Form_Ast : in Mal.T) is + begin case Form_Ast.Kind is when Kind_Nil => Append (Buffer, "nil"); @@ -53,94 +45,128 @@ package body Printer is when Kind_Symbol => Append (Buffer, Form_Ast.Symbol.To_String); when Kind_Number => - declare - Img : constant String := Integer'Image (Form_Ast.Ada_Number); - F : Positive := Img'First; - begin - if Img (F) = ' ' then - F := F + 1; - end if; - Append (Buffer, Img (F .. Img'Last)); - end; + Print_Number (Form_Ast.Number); when Kind_Keyword => Append (Buffer, ':'); Append (Buffer, Form_Ast.S); when Kind_String => if Readably then - declare - C : Character; - begin - Append (Buffer, '"'); - for I in 1 .. Length (Form_Ast.S) loop - C := Element (Form_Ast.S, I); - case C is - when '"' | '\' => - Append (Buffer, '\'); - Append (Buffer, C); - when Ada.Characters.Latin_1.LF => - Append (Buffer, "\n"); - when others => - Append (Buffer, C); - end case; - end loop; - Append (Buffer, '"'); - end; + Append (Buffer, '"'); + Print_Readably (Form_Ast.S); + Append (Buffer, '"'); else Append (Buffer, Form_Ast.S); end if; when Kind_List => Append (Buffer, '('); - Print_List (Form_Ast.L); + Print_List (Form_Ast.List); Append (Buffer, ')'); when Kind_Vector => Append (Buffer, '['); - Print_List (Form_Ast.L); + Print_List (Form_Ast.List); Append (Buffer, ']'); when Kind_Map => Append (Buffer, '{'); - declare - Is_First : Boolean := True; - procedure Process (Key : in Mal.T; - Element : in Mal.T); - procedure Iterate is new Maps.Iterate (Process); - procedure Process (Key : in Mal.T; - Element : in Mal.T) - is - begin - if Is_First then - Is_First := False; - else - Append (Buffer, ' '); - end if; - Print_Form (Key); - Append (Buffer, ' '); - Print_Form (Element); - end Process; - begin - Iterate (Form_Ast.Map); - end; + Print_Map (Form_Ast.Map); Append (Buffer, '}'); when Kind_Builtin | Kind_Builtin_With_Meta => Append (Buffer, "#"); when Kind_Function => - Append (Buffer, "# "); - Print_Form (Form_Ast.Function_Value.Expression); + Append (Buffer, "# "); + Print_Form (Form_Ast.Fn.Ast); Append (Buffer, '>'); when Kind_Macro => - Append (Buffer, "# "); - Print_Form (Form_Ast.Function_Value.Expression); + Append (Buffer, "# "); + Print_Form (Form_Ast.Fn.Ast); Append (Buffer, '>'); when Kind_Atom => Append (Buffer, "(atom "); - Print_Form (Atoms.Deref (Mal.T_Array'(1 => Form_Ast))); + Print_Form (Atoms.Deref (Form_Ast.Atom)); Append (Buffer, ')'); end case; end Print_Form; + procedure Print_List (List : in Lists.Ptr) is + Started : Boolean := False; + begin + for I in 1 .. List.Length loop + if Started then + Append (Buffer, ' '); + else + Started := True; + end if; + Print_Form (List.Element (I)); + end loop; + end Print_List; + + procedure Print_Map (Map : in Maps.Ptr) is + procedure Process (Key : in Mal.T; + Element : in Mal.T); + procedure Iterate is new Maps.Iterate (Process); + Started : Boolean := False; + procedure Process (Key : in Mal.T; + Element : in Mal.T) + is + begin + if Started then + Append (Buffer, ' '); + else + Started := True; + end if; + Print_Form (Key); + Append (Buffer, ' '); + Print_Form (Element); + end Process; + begin + Iterate (Map); + end Print_Map; + + procedure Print_Number (Number : in Integer) is + Image : constant String := Integer'Image (Number); + First : Positive := Image'First; + begin + if Image (First) = ' ' then + First := First + 1; + end if; + Append (Buffer, Image (First .. Image'Last)); + end Print_Number; + + procedure Print_Readably (S : in Unbounded_String) is + begin + for I in 1 .. Length (S) loop + declare + C : constant Character := Element (S, I); + begin + case C is + when '"' | '\' => + Append (Buffer, '\'); + Append (Buffer, C); + when Ada.Characters.Latin_1.LF => + Append (Buffer, "\n"); + when others => + Append (Buffer, C); + end case; + end; + end loop; + end Print_Readably; + + procedure Print_Symbols (List : in Symbols.Symbol_Array) is + Started : Boolean := False; + begin + for S of List loop + if Started then + Append (Buffer, ' '); + else + Started := True; + end if; + Append (Buffer, S.To_String); + end loop; + end Print_Symbols; + ---------------------------------------------------------------------- begin -- Pr_Str diff --git a/ada2/printer.ads b/ada2/printer.ads index 219f682dae..b50d32a60d 100644 --- a/ada2/printer.ads +++ b/ada2/printer.ads @@ -8,4 +8,9 @@ package Printer with Elaborate_Body is Readably : in Boolean := True) return Ada.Strings.Unbounded.Unbounded_String; + function Img (Ast : in Types.Mal.T) return String + is (Ada.Strings.Unbounded.To_String (Pr_Str (Ast))) with Inline; + -- This form is convenient for reporting errors, but the + -- conversion should be avoided when possible. + end Printer; diff --git a/ada2/reader.adb b/ada2/reader.adb index 776f60f9b5..33d0c3c4a0 100644 --- a/ada2/reader.adb +++ b/ada2/reader.adb @@ -25,8 +25,7 @@ package body Reader is ---------------------------------------------------------------------- - procedure Find_Next_Token - is + procedure Find_Next_Token is use Ada.Characters.Latin_1; begin First := Last + 1; diff --git a/ada2/readline.adb b/ada2/readline.adb new file mode 100644 index 0000000000..882b347387 --- /dev/null +++ b/ada2/readline.adb @@ -0,0 +1,32 @@ +with Interfaces.C.Strings; + +package body Readline is + + function Input (Prompt : in String) return String is + + use Interfaces.C; + use Interfaces.C.Strings; + + function C_Readline (Prompt : in char_array) return chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in chars_ptr) + with Import, Convention => C, External_Name => "free"; + + C_Line : constant chars_ptr := C_Readline (To_C (Prompt)); + begin + if C_Line = Null_Ptr then + raise End_Of_File; + end if; + return Ada_Line : constant String := Value (C_Line) do + if Ada_Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + end return; + end Input; + +end Readline; diff --git a/ada2/readline.ads b/ada2/readline.ads new file mode 100644 index 0000000000..534ee7f7db --- /dev/null +++ b/ada2/readline.ads @@ -0,0 +1,7 @@ +package Readline with Preelaborate is + + function Input (Prompt : in String) return String; + + End_Of_File : exception; + +end Readline; diff --git a/ada2/step0_repl.adb b/ada2/step0_repl.adb index f318731343..9eda48659d 100644 --- a/ada2/step0_repl.adb +++ b/ada2/step0_repl.adb @@ -1,55 +1,43 @@ with Ada.Text_IO; -with Interfaces.C.Strings; + +with Readline; procedure Step0_Repl is - subtype Mal_Type is String; + function Read return String with Inline; - function Read (Source : in String) return Mal_Type - is (Source); + function Eval (Ast : in String) return String; - function Eval (Ast : in Mal_Type) return Mal_Type - is (Ast); + procedure Print (Ast : in String) with Inline; - function Print (Ast : in Mal_Type) return String - is (Ast); + procedure Rep with Inline; - function Rep (Source : in String) return String - is (Print (Eval (Read (Source)))) with Inline; + ---------------------------------------------------------------------- - procedure Interactive_Loop; + function Eval (Ast : in String) return String is (Ast); - ---------------------------------------------------------------------- + procedure Print (Ast : in String) is + begin + Ada.Text_IO.Put_Line (Ast); + end Print; + + function Read return String is (Readline.Input ("user> ")); - procedure Interactive_Loop is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Rep is begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Put_Line (Rep (Line)); - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + Print (Eval (Read)); + end Rep; ---------------------------------------------------------------------- begin - Interactive_Loop; + loop + begin + Rep; + exception + when Readline.End_Of_File => + exit; + end; + end loop; + Ada.Text_IO.New_Line; end Step0_Repl; diff --git a/ada2/step1_read_print.adb b/ada2/step1_read_print.adb index 06f49a3005..67b3277621 100644 --- a/ada2/step1_read_print.adb +++ b/ada2/step1_read_print.adb @@ -1,69 +1,54 @@ with Ada.Exceptions; -with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Printer; with Reader; +with Readline; with Types.Mal; procedure Step1_Read_Print is - package ASU renames Ada.Strings.Unbounded; use Types; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; - function Eval (Ast : in Mal.T) return Mal.T - is (Ast); + function Eval (Ast : in Mal.T) return Mal.T; - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String) return ASU.Unbounded_String - is (Print (Eval (Read (Source)))) with Inline; - - procedure Interactive_Loop; + procedure Rep with Inline; ---------------------------------------------------------------------- - procedure Interactive_Loop is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + function Eval (Ast : in Mal.T) return Mal.T is (Ast); + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep is begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line)); - exception - when Reader.Empty_Source => - null; - when E : Reader.Reader_Error => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + Print (Eval (Read)); + end Rep; ---------------------------------------------------------------------- begin - Interactive_Loop; + loop + begin + Rep; + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Reader.Reader_Error => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end Step1_Read_Print; diff --git a/ada2/step2_eval.adb b/ada2/step2_eval.adb index 9010bb2c4f..7a5f9f72d3 100644 --- a/ada2/step2_eval.adb +++ b/ada2/step2_eval.adb @@ -1,57 +1,48 @@ with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Exceptions; with Ada.Strings.Hash; -with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Printer; with Reader; -with Types.Builtins; +with Readline; with Types.Lists; with Types.Mal; with Types.Maps; procedure Step2_Eval is - package ASU renames Ada.Strings.Unbounded; use Types; - package Environments is new Ada.Containers.Indefinite_Hashed_Maps + package Envs is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, - Element_Type => Builtins.Ptr, + Element_Type => Mal.Builtin_Ptr, Hash => Ada.Strings.Hash, Equivalent_Keys => "=", - "=" => Builtins."="); - Unknown_Symbol : exception; + "=" => Mal."="); + Unknown_Key : exception; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast : in Mal.T; - Env : in Environments.Map) return Mal.T; + Env : in Envs.Map) return Mal.T; - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Map) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; - - procedure Interactive_Loop (Repl : in Environments.Map); + procedure Rep (Env : in Envs.Map) with Inline; generic with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Map, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Map, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Map, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval); ---------------------------------------------------------------------- function Eval (Ast : in Mal.T; - Env : in Environments.Map) return Mal.T is + Env : in Envs.Map) return Mal.T + is First : Mal.T; begin -- Ada.Text_IO.New_Line; @@ -64,80 +55,57 @@ procedure Step2_Eval is return Ast; when Kind_Symbol => declare - S : constant String := Ast.Symbol.To_String; - C : constant Environments.Cursor := Env.Find (S); + S : constant String := Ast.Symbol.To_String; + C : constant Envs.Cursor := Env.Find (S); begin - if Environments.Has_Element (C) then - return (Kind_Builtin, Environments.Element (C)); + if Envs.Has_Element (C) then + return (Kind_Builtin, Envs.Element (C)); else -- The predefined message does not pass tests. - raise Unknown_Symbol with "'" & S & "' not found"; + raise Unknown_Key with "'" & S & "' not found"; end if; end; when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Eval (Ast.L.Element (1), Env); + First := Eval (Ast.List.Element (1), Env); -- Apply phase. case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T - is (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number, - Args (Args'Last).Ada_Number)); - - procedure Interactive_Loop (Repl : in Environments.Map) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + is (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + + procedure Print (Ast : in Mal.T) is begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Unknown_Symbol => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Map) is + begin + Print (Eval (Read, Env)); + end Rep; ---------------------------------------------------------------------- @@ -146,12 +114,24 @@ procedure Step2_Eval is function Product is new Generic_Mal_Operator ("*"); function Division is new Generic_Mal_Operator ("/"); - Repl : Environments.Map; + Repl : Envs.Map; begin Repl.Insert ("+", Addition 'Unrestricted_Access); Repl.Insert ("-", Subtraction'Unrestricted_Access); Repl.Insert ("*", Product 'Unrestricted_Access); Repl.Insert ("/", Division 'Unrestricted_Access); - - Interactive_Loop (Repl); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Reader.Reader_Error | Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end Step2_Eval; diff --git a/ada2/step3_env.adb b/ada2/step3_env.adb index 1b4448bfe2..79290d58da 100644 --- a/ada2/step3_env.adb +++ b/ada2/step3_env.adb @@ -1,11 +1,10 @@ with Ada.Exceptions; -with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; -with Environments; +with Envs; with Printer; with Reader; +with Readline; with Types.Lists; with Types.Mal; with Types.Maps; @@ -13,43 +12,36 @@ with Types.Symbols.Names; procedure Step3_Env is - package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T; + Env : in Envs.Ptr) return Mal.T; - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; - - procedure Interactive_Loop (Repl : in Environments.Ptr); + procedure Rep (Env : in Envs.Ptr) with Inline; generic with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); ---------------------------------------------------------------------- function Eval (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T is + Env : in Envs.Ptr) return Mal.T + is + use type Symbols.Ptr; First : Mal.T; begin -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -60,36 +52,38 @@ procedure Step3_Env is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - New_Env : constant Environments.Ptr := Env.Sub; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + -- This curious syntax is useful for later steps. + New_Env : Envs.Ptr := Env.Copy_Pointer; begin + New_Env.Replace_With_Sub; if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; end if; @@ -100,7 +94,7 @@ procedure Step3_Env is New_Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), New_Env)); end loop; - return Eval (Ast.L.Element (3), New_Env); + return Eval (Ast.List.Element (3), New_Env); end; else -- Equivalent to First := Eval (First, Env), except that @@ -112,57 +106,34 @@ procedure Step3_Env is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T - is (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number, - Args (Args'Last).Ada_Number)); - - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + is (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + + procedure Print (Ast : in Mal.T) is begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; ---------------------------------------------------------------------- @@ -171,14 +142,28 @@ procedure Step3_Env is function Product is new Generic_Mal_Operator ("*"); function Division is new Generic_Mal_Operator ("/"); - function S (Source : in String) return Symbols.Ptr - renames Symbols.Constructor; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; begin - Repl.Set (S ("+"), (Kind_Builtin, Addition 'Unrestricted_Access)); - Repl.Set (S ("-"), (Kind_Builtin, Subtraction'Unrestricted_Access)); - Repl.Set (S ("*"), (Kind_Builtin, Product 'Unrestricted_Access)); - Repl.Set (S ("/"), (Kind_Builtin, Division 'Unrestricted_Access)); - - Interactive_Loop (Repl); + Repl.Set (Symbols.Constructor ("+"), + (Kind_Builtin, Addition 'Unrestricted_Access)); + Repl.Set (Symbols.Constructor ("-"), + (Kind_Builtin, Subtraction'Unrestricted_Access)); + Repl.Set (Symbols.Constructor ("*"), + (Kind_Builtin, Product 'Unrestricted_Access)); + Repl.Set (Symbols.Constructor ("/"), + (Kind_Builtin, Division 'Unrestricted_Access)); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end Step3_Env; diff --git a/ada2/step4_if_fn_do.adb b/ada2/step4_if_fn_do.adb index bce010d3dd..d96d28c7bf 100644 --- a/ada2/step4_if_fn_do.adb +++ b/ada2/step4_if_fn_do.adb @@ -1,12 +1,12 @@ with Ada.Exceptions; -with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -15,42 +15,37 @@ with Types.Symbols.Names; procedure Step4_If_Fn_Do is - package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T; + Env : in Envs.Ptr) return Mal.T; - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T is + Env : in Envs.Ptr) return Mal.T + is + use type Symbols.Ptr; First : Mal.T; begin -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -61,75 +56,78 @@ procedure Step4_If_Fn_Do is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - return Eval (Ast.L.Element (Ast.L.Length), Env); + return Eval (Ast.List.Element (Ast.List.Length), Env); elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - return Eval (Ast.L.Element (3), Env); - elsif Ast.L.Length = 3 then + return Eval (Ast.List.Element (3), Env); + elsif Ast.List.Length = 3 then return Mal.Nil; else - return Eval (Ast.L.Element (4), Env); + return Eval (Ast.List.Element (4), Env); end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; - New_Env : constant Environments.Ptr := Env.Sub; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + -- This curious syntax is useful for later steps. + New_Env : Envs.Ptr := Env.Copy_Pointer; begin + New_Env.Replace_With_Sub; if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; end if; @@ -140,7 +138,7 @@ procedure Step4_If_Fn_Do is New_Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), New_Env)); end loop; - return Eval (Ast.L.Element (3), New_Env); + return Eval (Ast.List.Element (3), New_Env); end; else -- Equivalent to First := Eval (First, Env), except that @@ -152,74 +150,75 @@ procedure Step4_If_Fn_Do is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); - New_Env : constant Environments.Ptr - := First.Function_Value.Closure.Closure_Sub; + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - First.Function_Value.Set_Binds (New_Env, Args); - return Eval (First.Function_Value.Expression, New_Env); + return First.Fn.Apply (Args); end; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); - Interactive_Loop (Repl); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end Step4_If_Fn_Do; diff --git a/ada2/step5_tco.adb b/ada2/step5_tco.adb index c9182356b3..b6079454a6 100644 --- a/ada2/step5_tco.adb +++ b/ada2/step5_tco.adb @@ -1,12 +1,12 @@ with Ada.Exceptions; -with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -15,48 +15,42 @@ with Types.Symbols.Names; procedure Step5_Tco is - package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T; + Env0 : in Envs.Ptr) return Mal.T; - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T + Env0 : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. - Ast : Mal.T := Ast0; - Env : Environments.Ptr := Env0.Copy_Pointer; + Ast : Mal.T := Ast0; + Env : Envs.Ptr := Env0.Copy_Pointer; First : Mal.T; begin <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -67,76 +61,77 @@ procedure Step5_Tco is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - Ast := Ast.L.Element (Ast.L.Length); + Ast := Ast.List.Element (Ast.List.Length); goto Restart; elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; - elsif Ast.L.Length = 3 then + elsif Ast.List.Length = 3 then return Mal.Nil; else - Ast := Ast.L.Element (4); + Ast := Ast.List.Element (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; begin if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; @@ -149,7 +144,7 @@ procedure Step5_Tco is Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), Env)); end loop; - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; end; else @@ -162,74 +157,79 @@ procedure Step5_Tco is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - Env.Replace_With_Closure_Sub (First.Function_Value.Closure); - First.Function_Value.Set_Binds (Env, Args); - Ast := First.Function_Value.Expression; + Env.Replace_With_Sub (Outer => First.Fn.Env, + Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; goto Restart; end; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); - Interactive_Loop (Repl); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end Step5_Tco; diff --git a/ada2/step6_file.adb b/ada2/step6_file.adb index b5051634f5..57988f7df6 100644 --- a/ada2/step6_file.adb +++ b/ada2/step6_file.adb @@ -2,12 +2,13 @@ with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -18,46 +19,41 @@ procedure Step6_File is package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T; + Env0 : in Envs.Ptr) return Mal.T; - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T + Env0 : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. - Ast : Mal.T := Ast0; - Env : Environments.Ptr := Env0.Copy_Pointer; + Ast : Mal.T := Ast0; + Env : Envs.Ptr := Env0.Copy_Pointer; First : Mal.T; begin <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -68,76 +64,77 @@ procedure Step6_File is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - Ast := Ast.L.Element (Ast.L.Length); + Ast := Ast.List.Element (Ast.List.Length); goto Restart; elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; - elsif Ast.L.Length = 3 then + elsif Ast.List.Length = 3 then return Mal.Nil; else - Ast := Ast.L.Element (4); + Ast := Ast.List.Element (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; begin if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; @@ -150,7 +147,7 @@ procedure Step6_File is Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), Env)); end loop; - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; end; else @@ -163,78 +160,71 @@ procedure Step6_File is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - Env.Replace_With_Closure_Sub (First.Function_Value.Closure); - First.Function_Value.Set_Binds (Env, Args); - Ast := First.Function_Value.Expression; + Env.Replace_With_Sub (Outer => First.Fn.Env, + Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; goto Restart; end; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; use Ada.Command_Line; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + -- Define ARGV from command line arguments. declare Args : Mal.T_Array (2 .. Argument_Count); begin @@ -243,9 +233,23 @@ begin end loop; Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); end; - if Argument_Count = 0 then - Interactive_Loop (Repl); + -- Script? + if 0 < Argument_Count then + Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); else - Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end if; end Step6_File; diff --git a/ada2/step7_quote.adb b/ada2/step7_quote.adb index 819ee88dc1..9424e615da 100644 --- a/ada2/step7_quote.adb +++ b/ada2/step7_quote.adb @@ -2,12 +2,13 @@ with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -18,53 +19,48 @@ procedure Step7_Quote is package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T; + Env0 : in Envs.Ptr) return Mal.T; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T; + Env : in Envs.Ptr) return Mal.T; -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks -- too much the step structure shared by all implementations. - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T + Env0 : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. - Ast : Mal.T := Ast0; - Env : Environments.Ptr := Env0.Copy_Pointer; + Ast : Mal.T := Ast0; + Env : Envs.Ptr := Env0.Copy_Pointer; First : Mal.T; begin <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -75,76 +71,77 @@ procedure Step7_Quote is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - Ast := Ast.L.Element (Ast.L.Length); + Ast := Ast.List.Element (Ast.List.Length); goto Restart; elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; - elsif Ast.L.Length = 3 then + elsif Ast.List.Length = 3 then return Mal.Nil; else - Ast := Ast.L.Element (4); + Ast := Ast.List.Element (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; begin if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; @@ -157,19 +154,19 @@ procedure Step7_Quote is Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), Env)); end loop; - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quasiquote: expects 1 argument"; end if; - return Quasiquote (Ast.L.Element (2), Env); + return Quasiquote (Ast.List.Element (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quote: expects 1 argument"; end if; - return Ast.L.Element (2); + return Ast.List.Element (2); else -- Equivalent to First := Eval (First, Env), except that -- we already know enough to spare a recursive call in @@ -180,70 +177,51 @@ procedure Step7_Quote is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - Env.Replace_With_Closure_Sub (First.Function_Value.Closure); - First.Function_Value.Set_Binds (Env, Args); - Ast := First.Function_Value.Expression; + Env.Replace_With_Sub (Outer => First.Fn.Env, + Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; goto Restart; end; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T + Env : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. @@ -254,15 +232,15 @@ procedure Step7_Quote is for I in R'Range loop R (I) := List.Element (I); if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol + and then 0 < R (I).List.Length + and then R (I).List.Element (1).Kind = Kind_Symbol + and then R (I).List.Element (1).Symbol = Symbols.Names.Splice_Unquote then - if R (I).L.Length /= 2 then + if R (I).List.Length /= 2 then raise Argument_Error with "splice-unquote: expects 1 arg"; end if; - R (I) := Eval (R (I).L.Element (2), Env); + R (I) := Eval (R (I).List.Element (2), Env); if R (I).Kind /= Kind_List then raise Argument_Error with "splice-unquote: expects a list"; end if; @@ -278,33 +256,47 @@ procedure Step7_Quote is case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); when Kind_List => - if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.List.Length + and then Ast.List.Element (1).Kind = Kind_Symbol + and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then - return Eval (Ast.L.Element (2), Env); + return Eval (Ast.List.Element (2), Env); else - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); end if; when others => return Ast; end case; end Quasiquote; + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; + ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; use Ada.Command_Line; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + -- Define ARGV from command line arguments. declare Args : Mal.T_Array (2 .. Argument_Count); begin @@ -313,9 +305,23 @@ begin end loop; Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); end; - if Argument_Count = 0 then - Interactive_Loop (Repl); + -- Script? + if 0 < Argument_Count then + Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); else - Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end if; end Step7_Quote; diff --git a/ada2/step8_macros.adb b/ada2/step8_macros.adb index c8712face3..5240b589f2 100644 --- a/ada2/step8_macros.adb +++ b/ada2/step8_macros.adb @@ -2,12 +2,13 @@ with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -18,54 +19,49 @@ procedure Step8_Macros is package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T; + Env0 : in Envs.Ptr) return Mal.T; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T; + Env : in Envs.Ptr) return Mal.T; -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks -- too much the step structure shared by all implementations. - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T + Env0 : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. - Ast : Mal.T := Ast0; - Env : Environments.Ptr := Env0.Copy_Pointer; - Macroexpanding : Boolean := False; + Ast : Mal.T := Ast0; + Env : Envs.Ptr := Env0.Copy_Pointer; + Macroexpanding : Boolean := False; First : Mal.T; begin <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -76,92 +72,93 @@ procedure Step8_Macros is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "defmacro!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "defmacro!: arg 1 must be a symbol"; end if; declare - F : constant Mal.T := Eval (Ast.L.Element (3), Env); + F : constant Mal.T := Eval (Ast.List.Element (3), Env); begin if F.Kind /= Kind_Function then raise Argument_Error with "defmacro!: expects a function"; end if; - return R : constant Mal.T := F.Function_Value.New_Macro do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := F.Fn.New_Macro do + Env.Set (Ast.List.Element (2).Symbol, R); end return; end; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - Ast := Ast.L.Element (Ast.L.Length); + Ast := Ast.List.Element (Ast.List.Length); goto Restart; elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; - elsif Ast.L.Length = 3 then + elsif Ast.List.Length = 3 then return Mal.Nil; else - Ast := Ast.L.Element (4); + Ast := Ast.List.Element (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; begin if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; @@ -174,26 +171,26 @@ procedure Step8_Macros is Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), Env)); end loop; - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "macroexpand: expects 1 argument"; end if; Macroexpanding := True; - Ast := Ast.L.Element (2); + Ast := Ast.List.Element (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quasiquote: expects 1 argument"; end if; - return Quasiquote (Ast.L.Element (2), Env); + return Quasiquote (Ast.List.Element (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quote: expects 1 argument"; end if; - return Ast.L.Element (2); + return Ast.List.Element (2); else -- Equivalent to First := Eval (First, Env), except that -- we already know enough to spare a recursive call in @@ -204,82 +201,61 @@ procedure Step8_Macros is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - Env.Replace_With_Closure_Sub (First.Function_Value.Closure); - First.Function_Value.Set_Binds (Env, Args); - Ast := First.Function_Value.Expression; + Env.Replace_With_Sub (Outer => First.Fn.Env, + Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; goto Restart; end; when Kind_Macro => - declare - New_Env : constant Environments.Ptr := Env.Sub; - begin - First.Function_Value.Set_Binds (New_Env, Ast.L); - Ast := Eval (First.Function_Value.Expression, New_Env); - end; + Ast := Eval (Ast0 => First.Fn.Ast, + Env0 => Envs.Sub (Outer => Env, + Binds => First.Fn.Params, + Exprs => Ast.List)); if Macroexpanding then return Ast; else goto Restart; end if; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T + Env : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. @@ -290,15 +266,15 @@ procedure Step8_Macros is for I in R'Range loop R (I) := List.Element (I); if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol + and then 0 < R (I).List.Length + and then R (I).List.Element (1).Kind = Kind_Symbol + and then R (I).List.Element (1).Symbol = Symbols.Names.Splice_Unquote then - if R (I).L.Length /= 2 then + if R (I).List.Length /= 2 then raise Argument_Error with "splice-unquote: expects 1 arg"; end if; - R (I) := Eval (R (I).L.Element (2), Env); + R (I) := Eval (R (I).List.Element (2), Env); if R (I).Kind /= Kind_List then raise Argument_Error with "splice-unquote: expects a list"; end if; @@ -314,24 +290,31 @@ procedure Step8_Macros is case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); when Kind_List => - if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.List.Length + and then Ast.List.Element (1).Kind = Kind_Symbol + and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then - return Eval (Ast.L.Element (2), Env); + return Eval (Ast.List.Element (2), Env); else - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); end if; when others => return Ast; end case; end Quasiquote; + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; + ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" @@ -347,11 +330,18 @@ procedure Step8_Macros is & " `(let* (or_FIXME ~(first xs))" & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; use Ada.Command_Line; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + -- Define ARGV from command line arguments. declare Args : Mal.T_Array (2 .. Argument_Count); begin @@ -360,9 +350,23 @@ begin end loop; Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); end; - if Argument_Count = 0 then - Interactive_Loop (Repl); + -- Script? + if 0 < Argument_Count then + Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); else - Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end if; end Step8_Macros; diff --git a/ada2/step9_try.adb b/ada2/step9_try.adb index 2fa414f0ef..8e90bd663d 100644 --- a/ada2/step9_try.adb +++ b/ada2/step9_try.adb @@ -2,12 +2,13 @@ with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -18,54 +19,49 @@ procedure Step9_Try is package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T; + Env0 : in Envs.Ptr) return Mal.T; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T; + Env : in Envs.Ptr) return Mal.T; -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks -- too much the step structure shared by all implementations. - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T + Env0 : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. - Ast : Mal.T := Ast0; - Env : Environments.Ptr := Env0.Copy_Pointer; - Macroexpanding : Boolean := False; + Ast : Mal.T := Ast0; + Env : Envs.Ptr := Env0.Copy_Pointer; + Macroexpanding : Boolean := False; First : Mal.T; begin <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -76,92 +72,93 @@ procedure Step9_Try is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "defmacro!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "defmacro!: arg 1 must be a symbol"; end if; declare - F : constant Mal.T := Eval (Ast.L.Element (3), Env); + F : constant Mal.T := Eval (Ast.List.Element (3), Env); begin if F.Kind /= Kind_Function then raise Argument_Error with "defmacro!: expects a function"; end if; - return R : constant Mal.T := F.Function_Value.New_Macro do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := F.Fn.New_Macro do + Env.Set (Ast.List.Element (2).Symbol, R); end return; end; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - Ast := Ast.L.Element (Ast.L.Length); + Ast := Ast.List.Element (Ast.List.Length); goto Restart; elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; - elsif Ast.L.Length = 3 then + elsif Ast.List.Length = 3 then return Mal.Nil; else - Ast := Ast.L.Element (4); + Ast := Ast.List.Element (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; begin if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; @@ -174,37 +171,37 @@ procedure Step9_Try is Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), Env)); end loop; - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "macroexpand: expects 1 argument"; end if; Macroexpanding := True; - Ast := Ast.L.Element (2); + Ast := Ast.List.Element (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quasiquote: expects 1 argument"; end if; - return Quasiquote (Ast.L.Element (2), Env); + return Quasiquote (Ast.List.Element (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quote: expects 1 argument"; end if; - return Ast.L.Element (2); + return Ast.List.Element (2); elsif First.Symbol = Symbols.Names.Try then - if Ast.L.Length = 2 then - Ast := Ast.L.Element (2); + if Ast.List.Length = 2 then + Ast := Ast.List.Element (2); goto Restart; - elsif Ast.L.Length /= 3 then + elsif Ast.List.Length /= 3 then raise Argument_Error with "try*: expects 1 or 2 arguments"; - elsif Ast.L.Element (3).Kind /= Kind_List then + elsif Ast.List.Element (3).Kind /= Kind_List then raise Argument_Error with "try*: argument 2 must be a list"; end if; declare - A3 : constant Lists.Ptr := Ast.L.Element (3).L; + A3 : constant Lists.Ptr := Ast.List.Element (3).List; begin if A3.Length /= 3 then raise Argument_Error with "try*: arg 2 must have 3 elements"; @@ -216,10 +213,10 @@ procedure Step9_Try is raise Argument_Error with "catch*: expects a symbol"; end if; begin - return Eval (Ast.L.Element (2), Env); + return Eval (Ast.List.Element (2), Env); exception when E : Reader.Empty_Source | Argument_Error - | Reader.Reader_Error | Environments.Unknown_Key => + | Reader.Reader_Error | Envs.Unknown_Key => Env.Replace_With_Sub; Env.Set (A3.Element (2).Symbol, Mal.T'(Kind_String, ASU.To_Unbounded_String @@ -229,7 +226,6 @@ procedure Step9_Try is when Core.Exception_Throwed => Env.Replace_With_Sub; Env.Set (A3.Element (2).Symbol, Core.Last_Exception); - Core.Last_Exception := Mal.Nil; Ast := A3.Element (3); goto Restart; -- Other exceptions are unexpected. @@ -245,86 +241,61 @@ procedure Step9_Try is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - Env.Replace_With_Closure_Sub (First.Function_Value.Closure); - First.Function_Value.Set_Binds (Env, Args); - Ast := First.Function_Value.Expression; + Env.Replace_With_Sub (Outer => First.Fn.Env, + Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; goto Restart; end; when Kind_Macro => - declare - New_Env : constant Environments.Ptr := Env.Sub; - begin - First.Function_Value.Set_Binds (New_Env, Ast.L); - Ast := Eval (First.Function_Value.Expression, New_Env); - end; + Ast := Eval (Ast0 => First.Fn.Ast, + Env0 => Envs.Sub (Outer => Env, + Binds => First.Fn.Params, + Exprs => Ast.List)); if Macroexpanding then return Ast; else goto Restart; end if; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - when Core.Exception_Throwed => - Ada.Text_IO.Put ("User exception: "); - Ada.Text_IO.Unbounded_IO.Put_Line (Print (Core.Last_Exception)); - Core.Last_Exception := Mal.Nil; - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T + Env : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. @@ -335,15 +306,15 @@ procedure Step9_Try is for I in R'Range loop R (I) := List.Element (I); if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol + and then 0 < R (I).List.Length + and then R (I).List.Element (1).Kind = Kind_Symbol + and then R (I).List.Element (1).Symbol = Symbols.Names.Splice_Unquote then - if R (I).L.Length /= 2 then + if R (I).List.Length /= 2 then raise Argument_Error with "splice-unquote: expects 1 arg"; end if; - R (I) := Eval (R (I).L.Element (2), Env); + R (I) := Eval (R (I).List.Element (2), Env); if R (I).Kind /= Kind_List then raise Argument_Error with "splice-unquote: expects a list"; end if; @@ -359,24 +330,31 @@ procedure Step9_Try is case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); when Kind_List => - if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.List.Length + and then Ast.List.Element (1).Kind = Kind_Symbol + and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then - return Eval (Ast.L.Element (2), Env); + return Eval (Ast.List.Element (2), Env); else - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); end if; when others => return Ast; end case; end Quasiquote; + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; + ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" @@ -392,11 +370,18 @@ procedure Step9_Try is & " `(let* (or_FIXME ~(first xs))" & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; use Ada.Command_Line; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + -- Define ARGV from command line arguments. declare Args : Mal.T_Array (2 .. Argument_Count); begin @@ -405,9 +390,27 @@ begin end loop; Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); end; - if Argument_Count = 0 then - Interactive_Loop (Repl); + -- Script? + if 0 < Argument_Count then + Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); else - Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + when Core.Exception_Throwed => + Ada.Text_IO.Put ("User exception: "); + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str + (Core.Last_Exception)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end if; end Step9_Try; diff --git a/ada2/stepa_mal.adb b/ada2/stepa_mal.adb index b660e17753..355b4be173 100644 --- a/ada2/stepa_mal.adb +++ b/ada2/stepa_mal.adb @@ -2,12 +2,13 @@ with Ada.Command_Line; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Interfaces.C.Strings; with Core; -with Environments; +with Envs; +with Eval_Cb; with Printer; with Reader; +with Readline; with Types.Functions; with Types.Lists; with Types.Mal; @@ -18,54 +19,49 @@ procedure StepA_Mal is package ASU renames Ada.Strings.Unbounded; use Types; - use type Symbols.Ptr; - function Read (Source : in String) return Mal.T - renames Reader.Read_Str; + function Read return Mal.T with Inline; function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T; + Env0 : in Envs.Ptr) return Mal.T; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T; + Env : in Envs.Ptr) return Mal.T; -- Mergeing quote and quasiquote into eval with a flag triggering -- a different behaviour as done for macros in step8 would improve -- the performances significantly, but Kanaka finds that it breaks -- too much the step structure shared by all implementations. - function Print (Ast : in Mal.T; - Readably : in Boolean := True) return ASU.Unbounded_String - renames Printer.Pr_Str; + procedure Print (Ast : in Mal.T) with Inline; - function Rep (Source : in String; - Env : in Environments.Ptr) return ASU.Unbounded_String - is (Print (Eval (Read (Source), Env))) with Inline; + procedure Rep (Env : in Envs.Ptr) with Inline; - procedure Interactive_Loop (Repl : in Environments.Ptr); - - function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval); + function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + -- Procedural form of Eval. -- Convenient when the result of eval is of no interest. - procedure Discard (Ast : in Mal.T) is null; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) with Inline; ---------------------------------------------------------------------- function Eval (Ast0 : in Mal.T; - Env0 : in Environments.Ptr) return Mal.T + Env0 : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. - Ast : Mal.T := Ast0; - Env : Environments.Ptr := Env0.Copy_Pointer; - Macroexpanding : Boolean := False; + Ast : Mal.T := Ast0; + Env : Envs.Ptr := Env0.Copy_Pointer; + Macroexpanding : Boolean := False; First : Mal.T; begin <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); - -- Environments.Dump_Stack; + -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -76,92 +72,93 @@ procedure StepA_Mal is when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.L, Env)); + return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.L.Length = 0 then + if Ast.List.Length = 0 then return Ast; end if; - First := Ast.L.Element (1); + First := Ast.List.Element (1); -- Special forms if First.Kind /= Kind_Symbol then -- Evaluate First, in the less frequent case where it is -- not a symbol. First := Eval (First, Env); elsif First.Symbol = Symbols.Names.Def then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "def!: arg 1 must be a symbol"; end if; - return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do + Env.Set (Ast.List.Element (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "defmacro!: expects 2 arguments"; - elsif Ast.L.Element (2).Kind /= Kind_Symbol then + elsif Ast.List.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "defmacro!: arg 1 must be a symbol"; end if; declare - F : constant Mal.T := Eval (Ast.L.Element (3), Env); + F : constant Mal.T := Eval (Ast.List.Element (3), Env); begin if F.Kind /= Kind_Function then raise Argument_Error with "defmacro!: expects a function"; end if; - return R : constant Mal.T := F.Function_Value.New_Macro do - Env.Set (Ast.L.Element (2).Symbol, R); + return R : constant Mal.T := F.Fn.New_Macro do + Env.Set (Ast.List.Element (2).Symbol, R); end return; end; elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.L.Length = 1 then + if Ast.List.Length = 1 then raise Argument_Error with "do: expects at least 1 argument"; end if; - for I in 2 .. Ast.L.Length - 1 loop - Discard (Eval (Ast.L.Element (I), Env)); + for I in 2 .. Ast.List.Length - 1 loop + Eval_P (Ast.List.Element (I), Env); end loop; - Ast := Ast.L.Element (Ast.L.Length); + Ast := Ast.List.Element (Ast.List.Length); goto Restart; elsif First.Symbol = Symbols.Names.Fn then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.L.Element (2).L.Length => - Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol) + elsif (for some F in 1 .. Ast.List.Element (2).List.Length => + Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) then raise Argument_Error with "fn*: arg 2 must contain symbols"; end if; - return Functions.New_Function (Ast.L.Element (2).L, - Ast.L.Element (3), Env.New_Closure); + return Functions.New_Function (Params => Ast.List.Element (2).List, + Ast => Ast.List.Element (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.L.Length not in 3 .. 4 then + if Ast.List.Length not in 3 .. 4 then raise Argument_Error with "if: expects 2 or 3 arguments"; end if; declare - Test : constant Mal.T := Eval (Ast.L.Element (2), Env); + Test : constant Mal.T := Eval (Ast.List.Element (2), Env); begin if (case Test.Kind is when Kind_Nil => False, when Kind_Boolean => Test.Ada_Boolean, when others => True) then - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; - elsif Ast.L.Length = 3 then + elsif Ast.List.Length = 3 then return Mal.Nil; else - Ast := Ast.L.Element (4); + Ast := Ast.List.Element (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.L.Length /= 3 then + if Ast.List.Length /= 3 then raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then + elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then raise Argument_Error with "let*: expects a list or vector"; end if; declare - Bindings : constant Lists.Ptr := Ast.L.Element (2).L; + Bindings : constant Lists.Ptr := Ast.List.Element (2).List; begin if Bindings.Length mod 2 /= 0 then raise Argument_Error with "let*: odd number of bindings"; @@ -174,37 +171,37 @@ procedure StepA_Mal is Env.Set (Bindings.Element (2 * I - 1).Symbol, Eval (Bindings.Element (2 * I), Env)); end loop; - Ast := Ast.L.Element (3); + Ast := Ast.List.Element (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "macroexpand: expects 1 argument"; end if; Macroexpanding := True; - Ast := Ast.L.Element (2); + Ast := Ast.List.Element (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quasiquote: expects 1 argument"; end if; - return Quasiquote (Ast.L.Element (2), Env); + return Quasiquote (Ast.List.Element (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.L.Length /= 2 then + if Ast.List.Length /= 2 then raise Argument_Error with "quote: expects 1 argument"; end if; - return Ast.L.Element (2); + return Ast.List.Element (2); elsif First.Symbol = Symbols.Names.Try then - if Ast.L.Length = 2 then - Ast := Ast.L.Element (2); + if Ast.List.Length = 2 then + Ast := Ast.List.Element (2); goto Restart; - elsif Ast.L.Length /= 3 then + elsif Ast.List.Length /= 3 then raise Argument_Error with "try*: expects 1 or 2 arguments"; - elsif Ast.L.Element (3).Kind /= Kind_List then + elsif Ast.List.Element (3).Kind /= Kind_List then raise Argument_Error with "try*: argument 2 must be a list"; end if; declare - A3 : constant Lists.Ptr := Ast.L.Element (3).L; + A3 : constant Lists.Ptr := Ast.List.Element (3).List; begin if A3.Length /= 3 then raise Argument_Error with "try*: arg 2 must have 3 elements"; @@ -216,10 +213,10 @@ procedure StepA_Mal is raise Argument_Error with "catch*: expects a symbol"; end if; begin - return Eval (Ast.L.Element (2), Env); + return Eval (Ast.List.Element (2), Env); exception when E : Reader.Empty_Source | Argument_Error - | Reader.Reader_Error | Environments.Unknown_Key => + | Reader.Reader_Error | Envs.Unknown_Key => Env.Replace_With_Sub; Env.Set (A3.Element (2).Symbol, Mal.T'(Kind_String, ASU.To_Unbounded_String @@ -229,7 +226,6 @@ procedure StepA_Mal is when Core.Exception_Throwed => Env.Replace_With_Sub; Env.Set (A3.Element (2).Symbol, Core.Last_Exception); - Core.Last_Exception := Mal.Nil; Ast := A3.Element (3); goto Restart; -- Other exceptions are unexpected. @@ -245,95 +241,70 @@ procedure StepA_Mal is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Builtin_With_Meta => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - return First.Builtin_With_Meta.Data.all (Args); + return First.Builtin_With_Meta.Builtin.all (Args); end; when Kind_Function => declare - Args : Mal.T_Array (2 .. Ast.L.Length); + Args : Mal.T_Array (2 .. Ast.List.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.L.Element (I), Env); + Args (I) := Eval (Ast.List.Element (I), Env); end loop; - Env.Replace_With_Closure_Sub (First.Function_Value.Closure); - First.Function_Value.Set_Binds (Env, Args); - Ast := First.Function_Value.Expression; + Env.Replace_With_Sub (Outer => First.Fn.Env, + Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; goto Restart; end; when Kind_Macro => - declare - New_Env : constant Environments.Ptr := Env.Sub; - begin - First.Function_Value.Set_Binds (New_Env, Ast.L); - Ast := Eval (First.Function_Value.Expression, New_Env); - end; + Ast := Eval (Ast0 => First.Fn.Ast, + Env0 => Envs.Sub (Outer => Env, + Binds => First.Fn.Params, + Exprs => Ast.List)); if Macroexpanding then return Ast; else goto Restart; end if; when others => - raise Argument_Error - with "cannot execute " & ASU.To_String (Print (First)); + raise Argument_Error with "cannot call " & Printer.Img (First); end case; end case; end Eval; - procedure Interactive_Loop (Repl : in Environments.Ptr) is - use Interfaces.C, Interfaces.C.Strings; - function Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - Prompt : constant char_array := To_C ("user> "); - C_Line : chars_ptr; + procedure Eval_P (Ast : in Mal.T; + Env : in Envs.Ptr) + is + Result : constant Mal.T := Eval (Ast, Env); begin - loop - C_Line := Readline (Prompt); - exit when C_Line = Null_Ptr; - declare - Line : constant String := Value (C_Line); - begin - if Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl)); - exception - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error - | Environments.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - when Core.Exception_Throwed => - Ada.Text_IO.Put ("User exception: "); - Ada.Text_IO.Unbounded_IO.Put_Line (Print (Core.Last_Exception)); - Core.Last_Exception := Mal.Nil; - -- Other exceptions are unexpected. - end; - end loop; - Ada.Text_IO.New_Line; - end Interactive_Loop; + pragma Unreferenced (Result); + end Eval_P; + + procedure Print (Ast : in Mal.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; function Quasiquote (Ast : in Mal.T; - Env : in Environments.Ptr) return Mal.T + Env : in Envs.Ptr) return Mal.T is + use type Symbols.Ptr; + function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. @@ -344,15 +315,15 @@ procedure StepA_Mal is for I in R'Range loop R (I) := List.Element (I); if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).L.Length - and then R (I).L.Element (1).Kind = Kind_Symbol - and then R (I).L.Element (1).Symbol + and then 0 < R (I).List.Length + and then R (I).List.Element (1).Kind = Kind_Symbol + and then R (I).List.Element (1).Symbol = Symbols.Names.Splice_Unquote then - if R (I).L.Length /= 2 then + if R (I).List.Length /= 2 then raise Argument_Error with "splice-unquote: expects 1 arg"; end if; - R (I) := Eval (R (I).L.Element (2), Env); + R (I) := Eval (R (I).List.Element (2), Env); if R (I).Kind /= Kind_List then raise Argument_Error with "splice-unquote: expects a list"; end if; @@ -368,24 +339,31 @@ procedure StepA_Mal is case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); when Kind_List => - if 0 < Ast.L.Length - and then Ast.L.Element (1).Kind = Kind_Symbol - and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.List.Length + and then Ast.List.Element (1).Kind = Kind_Symbol + and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then - return Eval (Ast.L.Element (2), Env); + return Eval (Ast.List.Element (2), Env); else - return Quasiquote_List (Ast.L); + return Quasiquote_List (Ast.List); end if; when others => return Ast; end case; end Quasiquote; + function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + Print (Eval (Read, Env)); + end Rep; + ---------------------------------------------------------------------- - Startup : constant String := "(do" + Startup : constant String := "(do " & "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" @@ -406,11 +384,18 @@ procedure StepA_Mal is & " (if ~condvar ~condvar (or ~@(rest xs)))))))))" & "(def! *host-language* ""ada2"")" & ")"; - Repl : Environments.Ptr renames Environments.Repl; + Repl : Envs.Ptr renames Envs.Repl; use Ada.Command_Line; begin - Core.Eval_Ref := Eval'Unrestricted_Access; - Discard (Eval (Read (Startup), Repl)); + -- Show the Eval function to other packages. + Eval_Cb.Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + for Binding of Core.Ns loop + Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); + end loop; + -- Native startup procedure. + Eval_P (Reader.Read_Str (Startup), Repl); + -- Define ARGV from command line arguments. declare Args : Mal.T_Array (2 .. Argument_Count); begin @@ -419,11 +404,29 @@ begin end loop; Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); end; - if Argument_Count = 0 then - Discard (Eval (Read ("(println (str ""Mal ["" *host-language* ""]""))"), - Repl)); - Interactive_Loop (Repl); + -- Script? + if 0 < Argument_Count then + Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); else - Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl)); + Eval_P (Reader.Read_Str + ("(println (str ""Mal ["" *host-language* ""]""))"), Repl); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Reader.Empty_Source => + null; + when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + when Core.Exception_Throwed => + Ada.Text_IO.Put ("User exception: "); + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str + (Core.Last_Exception)); + -- Other exceptions are unexpected. + end; + end loop; + Ada.Text_IO.New_Line; end if; end StepA_Mal; diff --git a/ada2/types-atoms.adb b/ada2/types-atoms.adb index 6f0afb76ed..952504a1e5 100644 --- a/ada2/types-atoms.adb +++ b/ada2/types-atoms.adb @@ -1,5 +1,6 @@ with Ada.Unchecked_Deallocation; +with Printer; with Types.Mal; package body Types.Atoms is @@ -21,11 +22,10 @@ package body Types.Atoms is function Atom (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then raise Argument_Error with "atom: expects 1 argument" - else - (Kind => Kind_Atom, - Atom => (Ada.Finalization.Controlled with - Ref => new Rec'(Data => Args (Args'First), - Refs => 1)))); + else + (Kind_Atom, (Ada.Finalization.Controlled with new Rec' + (Refs => 1, + Data => Args (Args'First))))); function Deref (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then @@ -33,7 +33,10 @@ package body Types.Atoms is elsif Args (Args'First).Kind /= Kind_Atom then raise Argument_Error with "deref: expects an atom" else - (Args (Args'First).Atom.Ref.all.Data)); + Args (Args'First).Atom.Ref.all.Data); + + function Deref (Item : in Ptr) return Mal.T + is (Item.Ref.all.Data); procedure Finalize (Object : in out Ptr) is begin @@ -53,10 +56,37 @@ package body Types.Atoms is raise Argument_Error with "reset: expects 2 arguments"; elsif Args (Args'First).Kind /= Kind_Atom then raise Argument_Error with "reset: first argument must be an atom"; - else - Args (Args'First).Atom.Ref.all.Data := Args (Args'Last); - return Args (Args'Last); end if; + Args (Args'First).Atom.Ref.all.Data := Args (Args'Last); + return Args (Args'Last); end Reset; + function Swap (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length < 2 then + raise Argument_Error with "swap!: expects at least 2 arguments"; + elsif Args (Args'First).Kind /= Kind_Atom then + raise Argument_Error with "swap!: first argument must be an atom"; + end if; + declare + use type Mal.T_Array; + X : Mal.T renames Args (Args'First).Atom.Ref.all.Data; + F : Mal.T renames Args (Args'First + 1); + A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last); + begin + case F.Kind is + when Kind_Builtin => + X := F.Builtin.all (A); + when Kind_Builtin_With_Meta => + X := F.Builtin_With_Meta.Builtin.all (A); + when Kind_Function => + X := F.Fn.Apply (A); + when others => + raise Argument_Error + with "swap!: cannot call " & Printer.Img (F); + end case; + return X; + end; + end Swap; + end Types.Atoms; diff --git a/ada2/types-atoms.ads b/ada2/types-atoms.ads index 2ed928abc0..19ef44b372 100644 --- a/ada2/types-atoms.ads +++ b/ada2/types-atoms.ads @@ -5,20 +5,15 @@ limited with Types.Mal; package Types.Atoms is type Ptr is private; - -- A wrapper for a pointer counting references. - - -- The default value is invalid, new variables must be assigned - -- immediately (a hidden discriminant would prevent this type to - -- become a field inside Types.Mal.T, so we check this with a - -- private invariant a fallback, an invariant in the private part - -- checks that any created object is affected before use. - - -- Assignment give another reference to the same storage. -- Built-in functions. function Atom (Args : in Mal.T_Array) return Mal.T; function Deref (Args : in Mal.T_Array) return Mal.T; function Reset (Args : in Mal.T_Array) return Mal.T; + function Swap (Args : in Mal.T_Array) return Mal.T; + + -- Helper for print. + function Deref (Item : in Ptr) return Mal.T with Inline; private diff --git a/ada2/types-builtins.adb b/ada2/types-builtins.adb index 7f1dd79db0..450574795e 100644 --- a/ada2/types-builtins.adb +++ b/ada2/types-builtins.adb @@ -5,24 +5,24 @@ with Types.Mal; package body Types.Builtins is type Rec is limited record - Data : Ptr; - Refs : Natural; - Meta : Mal.T; + Builtin : Mal.Builtin_Ptr; + Refs : Natural; + Meta : Mal.T; end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); ---------------------------------------------------------------------- - procedure Adjust (Object : in out Ptr_With_Meta) is + procedure Adjust (Object : in out Ptr) is begin Object.Ref.all.Refs := Object.Ref.all.Refs + 1; end Adjust; - function Data (Item : in Ptr_With_Meta) return Ptr - is (Item.Ref.all.Data); + function Builtin (Item : in Ptr) return Mal.Builtin_Ptr + is (Item.Ref.all.Builtin); - procedure Finalize (Object : in out Ptr_With_Meta) is + procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then Object.Ref.all.Refs := Object.Ref.all.Refs - 1; @@ -34,20 +34,20 @@ package body Types.Builtins is end if; end Finalize; - function Meta (Item : in Ptr_With_Meta) return Mal.T + function Meta (Item : in Ptr) return Mal.T is (Item.Ref.all.Meta); - function With_Meta (Data : in Ptr; + function With_Meta (Builtin : in Mal.Builtin_Ptr; Metadata : in Mal.T) return Mal.T is (Kind_Builtin_With_Meta, (Ada.Finalization.Controlled with new Rec' - (Data => Data, - Meta => Metadata, - Refs => 1))); + (Builtin => Builtin, + Meta => Metadata, + Refs => 1))); - function With_Meta (Data : in Ptr_With_Meta; + function With_Meta (Item : in Ptr; Metadata : in Mal.T) return Mal.T -- Do not try to reuse the memory. We can hope that this kind of -- nonsense will be rare. - is (With_Meta (Data.Data, Metadata)); + is (With_Meta (Item.Ref.all.Builtin, Metadata)); end Types.Builtins; diff --git a/ada2/types-builtins.ads b/ada2/types-builtins.ads index 7ad35db427..2bd05be061 100644 --- a/ada2/types-builtins.ads +++ b/ada2/types-builtins.ads @@ -4,43 +4,30 @@ limited with Types.Mal; package Types.Builtins is - type Ptr is access function (Args : in Mal.T_Array) return Mal.T; - -- This access type is efficient and sufficient for most purposes, - -- as counting references is a waste of time for native functions, - -- which are often used as atomic elements. The controlled type - -- below is only useful when one has the silly idea to add - -- metadata to a built-in. + -- Types.Mal.Builtin_Ptr is efficient and sufficient for most + -- purposes, as counting references is a waste of time for native + -- functions. The controlled type below is only useful when one + -- has the silly idea to add metadata to a built-in. - type Ptr_With_Meta is tagged private; - -- A wrapper for a pointer counting references. + type Ptr is tagged private; - -- The default value is invalid, new variables must be assigned - -- immediately (a hidden discriminant would prevent this type to - -- become a field inside Types.Mal.T, so we check this with a - -- private invariant a fallback, an invariant in the private part - -- checks that any created object is affected before use. - - -- Assignment give another reference to the same storage. - - function With_Meta (Data : in Ptr; + function With_Meta (Builtin : in Mal.Builtin_Ptr; Metadata : in Mal.T) return Mal.T with Inline; - function With_Meta (Data : in Ptr_With_Meta; + function With_Meta (Item : in Ptr; Metadata : in Mal.T) return Mal.T with Inline; - function Meta (Item : in Ptr_With_Meta) return Mal.T with Inline; - function Data (Item : in Ptr_With_Meta) return Ptr with Inline; + function Meta (Item : in Ptr) return Mal.T with Inline; + function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline; private - -- See README for the implementation of reference counting. - type Rec; type Acc is access Rec; - type Ptr_With_Meta is new Ada.Finalization.Controlled with record + type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record with Invariant => Ref /= null; - overriding procedure Adjust (Object : in out Ptr_With_Meta) with Inline; - overriding procedure Finalize (Object : in out Ptr_With_Meta) with Inline; - pragma Finalize_Storage_Only (Ptr_With_Meta); + overriding procedure Adjust (Object : in out Ptr) with Inline; + overriding procedure Finalize (Object : in out Ptr) with Inline; + pragma Finalize_Storage_Only (Ptr); end Types.Builtins; diff --git a/ada2/types-functions.adb b/ada2/types-functions.adb index b40914767c..2446849341 100644 --- a/ada2/types-functions.adb +++ b/ada2/types-functions.adb @@ -1,25 +1,22 @@ -with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; -with Environments; -with Printer; +with Envs; +with Eval_Cb; with Types.Lists; with Types.Mal; -with Types.Symbols.Names; +with Types.Symbols; package body Types.Functions is subtype AFC is Ada.Finalization.Controlled; - package ASU renames Ada.Strings.Unbounded; - use type Types.Symbols.Ptr; - - type Rec is limited record - Refs : Natural := 1; - Args : Lists.Ptr; - Expr : Mal.T; - Env : Environments.Closure_Ptr := Environments.Null_Closure; - Varargs : Boolean; - Meta : Mal.T := Mal.Nil; + use type Envs.Closure_Ptr; + + type Rec (Params_Last : Natural) is limited record + Ast : Mal.T; + Refs : Natural := 1; + Env : Envs.Closure_Ptr := Envs.Null_Closure; + Meta : Mal.T := Mal.Nil; + Params : Symbols.Symbol_Array (1 .. Params_Last); end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); @@ -31,11 +28,24 @@ package body Types.Functions is Object.Ref.all.Refs := Object.Ref.all.Refs + 1; end Adjust; - function Closure (Item : in Ptr) return Environments.Closure_Ptr - is (Item.Ref.all.Env); + function Apply (Item : in Ptr; + Args : in Mal.T_Array) return Mal.T is + begin + pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); + return Eval_Cb.Cb.all (Ast => Item.Ref.all.Ast, + Env => Envs.Sub (Outer => Item.Ref.all.Env, + Binds => Item.Ref.all.Params, + Exprs => Args)); + end Apply; + + function Ast (Item : in Ptr) return Mal.T + is (Item.Ref.all.Ast); - function Expression (Item : in Ptr) return Mal.T - is (Item.Ref.all.Expr); + function Env (Item : in Ptr) return Envs.Closure_Ptr is + begin + pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); + return Item.Ref.all.Env; + end Env; procedure Finalize (Object : in out Ptr) is begin @@ -49,25 +59,30 @@ package body Types.Functions is end if; end Finalize; - function Formals (Item : in Ptr) return Lists.Ptr - is (Item.Ref.all.Args); + function Params (Item : in Ptr) return Symbols.Symbol_Array + is (Item.Ref.all.Params); - function Meta (Item : in Ptr) return Mal.T - is (Item.Ref.all.Meta); + function Meta (Item : in Ptr) return Mal.T is + begin + pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); + return Item.Ref.all.Meta; + end Meta; - function New_Function (Formals : in Lists.Ptr; - Expression : in Mal.T; - Environment : in Environments.Closure_Ptr) + function New_Function (Params : in Lists.Ptr; + Ast : in Mal.T; + Env : in Envs.Closure_Ptr) return Mal.T - is (Kind_Function, - (AFC with new Rec' - (Args => Formals, - Expr => Expression, - Env => Environment, - Varargs => 1 < Formals.Length - and then Formals.Element (Formals.Length - 1).Symbol - = Symbols.Names.Ampersand, - others => <>))); + is + Ref : constant Acc := new Rec'(Params_Last => Params.Length, + Ast => Ast, + Env => Env, + others => <>); + begin + for I in 1 .. Params.Length loop + Ref.all.Params (I) := Params.Element (I).Symbol; + end loop; + return (Kind_Function, (AFC with Ref)); + end New_Function; function New_Macro (Item : in Ptr) return Mal.T is Old : Rec renames Item.Ref.all; @@ -77,95 +92,37 @@ package body Types.Functions is if Old.Refs = 1 then Ref := Item.Ref; Old.Refs := 2; - Old.Env := Environments.Null_Closure; - -- Finalize the previous closure. + Old.Env := Envs.Null_Closure; + -- Finalize the environment, it will not be used anymore. Old.Meta := Mal.Nil; else - Ref := new Rec'(Args => Item.Ref.all.Args, - Expr => Item.Ref.all.Expr, - Varargs => Item.Ref.all.Varargs, - others => <>); + Ref := new Rec'(Params_Last => Old.Params_Last, + Params => Old.Params, + Ast => Old.Ast, + others => <>); end if; return (Kind_Macro, (AFC with Ref)); end New_Macro; - procedure Set_Binds (Item : in Ptr; - Env : in Environments.Ptr; - Args : in Mal.T_Array) - is - R : Rec renames Item.Ref.all; - begin - if R.Varargs then - if Args'Length < R.Args.Length - 2 then - raise Argument_Error with "expected " - & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) - & ", got" & Args'Length'Img; - end if; - for I in 1 .. R.Args.Length - 2 loop - Env.Set (R.Args.Element (I).Symbol, Args (Args'First + I - 1)); - end loop; - Env.Set (R.Args.Element (R.Args.Length).Symbol, - Lists.List (Args (Args'First + R.Args.Length - 2 .. Args'Last))); - else - if Args'Length /= R.Args.Length then - raise Argument_Error with "expected " - & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) - & ", got" & Args'Length'Img; - end if; - for I in 1 .. R.Args.Length loop - Env.Set (R.Args.Element (I).Symbol, Args (Args'First + I - 1)); - end loop; - end if; - end Set_Binds; - - procedure Set_Binds (Item : in Ptr; - Env : in Environments.Ptr; - Args : in Lists.Ptr) - is - R : Rec renames Item.Ref.all; - begin - if R.Varargs then - if Args.Length - 1 < R.Args.Length - 2 then - raise Argument_Error with "expected " - & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) - & ", got" & Natural'Image (Args.Length - 1); - end if; - for I in 1 .. R.Args.Length - 2 loop - Env.Set (R.Args.Element (I).Symbol, Args.Element (1 + I)); - end loop; - Env.Set (R.Args.Element (R.Args.Length).Symbol, - Lists.Slice (Args, R.Args.Length)); - else - if Args.Length - 1 /= R.Args.Length then - raise Argument_Error with "expected " - & ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args))) - & ", got" & Natural'Image (Args.Length - 1); - end if; - for I in 1 .. R.Args.Length loop - Env.Set (R.Args.Element (I).Symbol, Args.Element (1 + I)); - end loop; - end if; - end Set_Binds; - - function With_Meta (Data : in Ptr; + function With_Meta (Item : in Ptr; Metadata : in Mal.T) return Mal.T is - Old : Rec renames Data.Ref.all; + Old : Rec renames Item.Ref.all; Ref : Acc; begin + pragma Assert (Old.Env /= Envs.Null_Closure); pragma Assert (0 < Old.Refs); if Old.Refs = 1 then - Ref := Data.Ref; + Ref := Item.Ref; Old.Refs := 2; Old.Meta := Metadata; else - Ref := new Rec'(Args => Data.Ref.all.Args, - Expr => Data.Ref.all.Expr, - Env => Data.Ref.all.Env, - Varargs => Data.Ref.all.Varargs, - Meta => Metadata, - others => <>); - + Ref := new Rec'(Params_Last => Old.Params_Last, + Params => Old.Params, + Ast => Old.Ast, + Env => Old.Env, + Meta => Metadata, + others => <>); end if; return (Kind_Function, (AFC with Ref)); end With_Meta; diff --git a/ada2/types-functions.ads b/ada2/types-functions.ads index ec996b38be..99a342edea 100644 --- a/ada2/types-functions.ads +++ b/ada2/types-functions.ads @@ -1,59 +1,41 @@ private with Ada.Finalization; -limited with Environments; +limited with Envs; limited with Types.Lists; limited with Types.Mal; +limited with Types.Symbols; package Types.Functions is type Ptr is tagged private; - -- A wrapper for a pointer counting references. + -- A pointer to an user-defined function or macro. - -- The default value is invalid, new variables must be assigned - -- immediately (a hidden discriminant would prevent this type to - -- become a field inside Types.Mal.T, so we check this with a - -- private invariant a fallback, an invariant in the private part - -- checks that any created object is affected before use. - - -- Assignment give another reference to the same storage. - - function New_Function (Formals : in Lists.Ptr; - Expression : in Mal.T; - Environment : in Environments.Closure_Ptr) - return Mal.T + function New_Function (Params : in Lists.Ptr; + Ast : in Mal.T; + Env : in Envs.Closure_Ptr) return Mal.T with Inline; - -- Equivalent to a sequence of Set with the formal parameters and - -- Args elements, except for the handling of "&". - -- May raise Argument_Count. - -- For functions. - procedure Set_Binds (Item : in Ptr; - Env : in Environments.Ptr; - Args : in Mal.T_Array); - function New_Macro (Item : in Ptr) return Mal.T with Inline; - -- Set_Binds for macros. - -- It skips the first element of Args. - procedure Set_Binds (Item : in Ptr; - Env : in Environments.Ptr; - Args : in Lists.Ptr); - -- Used when printing, or applying with specific requirements, - -- like allowing tail call optimization or macros. - function Formals (Item : in Ptr) return Lists.Ptr with Inline; - function Expression (Item : in Ptr) return Mal.T with Inline; - function Closure (Item : in Ptr) return Environments.Closure_Ptr - with Inline; + function Params (Item : in Ptr) return Symbols.Symbol_Array with Inline; + function Ast (Item : in Ptr) return Mal.T with Inline; + -- Useful to print. + + function Apply (Item : in Ptr; + Args : in Mal.T_Array) return Mal.T with Inline; + -- Fails for macros. + + function Env (Item : in Ptr) return Envs.Closure_Ptr with Inline; + -- Fails for macros. Required for TCO, instead of Apply. function Meta (Item : in Ptr) return Mal.T with Inline; - function With_Meta (Data : in Ptr; - Metadata : in Mal.T) - return Mal.T with Inline; + -- Fails for macros. + function With_Meta (Item : in Ptr; + Metadata : in Mal.T) return Mal.T with Inline; + -- Fails for macros. private - -- See README for the implementation of reference counting. - type Rec; type Acc is access Rec; type Ptr is new Ada.Finalization.Controlled with record diff --git a/ada2/types-lists.adb b/ada2/types-lists.adb index 7f25702915..37ce66df78 100644 --- a/ada2/types-lists.adb +++ b/ada2/types-lists.adb @@ -1,5 +1,6 @@ with Ada.Unchecked_Deallocation; +with Printer; with Types.Mal; package body Types.Lists is @@ -45,59 +46,58 @@ package body Types.Lists is if Arg.Kind not in Kind_List | Kind_Vector then raise Argument_Error with "concat: expects lists or vectors"; end if; - Sum := Sum + Arg.L.Ref.all.Last; + Sum := Sum + Arg.List.Ref.all.Last; end loop; Ref := new Rec (Sum); for Arg of reverse Args loop - Ref.all.Data (Sum - Arg.L.Ref.all.Last + 1 .. Sum) - := Arg.L.Ref.all.Data; - Sum := Sum - Arg.L.Ref.all.Last; + Ref.all.Data (Sum - Arg.List.Ref.all.Last + 1 .. Sum) + := Arg.List.Ref.all.Data; + Sum := Sum - Arg.List.Ref.all.Last; end loop; pragma Assert (Sum = 0); return (Kind_List, (AFC with Ref)); end Concat; function Conj (Args : in Mal.T_Array) return Mal.T is - Ref : Acc; begin if Args'Length = 0 then raise Argument_Error with "conj: expects at least 1 argument"; end if; - case Args (Args'First).Kind is - when Kind_List => - Ref := new Rec - (Args'Length - 1 + Args (Args'First).L.Ref.all.Last); - Ref.all.Data (Args'Length .. Ref.all.Last) - := Args (Args'First).L.Ref.all.Data; - for I in 1 .. Args'Length - 1 loop - Ref.all.Data (I) := Args (Args'Last - I + 1); - end loop; - return (Kind_List, (AFC with Ref)); - when Kind_Vector => - return (Kind_Vector, (AFC with new Rec' - (Last => Args'Length - 1 + Args (Args'First).L.Ref.all.Last, - Data => Args (Args'First).L.Ref.all.Data - & Args (Args'First + 1 .. Args'Last), - others => <>))); - when others => - raise Argument_Error with "conj: first arg must be list or vector"; - end case; + declare + A1 : Mal.T renames Args (Args'First); + Last : constant Natural := Args'Length - 1 + A1.List.Ref.all.Last; + Ref : constant Acc := new Rec (Last); + Data : Mal.T_Array renames Ref.all.Data; + begin + case A1.Kind is + when Kind_List => + Data (Args'Length .. Ref.all.Last) := A1.List.Ref.all.Data; + for I in 1 .. Args'Length - 1 loop + Data (I) := Args (Args'Last - I + 1); + end loop; + return (Kind_List, (AFC with Ref)); + when Kind_Vector => + Data := A1.List.Ref.all.Data + & Args (Args'First + 1 .. Args'Last); + return (Kind_Vector, (AFC with Ref)); + when others => + raise Argument_Error + with "conj: first argument must be a list or vector"; + end case; + end; end Conj; function Cons (Args : in Mal.T_Array) return Mal.T is begin if Args'Length /= 2 then raise Argument_Error with "cons: expects 2 arguments"; + elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "cons: last arg must be a list or vector"; end if; - case Args (Args'Last).Kind is - when Kind_List | Kind_Vector => - return (Kind_List, (AFC with new Rec' - (Last => 1 + Args (Args'Last).L.Ref.all.Last, - Data => Args (Args'First) & Args (Args'Last).L.Ref.all.Data, - others => <>))); - when others => - raise Argument_Error with "cons: last arg must be list or vector"; - end case; + return (Kind_List, (AFC with new Rec' + (Last => 1 + Args (Args'Last).List.Ref.all.Last, + Data => Args (Args'First) & Args (Args'Last).List.Ref.all.Data, + others => <>))); end Cons; function Count (Args : in Mal.T_Array) return Mal.T @@ -108,7 +108,7 @@ package body Types.Lists is when Kind_Nil => (Kind_Number, 0), when Kind_List | Kind_Vector => - (Kind_Number, Args (Args'First).L.Ref.all.Last), + (Kind_Number, Args (Args'First).List.Ref.all.Last), when others => raise Argument_Error with "count: expects a list or vector")); @@ -136,10 +136,10 @@ package body Types.Lists is when Kind_Nil => Mal.Nil, when Kind_List | Kind_Vector => - (if Args (Args'First).L.Ref.all.Last = 0 then + (if Args (Args'First).List.Ref.all.Last = 0 then Mal.Nil else - Args (Args'First).L.Ref.all.Data (1)), + Args (Args'First).List.Ref.all.Data (1)), when others => raise Argument_Error with "first: expects a list or vector")); @@ -173,7 +173,7 @@ package body Types.Lists is else (case Args (Args'First).Kind is when Kind_List | Kind_Vector => - (Kind_Boolean, Args (Args'First).L.Ref.all.Last = 0), + (Kind_Boolean, Args (Args'First).List.Ref.all.Last = 0), when others => raise Argument_Error with "empty?: expects a list or vector")); @@ -185,6 +185,49 @@ package body Types.Lists is Last => Args'Length, others => <>))); + function Map (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 2 then + raise Argument_Error with "map: expects 2 arguments"; + elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then + raise Argument_Error with "map: argument 2 must be a list or vector"; + end if; + declare + F : Mal.T renames Args (Args'First); + Old : Rec renames Args (Args'Last).List.Ref.all; + Ref : Acc; + begin + pragma Assert (0 < Old.Refs); + if Old.Refs = 1 then + Ref := Args (Args'Last).List.Ref; + Old.Refs := 2; + Old.Meta := Mal.Nil; + else + Ref := new Rec (Old.Last); + end if; + return R : constant Mal.T := (Kind_List, (AFC with Ref)) do + -- Now we can afford raising an exception. + case F.Kind is + when Kind_Builtin => + for I in Old.Data'Range loop + Ref.all.Data (I) := F.Builtin.all (Old.Data (I .. I)); + end loop; + when Kind_Builtin_With_Meta => + for I in Old.Data'Range loop + Ref.all.Data (I) + := F.Builtin_With_Meta.Builtin.all (Old.Data (I .. I)); + end loop; + when Kind_Function => + for I in Old.Data'Range loop + Ref.all.Data (I) := F.Fn.Apply (Old.Data (I .. I)); + end loop; + when others => + raise Argument_Error with "map: cannot call " & Printer.Img (F); + end case; + end return; + end; + end Map; + function Meta (Item : in Ptr) return Mal.T is (Item.Ref.all.Meta); @@ -196,34 +239,43 @@ package body Types.Lists is when Kind_List | Kind_Vector => (if Args (Args'First + 1).Kind /= Kind_Number then raise Argument_Error with "nth: last arg must be a number" - elsif 1 + Args (Args'Last).Ada_Number - in Args (Args'First).L.Ref.all.Data'Range + elsif 1 + Args (Args'Last).Number + in Args (Args'First).List.Ref.all.Data'Range then - Args (Args'First).L.Ref.all.Data - (1 + Args (Args'Last).Ada_Number) + Args (Args'First).List.Ref.all.Data + (1 + Args (Args'Last).Number) else raise Argument_Error with "nth: index out of bounds"), when others => raise Argument_Error with "nth: expects a list or vector")); - function Rest (Args : in Mal.T_Array) return Mal.T - is (Kind_List, (AFC with - (if Args'Length /= 1 then - raise Argument_Error with "rest: expects 1 argument" - else - (case Args (Args'First).Kind is - when Kind_Nil => - new Rec (0), - when Kind_List | Kind_Vector => - (if Args (Args'First).L.Ref.all.Last = 0 then - new Rec (0) - else - new Rec'(Last => Args (Args'First).L.Ref.all.Last - 1, - Data => Args (Args'First).L.Ref.all.Data - (2 .. Args (Args'First).L.Ref.all.Last), - others => <>)), - when others => - raise Argument_Error with "rest: expects a list or vector")))); + function Rest (Args : in Mal.T_Array) return Mal.T is + begin + if Args'Length /= 1 then + raise Argument_Error with "rest: expects 1 argument"; + end if; + declare + A1 : Mal.T renames Args (Args'First); + Ref : Acc; + begin + case A1.Kind is + when Kind_Nil => + Ref := new Rec (0); + when Kind_List | Kind_Vector => + if A1.List.Ref.all.Last = 0 then + Ref := new Rec (0); + else + Ref := new Rec' + (Last => A1.List.Ref.all.Last - 1, + Data => A1.List.Ref.all.Data (2 .. A1.List.Ref.all.Last), + others => <>); + end if; + when others => + raise Argument_Error with "rest: expects a list or vector"; + end case; + return (Kind_List, (AFC with Ref)); + end; + end Rest; function Slice (Item : in Ptr; Start : in Positive) diff --git a/ada2/types-lists.ads b/ada2/types-lists.ads index 1e9906315d..c33d3ca47f 100644 --- a/ada2/types-lists.ads +++ b/ada2/types-lists.ads @@ -5,15 +5,6 @@ limited with Types.Mal; package Types.Lists is type Ptr is tagged private; - -- A wrapper for a pointer counting references. - - -- The default value is invalid, new variables must be assigned - -- immediately (a hidden discriminant would prevent this type to - -- become a field inside Types.Mal.T, so we check this with a - -- private invariant a fallback, an invariant in the private part - -- checks that any created object is affected before use. - - -- Assignment give another reference to the same storage. -- Built-in functions. function Concat (Args : in Mal.T_Array) return Mal.T; @@ -23,6 +14,7 @@ package Types.Lists is function First (Args : in Mal.T_Array) return Mal.T; function Is_Empty (Args : in Mal.T_Array) return Mal.T; function List (Args : in Mal.T_Array) return Mal.T; + function Map (Args : in Mal.T_Array) return Mal.T; function Nth (Args : in Mal.T_Array) return Mal.T; function Rest (Args : in Mal.T_Array) return Mal.T; function Vector (Args : in Mal.T_Array) return Mal.T; diff --git a/ada2/types-mal.adb b/ada2/types-mal.adb index 7e613d4172..cc8914ced5 100644 --- a/ada2/types-mal.adb +++ b/ada2/types-mal.adb @@ -15,14 +15,14 @@ package body Types.Mal is Right.Kind = Kind_Boolean and then Left.Ada_Boolean = Right.Ada_Boolean, when Kind_Number => - Right.Kind = Kind_Number and then Left.Ada_Number = Right.Ada_Number, + Right.Kind = Kind_Number and then Left.Number = Right.Number, when Kind_Symbol => Right.Kind = Kind_Symbol and then Left.Symbol = Right.Symbol, -- Here is the part that differs from the predefined equality. when Kind_Keyword | Kind_String => Right.Kind = Left.Kind and then Left.S = Right.S, when Kind_List | Kind_Vector => - Right.Kind in Kind_List | Kind_Vector and then Left.L = Right.L, + Right.Kind in Kind_List | Kind_Vector and then Left.List = Right.List, when Kind_Map => Right.Kind = Kind_Map and then Left.Map = Right.Map, when others => diff --git a/ada2/types-mal.ads b/ada2/types-mal.ads index d7aec36428..ca35f67a52 100644 --- a/ada2/types-mal.ads +++ b/ada2/types-mal.ads @@ -46,6 +46,10 @@ package Types.Mal is -- language, and require deep changes (the discriminant can be -- changed for an in out or access parameter). + type T_Array; + type T; + type Builtin_Ptr is access function (Args : in T_Array) return T; + type T (Kind : Kind_Type := Kind_Nil) is record case Kind is when Kind_Nil => @@ -53,7 +57,7 @@ package Types.Mal is when Kind_Boolean => Ada_Boolean : Boolean; when Kind_Number => - Ada_Number : Integer; + Number : Integer; when Kind_Atom => Atom : Atoms.Ptr; when Kind_Keyword | Kind_String => @@ -61,15 +65,15 @@ package Types.Mal is when Kind_Symbol => Symbol : Symbols.Ptr; when Kind_List | Kind_Vector => - L : Lists.Ptr; + List : Lists.Ptr; when Kind_Map => Map : Maps.Ptr; when Kind_Builtin => - Builtin : Builtins.Ptr; + Builtin : Builtin_Ptr; when Kind_Builtin_With_Meta => - Builtin_With_Meta : Builtins.Ptr_With_Meta; + Builtin_With_Meta : Builtins.Ptr; when Kind_Function | Kind_Macro => - Function_Value : Functions.Ptr; + Fn : Functions.Ptr; end case; end record; diff --git a/ada2/types-maps.ads b/ada2/types-maps.ads index 3fd07b459e..de9cc9a4c8 100644 --- a/ada2/types-maps.ads +++ b/ada2/types-maps.ads @@ -5,15 +5,6 @@ limited with Types.Mal; package Types.Maps is type Ptr is tagged private; - -- A wrapper for a pointer counting references. - - -- The default value is invalid, new variables must be assigned - -- immediately (a hidden discriminant would prevent this type to - -- become a field inside Types.Mal.T, so we check this with a - -- private invariant a fallback, an invariant in the private part - -- checks that any created object is affected before use. - - -- Assignment give another reference to the same storage. -- Built-in functions. function Assoc (Args : in Mal.T_Array) return Mal.T; @@ -52,8 +43,6 @@ package Types.Maps is private - -- See README for the implementation of reference counting. - type Rec; type Acc is access Rec; type Ptr is new Ada.Finalization.Controlled with record diff --git a/ada2/types-symbols.adb b/ada2/types-symbols.adb index 91c013b249..7aa5f530d9 100644 --- a/ada2/types-symbols.adb +++ b/ada2/types-symbols.adb @@ -87,4 +87,26 @@ package body Types.Symbols is function To_String (Item : in Ptr) return String is (Item.Ref.all.Data); + function To_String (Item : in Symbol_Array) return String is + I : Natural := Item'Length + 1; + begin + for S of Item loop + I := I + S.Ref.all.Last; + end loop; + return R : String (1 .. I) do + R (1) := '('; + I := 2; + for S of Item loop + if 2 < I then + R (I) := ' '; + I := I + 1; + end if; + R (I .. I + S.Ref.all.Last - 1) := S.Ref.all.Data; + I := I + S.Ref.all.Last; + end loop; + pragma Assert (I = R'Last); + R (R'Last) := ')'; + end return; + end To_String; + end Types.Symbols; diff --git a/ada2/types-symbols.ads b/ada2/types-symbols.ads index b1368f1479..fea08366b2 100644 --- a/ada2/types-symbols.ads +++ b/ada2/types-symbols.ads @@ -4,18 +4,8 @@ private with Ada.Finalization; package Types.Symbols with Preelaborate is type Ptr is tagged private; - -- A wrapper for a pointer counting references. - - -- The default value is invalid, new variables must be assigned - -- immediately (a hidden discriminant would prevent this type to - -- become a field inside Types.Mal.T, so we check this with a - -- private invariant a fallback, an invariant in the private part - -- checks that any created object is affected before use. - - -- Assignment give another reference to the same storage. function Constructor (Source : in String) return Ptr with Inline; - -- The only way to assign a valid value. function To_String (Item : in Ptr) return String with Inline; @@ -25,6 +15,13 @@ package Types.Symbols with Preelaborate is -- Equality compares the contents. + type Symbol_Array is array (Positive range <>) of Symbols.Ptr; + + function To_String (Item : in Symbols.Symbol_Array) return String; + -- Returns something like "(a b)". Convenient for error + -- reporting, but redundant with Printer (where it is more + -- efficient to concatenate directly to an unbounded buffer). + private -- Only one instance is allocated with a given content. This @@ -43,8 +40,6 @@ private -- probably because it significantly increases the size of -- Mal_Type. - -- See README for the implementation of reference counting. - type Rec; type Acc is access Rec; type Ptr is new Ada.Finalization.Controlled with record From a5d17b88f4b7d037b1c87e51beae60467a4257cb Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 10 Mar 2019 00:14:59 +0100 Subject: [PATCH 0488/1998] ada2: fix formatting and typos, add comments, check more errors. Only attempt to spare a recursion after step5, this is more consistent with the process. --- ada2/core.adb | 7 +++--- ada2/envs.adb | 10 +++++--- ada2/envs.ads | 3 +++ ada2/step2_eval.adb | 22 +++++++++++------ ada2/step3_env.adb | 42 +++++++++++++++++-------------- ada2/step4_if_fn_do.adb | 42 +++++++++++++++++-------------- ada2/step5_tco.adb | 50 ++++++++++++++++++++++++------------- ada2/step6_file.adb | 50 ++++++++++++++++++++++++------------- ada2/step7_quote.adb | 53 ++++++++++++++++++++++++++------------- ada2/step8_macros.adb | 53 ++++++++++++++++++++++++++------------- ada2/step9_try.adb | 55 +++++++++++++++++++++++++++-------------- ada2/stepa_mal.adb | 55 +++++++++++++++++++++++++++-------------- ada2/types-mal.adb | 2 +- ada2/types-mal.ads | 2 +- ada2/types-maps.adb | 5 ++-- 15 files changed, 292 insertions(+), 159 deletions(-) diff --git a/ada2/core.adb b/ada2/core.adb index 03e2ccc150..c4db4ef609 100644 --- a/ada2/core.adb +++ b/ada2/core.adb @@ -149,8 +149,9 @@ package body Core is function Is_False (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then raise Argument_Error with "false?: expects 1 argument" - else (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean - and then not Args (Args'First).Ada_Boolean)); + else + (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then not Args (Args'First).Ada_Boolean)); function Is_Function (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then @@ -405,7 +406,7 @@ package body Core is function Symbol (Args : in Mal.T_Array) return Mal.T is (if Args'Length /= 1 then - raise Argument_Error with "symbol?: expects 1 argument" + raise Argument_Error with "symbol: expects 1 argument" else (Kind_Symbol, Symbols.Constructor (ASU.To_String (Args (Args'First).S)))); diff --git a/ada2/envs.adb b/ada2/envs.adb index ae197eea1d..cd585aec5a 100644 --- a/ada2/envs.adb +++ b/ada2/envs.adb @@ -1,6 +1,8 @@ with Ada.Containers.Hashed_Maps; +-- with Ada.Text_IO.Unbounded_IO; with Ada.Unchecked_Deallocation; +-- with Printer; with Types.Symbols.Names; package body Envs is @@ -92,7 +94,7 @@ package body Envs is return (Ada.Finalization.Limited_Controlled with Env.Index); end Copy_Pointer; - -- procedure Dump_Stack (Long : Boolean := False) is + -- procedure Dump_Stack (Long : in Boolean := False) is -- use Ada.Text_IO; -- use Ada.Text_IO.Unbounded_IO; -- begin @@ -336,9 +338,9 @@ package body Envs is else Exprs'Length /= Binds'Length) then - raise Argument_Error with "user function expected " + raise Argument_Error with "function expected " & Symbols.To_String (Binds) & ", got" - & Integer'Image (Exprs'Length) & " actual parameters"; + & Integer'Image (Exprs'Length) & " actual parameter(s)"; end if; for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I)); @@ -364,7 +366,7 @@ package body Envs is then raise Argument_Error with "macro expected " & Symbols.To_String (Binds) & ", got" - & Integer'Image (Exprs.Length - 1) & "actual parameters"; + & Integer'Image (Exprs.Length - 1) & " actual parameter(s)"; end if; for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop M.Include (Binds (Binds'First + I), Exprs.Element (2 + I)); diff --git a/ada2/envs.ads b/ada2/envs.ads index b7082a6c17..b5b931b8fe 100644 --- a/ada2/envs.ads +++ b/ada2/envs.ads @@ -89,6 +89,9 @@ package Envs with Elaborate_Body is -- * The Exprs argument is a list. -- * Its first element is skipped. + -- procedure Dump_Stack (Long : in Boolean := False); + -- For debugging. + private -- There must be a reference level so that functions may keep diff --git a/ada2/step2_eval.adb b/ada2/step2_eval.adb index 7a5f9f72d3..101734b46c 100644 --- a/ada2/step2_eval.adb +++ b/ada2/step2_eval.adb @@ -47,7 +47,7 @@ procedure Step2_Eval is begin -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String | Kind_Keyword | Kind_Macro | Kind_Function @@ -70,12 +70,19 @@ procedure Step2_Eval is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Eval (Ast.List.Element (1), Env); - -- Apply phase. - case First.Kind is + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Eval (Ast.List.Element (1), Env); + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -87,7 +94,6 @@ procedure Step2_Eval is end; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; diff --git a/ada2/step3_env.adb b/ada2/step3_env.adb index 79290d58da..9a4294f31c 100644 --- a/ada2/step3_env.adb +++ b/ada2/step3_env.adb @@ -40,7 +40,7 @@ procedure Step3_Env is begin -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -54,16 +54,20 @@ procedure Step3_Env is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -97,13 +101,16 @@ procedure Step3_Env is return Eval (Ast.List.Element (3), New_Env); end; else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. - First := Env.Get (First.Symbol); + First := Eval (First, Env); end if; - -- Apply phase. - case First.Kind is + when others => + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -115,7 +122,6 @@ procedure Step3_Env is end; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; diff --git a/ada2/step4_if_fn_do.adb b/ada2/step4_if_fn_do.adb index d96d28c7bf..342f9dd737 100644 --- a/ada2/step4_if_fn_do.adb +++ b/ada2/step4_if_fn_do.adb @@ -44,7 +44,7 @@ procedure Step4_If_Fn_Do is begin -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -58,16 +58,20 @@ procedure Step4_If_Fn_Do is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -141,13 +145,16 @@ procedure Step4_If_Fn_Do is return Eval (Ast.List.Element (3), New_Env); end; else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. - First := Env.Get (First.Symbol); + First := Eval (First, Env); end if; - -- Apply phase. - case First.Kind is + when others => + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -168,7 +175,6 @@ procedure Step4_If_Fn_Do is end; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; diff --git a/ada2/step5_tco.adb b/ada2/step5_tco.adb index b6079454a6..2e109e393a 100644 --- a/ada2/step5_tco.adb +++ b/ada2/step5_tco.adb @@ -49,7 +49,7 @@ procedure Step5_Tco is <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -63,16 +63,20 @@ procedure Step5_Tco is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -148,13 +152,26 @@ procedure Step5_Tco is goto Restart; end; else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - -- Apply phase. - case First.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Kind_List | Kind_Vector | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -179,7 +196,6 @@ procedure Step5_Tco is end; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; diff --git a/ada2/step6_file.adb b/ada2/step6_file.adb index 57988f7df6..42294855b9 100644 --- a/ada2/step6_file.adb +++ b/ada2/step6_file.adb @@ -52,7 +52,7 @@ procedure Step6_File is <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -66,16 +66,20 @@ procedure Step6_File is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -151,13 +155,26 @@ procedure Step6_File is goto Restart; end; else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - -- Apply phase. - case First.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Kind_List | Kind_Vector | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -182,7 +199,6 @@ procedure Step6_File is end; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; diff --git a/ada2/step7_quote.adb b/ada2/step7_quote.adb index 9424e615da..2d517a65e4 100644 --- a/ada2/step7_quote.adb +++ b/ada2/step7_quote.adb @@ -59,7 +59,7 @@ procedure Step7_Quote is <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -73,16 +73,20 @@ procedure Step7_Quote is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -168,13 +172,26 @@ procedure Step7_Quote is end if; return Ast.List.Element (2); else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - -- Apply phase. - case First.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Kind_List | Kind_Vector | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -199,7 +216,6 @@ procedure Step7_Quote is end; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; @@ -262,6 +278,9 @@ procedure Step7_Quote is and then Ast.List.Element (1).Kind = Kind_Symbol and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then + if 2 < Ast.List.Length then + raise Argument_Error with "unquote: expects 1 argument"; + end if; return Eval (Ast.List.Element (2), Env); else return Quasiquote_List (Ast.List); diff --git a/ada2/step8_macros.adb b/ada2/step8_macros.adb index 5240b589f2..ac46883274 100644 --- a/ada2/step8_macros.adb +++ b/ada2/step8_macros.adb @@ -60,7 +60,7 @@ procedure Step8_Macros is <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -74,16 +74,20 @@ procedure Step8_Macros is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -192,13 +196,26 @@ procedure Step8_Macros is end if; return Ast.List.Element (2); else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - -- Apply phase. - case First.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Kind_List | Kind_Vector | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -233,7 +250,6 @@ procedure Step8_Macros is end if; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; @@ -296,6 +312,9 @@ procedure Step8_Macros is and then Ast.List.Element (1).Kind = Kind_Symbol and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then + if 2 < Ast.List.Length then + raise Argument_Error with "unquote: expects 1 argument"; + end if; return Eval (Ast.List.Element (2), Env); else return Quasiquote_List (Ast.List); diff --git a/ada2/step9_try.adb b/ada2/step9_try.adb index 8e90bd663d..e7684390da 100644 --- a/ada2/step9_try.adb +++ b/ada2/step9_try.adb @@ -60,7 +60,7 @@ procedure Step9_Try is <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -74,16 +74,20 @@ procedure Step9_Try is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -208,7 +212,7 @@ procedure Step9_Try is elsif A3.Element (1).Kind /= Kind_Symbol or else A3.Element (1).Symbol /= Symbols.Names.Catch then - raise Argument_Error with "try*: arg 2 must be a catch*"; + raise Argument_Error with "try*: arg 2 must be 'catch*'"; elsif A3.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "catch*: expects a symbol"; end if; @@ -232,13 +236,26 @@ procedure Step9_Try is end; end; else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - -- Apply phase. - case First.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Kind_List | Kind_Vector | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -273,7 +290,6 @@ procedure Step9_Try is end if; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; @@ -336,6 +352,9 @@ procedure Step9_Try is and then Ast.List.Element (1).Kind = Kind_Symbol and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then + if 2 < Ast.List.Length then + raise Argument_Error with "unquote: expects 1 argument"; + end if; return Eval (Ast.List.Element (2), Env); else return Quasiquote_List (Ast.List); diff --git a/ada2/stepa_mal.adb b/ada2/stepa_mal.adb index 355b4be173..75977ddf14 100644 --- a/ada2/stepa_mal.adb +++ b/ada2/stepa_mal.adb @@ -60,7 +60,7 @@ procedure StepA_Mal is <> -- Ada.Text_IO.New_Line; -- Ada.Text_IO.Put ("EVAL: "); - -- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast)); + -- Print (Ast); -- Envs.Dump_Stack; case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String @@ -74,16 +74,20 @@ procedure StepA_Mal is when Kind_Vector => return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); when Kind_List => - if Ast.List.Length = 0 then - return Ast; - end if; - First := Ast.List.Element (1); - -- Special forms - if First.Kind /= Kind_Symbol then - -- Evaluate First, in the less frequent case where it is - -- not a symbol. - First := Eval (First, Env); - elsif First.Symbol = Symbols.Names.Def then + null; + end case; + + -- Ast is a list. + if Ast.List.Length = 0 then + return Ast; + end if; + First := Ast.List.Element (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Symbol = Symbols.Names.Def then if Ast.List.Length /= 3 then raise Argument_Error with "def!: expects 2 arguments"; elsif Ast.List.Element (2).Kind /= Kind_Symbol then @@ -208,7 +212,7 @@ procedure StepA_Mal is elsif A3.Element (1).Kind /= Kind_Symbol or else A3.Element (1).Symbol /= Symbols.Names.Catch then - raise Argument_Error with "try*: arg 2 must be a catch*"; + raise Argument_Error with "try*: arg 2 must be 'catch*'"; elsif A3.Element (2).Kind /= Kind_Symbol then raise Argument_Error with "catch*: expects a symbol"; end if; @@ -232,13 +236,26 @@ procedure StepA_Mal is end; end; else - -- Equivalent to First := Eval (First, Env), except that - -- we already know enough to spare a recursive call in - -- this frequent case. + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - -- Apply phase. - case First.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String + | Kind_Keyword | Kind_Macro | Kind_Function + | Kind_Builtin_With_Meta | Kind_Builtin => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Kind_List | Kind_Vector | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is when Kind_Builtin => declare Args : Mal.T_Array (2 .. Ast.List.Length); @@ -282,7 +299,6 @@ procedure StepA_Mal is end if; when others => raise Argument_Error with "cannot call " & Printer.Img (First); - end case; end case; end Eval; @@ -345,6 +361,9 @@ procedure StepA_Mal is and then Ast.List.Element (1).Kind = Kind_Symbol and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote then + if 2 < Ast.List.Length then + raise Argument_Error with "unquote: expects 1 argument"; + end if; return Eval (Ast.List.Element (2), Env); else return Quasiquote_List (Ast.List); diff --git a/ada2/types-mal.adb b/ada2/types-mal.adb index cc8914ced5..93c41409dd 100644 --- a/ada2/types-mal.adb +++ b/ada2/types-mal.adb @@ -13,7 +13,7 @@ package body Types.Mal is Right.Kind = Kind_Nil, when Kind_Boolean => Right.Kind = Kind_Boolean - and then Left.Ada_Boolean = Right.Ada_Boolean, + and then Left.Ada_Boolean = Right.Ada_Boolean, when Kind_Number => Right.Kind = Kind_Number and then Left.Number = Right.Number, when Kind_Symbol => diff --git a/ada2/types-mal.ads b/ada2/types-mal.ads index ca35f67a52..955d7a44e3 100644 --- a/ada2/types-mal.ads +++ b/ada2/types-mal.ads @@ -46,8 +46,8 @@ package Types.Mal is -- language, and require deep changes (the discriminant can be -- changed for an in out or access parameter). - type T_Array; type T; + type T_Array; type Builtin_Ptr is access function (Args : in T_Array) return T; type T (Kind : Kind_Type := Kind_Nil) is record diff --git a/ada2/types-maps.adb b/ada2/types-maps.adb index b0c333ff4a..6e70d5929a 100644 --- a/ada2/types-maps.adb +++ b/ada2/types-maps.adb @@ -75,8 +75,9 @@ package body Types.Maps is raise Argument_Error with "contains: expects 2 arguments" elsif Args (Args'First).Kind /= Kind_Map then raise Argument_Error with "contains: first arguement must be a map" - else (Kind_Boolean, - Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)))); + else + (Kind_Boolean, + Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)))); function Dissoc (Args : in Mal.T_Array) return Mal.T is begin From 2ddc3cd1a83bf40890a8878c8d1b5092abfd6e36 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 10 Mar 2019 00:14:59 +0100 Subject: [PATCH 0489/1998] ada2: replace a tail call with a jump in macroexpansion. --- ada2/envs.adb | 9 +++++++++ ada2/envs.ads | 8 ++++++++ ada2/step8_macros.adb | 16 +++++++++++----- ada2/step9_try.adb | 16 +++++++++++----- ada2/stepa_mal.adb | 16 +++++++++++----- 5 files changed, 50 insertions(+), 15 deletions(-) diff --git a/ada2/envs.adb b/ada2/envs.adb index cd585aec5a..cab3d403fc 100644 --- a/ada2/envs.adb +++ b/ada2/envs.adb @@ -318,6 +318,15 @@ package body Envs is Set_Binds (Stack (Top).Data, Binds, Exprs); end Replace_With_Sub; + procedure Replace_With_Sub_Macro (Env : in out Ptr; + Binds : in Symbols.Symbol_Array; + Exprs : in Lists.Ptr) + is + begin + Replace_With_Sub (Env); + Set_Binds_Macro (Stack (Top).Data, Binds, Exprs); + end Replace_With_Sub_Macro; + procedure Set (Env : in Ptr; Key : in Symbols.Ptr; New_Element : in Mal.T) is diff --git a/ada2/envs.ads b/ada2/envs.ads index b5b931b8fe..fdf73944df 100644 --- a/ada2/envs.ads +++ b/ada2/envs.ads @@ -46,6 +46,14 @@ package Envs with Elaborate_Body is -- except that such an assignment is forbidden for performance -- reasons. + procedure Replace_With_Sub_Macro (Env : in out Ptr; + Binds : in Types.Symbols.Symbol_Array; + Exprs : in Types.Lists.Ptr); + -- Equivalent to Env := Sub (Outer => Env, Binds, Expr), except + -- that such an assignment is forbidden for performance reasons. + -- This version is intended for macros: the Exprs argument is a + -- list, and its first element is skipped. + procedure Set (Env : in Ptr; Key : in Types.Symbols.Ptr; New_Element : in Types.Mal.T) diff --git a/ada2/step8_macros.adb b/ada2/step8_macros.adb index ac46883274..a1b00ed02a 100644 --- a/ada2/step8_macros.adb +++ b/ada2/step8_macros.adb @@ -239,13 +239,19 @@ procedure Step8_Macros is goto Restart; end; when Kind_Macro => - Ast := Eval (Ast0 => First.Fn.Ast, - Env0 => Envs.Sub (Outer => Env, - Binds => First.Fn.Params, - Exprs => Ast.List)); if Macroexpanding then - return Ast; + -- Evaluate the macro with tail call optimization. + Env.Replace_With_Sub_Macro (Binds => First.Fn.Params, + Exprs => Ast.List); + Ast := First.Fn.Ast; + goto Restart; else + -- Evaluate the macro normally. + Ast := Eval (Ast0 => First.Fn.Ast, + Env0 => Envs.Sub (Outer => Env, + Binds => First.Fn.Params, + Exprs => Ast.List)); + -- Then evaluate the result with TCO. goto Restart; end if; when others => diff --git a/ada2/step9_try.adb b/ada2/step9_try.adb index e7684390da..8291002fff 100644 --- a/ada2/step9_try.adb +++ b/ada2/step9_try.adb @@ -279,13 +279,19 @@ procedure Step9_Try is goto Restart; end; when Kind_Macro => - Ast := Eval (Ast0 => First.Fn.Ast, - Env0 => Envs.Sub (Outer => Env, - Binds => First.Fn.Params, - Exprs => Ast.List)); if Macroexpanding then - return Ast; + -- Evaluate the macro with tail call optimization. + Env.Replace_With_Sub_Macro (Binds => First.Fn.Params, + Exprs => Ast.List); + Ast := First.Fn.Ast; + goto Restart; else + -- Evaluate the macro normally. + Ast := Eval (Ast0 => First.Fn.Ast, + Env0 => Envs.Sub (Outer => Env, + Binds => First.Fn.Params, + Exprs => Ast.List)); + -- Then evaluate the result with TCO. goto Restart; end if; when others => diff --git a/ada2/stepa_mal.adb b/ada2/stepa_mal.adb index 75977ddf14..d3b44b0d95 100644 --- a/ada2/stepa_mal.adb +++ b/ada2/stepa_mal.adb @@ -288,13 +288,19 @@ procedure StepA_Mal is goto Restart; end; when Kind_Macro => - Ast := Eval (Ast0 => First.Fn.Ast, - Env0 => Envs.Sub (Outer => Env, - Binds => First.Fn.Params, - Exprs => Ast.List)); if Macroexpanding then - return Ast; + -- Evaluate the macro with tail call optimization. + Env.Replace_With_Sub_Macro (Binds => First.Fn.Params, + Exprs => Ast.List); + Ast := First.Fn.Ast; + goto Restart; else + -- Evaluate the macro normally. + Ast := Eval (Ast0 => First.Fn.Ast, + Env0 => Envs.Sub (Outer => Env, + Binds => First.Fn.Params, + Exprs => Ast.List)); + -- Then evaluate the result with TCO. goto Restart; end if; when others => From e2b412f9285f0b26586af9de87fa5a0096117993 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 10 Mar 2019 00:31:51 +0100 Subject: [PATCH 0490/1998] ada.2: rewrite the reader, for readability and efficiency. Use character sets and other language tools to delimit tokens. When possible, only test each input character once. Give verbose descriptions to subprograms. Simplify with one global variable instead of two. Improve reporting of ignored trailing items in input. --- ada2/reader.adb | 383 ++++++++++++++++++++++++++---------------------- 1 file changed, 204 insertions(+), 179 deletions(-) diff --git a/ada2/reader.adb b/ada2/reader.adb index 33d0c3c4a0..b2ec6b365b 100644 --- a/ada2/reader.adb +++ b/ada2/reader.adb @@ -1,4 +1,6 @@ +with Ada.Characters.Handling; with Ada.Characters.Latin_1; +with Ada.Strings.Maps.Constants; with Ada.Strings.Unbounded; with Types.Lists; @@ -7,224 +9,247 @@ with Types.Symbols.Names; package body Reader is - function Read_Str (Source : in String) return Types.Mal.T is + use Types; + use type Ada.Strings.Maps.Character_Set; + + Ignored_Set : constant Ada.Strings.Maps.Character_Set + := Ada.Strings.Maps.Constants.Control_Set + or Ada.Strings.Maps.To_Set (" ,;"); - use Types; + Symbol_Set : constant Ada.Strings.Maps.Character_Set + := not (Ignored_Set or Ada.Strings.Maps.To_Set ("""'()@[]^`{}~")); - First : Positive; - Last : Natural := Source'First - 1; + function Read_Str (Source : in String) return Types.Mal.T is + + I : Positive := Source'First; + -- Index of the currently considered character. function Read_Form return Mal.T; -- The recursive part of Read_Str. - procedure Find_Next_Token; - -- Search next token from index Last + 1. - -- If none is found, set First to Source'Last + 1. - -- Find_Next_Token is normally invoked right before Read_Form, - -- allowing the caller to check whether First <= Source'Last. - - ---------------------------------------------------------------------- + -- Helpers for Read_Form: - procedure Find_Next_Token is - use Ada.Characters.Latin_1; - begin - First := Last + 1; - while First <= Source'Last loop + procedure Skip_Ignored with Inline; + -- Check if the current character is ignorable or a comment. + -- Increment I until it exceeds Source'Last or designates + -- an interesting character. - case Source (First) is + procedure Skip_Digits with Inline; + -- Increment I at least once, until I exceeds Source'Last or + -- designates something else than a decimal digit. - when ' ' | ',' | HT | VT | LF | CR => - First := First + 1; + procedure Skip_Symbol with Inline; + -- Check if the current character is allowed in a symbol name. + -- Increment I uuntil it exceeds Source'Last or stops + -- designating an allowed character. - when '[' | ']' | '{' | '}' | '(' | ')' | ''' | '`' | '^' | '@' - => - Last := First; - exit; + -- Read_Atom has been merged into the same case/switch + -- statement, for clarity and efficiency. + function Read_List (Ending : in Character) return Mal.T_Array + with Inline; + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline; + function Read_String return Mal.T with Inline; + function Read_With_Meta return Mal.T with Inline; - when '~' => - if First + 1 <= Source'Last - and then Source (First + 1) = '@' - then - Last := First + 1; - else - Last := First; - end if; - exit; - - when '"' => - Last := First + 1; - loop - if Source'Last < Last then - raise Reader_Error with "unbalanced '""'"; - end if; - exit when Source (Last) = '"'; - if Source (Last) = '\' then - Last := Last + 1; - end if; - Last := Last + 1; - end loop; - exit; - - when ';' => - First := First + 1; - while First <= Source'Last loop - if Source (First) = LF then - First := First + 1; - exit; - end if; - First := First + 1; - end loop; - - when others => - Last := First; - while Last + 1 <= Source'Last - and then Source (Last + 1) not in - ' ' | ',' | HT | VT | LF | CR | '[' | ']' | '{' | '}' - | '(' | ')' | ''' | '`' | '^' | '@' | '~' | '"' | ';' - loop - Last := Last + 1; - end loop; - exit; + ---------------------------------------------------------------------- - end case; + function Read_List (Ending : in Character) return Mal.T_Array is + -- Big arrays on the stack are faster than repeated + -- dynamic reallocations. + Opening : constant Character := Source (I); + Buffer : Mal.T_Array (I + 1 .. Source'Last); + B_Last : Natural := I; + begin + I := I + 1; -- Skip (, [ or {. + loop + Skip_Ignored; + if Source'Last < I then + raise Reader_Error with "unbalanced '" & Opening & "'"; + end if; + exit when Source (I) = Ending; + B_Last := B_Last + 1; + Buffer (B_Last) := Read_Form; end loop; - end Find_Next_Token; + I := I + 1; -- Skip ), ] or }. + return Buffer (Buffer'First .. B_Last); + end Read_List; - function Read_Form return Mal.T is - - -- Read_Atom has been merged into the same case/switch - -- statement, for clarity and efficiency. - function Read_List (Ending : in Character) return Mal.T_Array - with Inline; - function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T - with Inline; - - function Read_List (Ending : in Character) return Mal.T_Array is - -- Using big arrays on the stack is faster than doing - -- repeated dynamic reallocations. - Buffer : Mal.T_Array (First + 1 .. Source'Last); - B_Last : Natural := Buffer'First - 1; - begin - loop - Find_Next_Token; - if Source'Last < First then - raise Reader_Error with "unbalanced '" & Ending & "'"; - end if; - exit when Source (First) = Ending; - B_Last := B_Last + 1; - Buffer (B_Last) := Read_Form; - end loop; - return Buffer (Buffer'First .. B_Last); - end Read_List; - - function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is - begin - Find_Next_Token; - if Source'Last < First then - raise Reader_Error with "Unfinished '" & Symbol.To_String & "'"; - end if; - return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form)); - end Read_Quote; + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is + begin + I := I + 1; -- Skip the initial ' or similar. + Skip_Ignored; + if Source'Last < I then + raise Reader_Error with "Incomplete '" & Symbol.To_String & "'"; + end if; + return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form)); + end Read_Quote; - use Ada.Strings.Unbounded; - begin -- Read_Form. - case Source (First) is - when '(' => - return Lists.List (Read_List (')')); - when '[' => - return Lists.Vector (Read_List (']')); - when '{' => - return Maps.Hash_Map (Read_List ('}')); + function Read_Form return Mal.T is + F : Positive; + begin + case Source (I) is + when ')' | ']' | '}' => + raise Reader_Error with "unbalanced '" & Source (I) & "'"; when '"' => - declare - Buffer : Unbounded_String; - I : Positive := First + 1; - begin - while I < Last loop - if Source (I) /= '\' or else I + 1 = Last then - Append (Buffer, Source (I)); - else - case Source (I + 1) is - when '\' | '"' => - I := I + 1; - Append (Buffer, Source (I)); - when 'n' => - I := I + 1; - Append (Buffer, Ada.Characters.Latin_1.LF); - when others => - Append (Buffer, Source (I)); - end case; - end if; - I := I + 1; - end loop; - return (Kind_String, Buffer); - end; + return Read_String; when ':' => - return (Kind_Keyword, - To_Unbounded_String (Source (First + 1 .. Last))); + I := I + 1; + F := I; + Skip_Symbol; + return (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String + (Source (F .. I - 1))); when '-' => - if First < Last - and then (for all C of Source (First + 1 .. Last) => - C in '0' .. '9') - then - return (Kind_Number, Integer'Value (Source (First .. Last))); - else - return (Kind_Symbol, - Symbols.Constructor (Source (First .. Last))); + F := I; + Skip_Digits; + if F + 1 < I then + return (Kind_Number, Integer'Value (Source (F .. I - 1))); + end if; + Skip_Symbol; + return (Kind_Symbol, Symbols.Constructor (Source (F .. I - 1))); + when '~' => + if I < Source'Last and then Source (I + 1) = '@' then + I := I + 1; + return Read_Quote (Symbols.Names.Splice_Unquote); end if; + return Read_Quote (Symbols.Names.Unquote); when '0' .. '9' => - return (Kind_Number, Integer'Value (Source (First .. Last))); + F := I; + Skip_Digits; + return (Kind_Number, Integer'Value (Source (F .. I - 1))); when ''' => return Read_Quote (Symbols.Names.Quote); when '`' => return Read_Quote (Symbols.Names.Quasiquote); when '@' => return Read_Quote (Symbols.Names.Deref); - when '~' => - if First = Last then - return Read_Quote (Symbols.Names.Unquote); - else - return Read_Quote (Symbols.Names.Splice_Unquote); - end if; when '^' => - declare - Args : Mal.T_Array (1 .. 3); - begin - Args (1) := (Kind_Symbol, Symbols.Names.With_Meta); - Find_Next_Token; - if Source'Last < First then - raise Reader_Error with "Unfinished 'with-meta'"; - end if; - Args (3) := Read_Form; - Find_Next_Token; - if Source'Last < First then - raise Reader_Error with "Unfinished 'with-meta'"; - end if; - Args (2) := Read_Form; - return Lists.List (Args); - end; + return Read_With_Meta; + when '(' => + return Lists.List (Read_List (')')); + when '[' => + return Lists.Vector (Read_List (']')); + when '{' => + return Maps.Hash_Map (Read_List ('}')); when others => - if Source (First .. Last) = "false" then + F := I; + Skip_Symbol; + if Source (F .. I - 1) = "false" then return (Kind_Boolean, False); - elsif Source (First .. Last) = "nil" then + elsif Source (F .. I - 1) = "nil" then return Mal.Nil; - elsif Source (First .. Last) = "true" then + elsif Source (F .. I - 1) = "true" then return (Kind_Boolean, True); - else - return (Kind_Symbol, - Symbols.Constructor (Source (First .. Last))); end if; + return (Kind_Symbol, Symbols.Constructor (Source (F .. I - 1))); end case; end Read_Form; + function Read_String return Mal.T is + use Ada.Strings.Unbounded; + S : Unbounded_String; + begin + loop + I := I + 1; + if Source'Last < I then + raise Reader_Error with "unbalanced '""'"; + end if; + case Source (I) is + when '"' => + exit; + when '\' => + I := I + 1; + if Source'Last < I then + raise Reader_Error with "unbalanced '""'"; + end if; + case Source (I) is + when '\' | '"' => + Append (S, Source (I)); + when 'n' => + Append (S, Ada.Characters.Latin_1.LF); + when others => + Append (S, Source (I - 1 .. I)); + end case; + when others => + Append (S, Source (I)); + end case; + end loop; + I := I + 1; -- Skip closing double quote. + return (Kind_String, S); + end Read_String; + + function Read_With_Meta return Mal.T is + Args : Mal.T_Array (1 .. 3); + begin + Args (1) := (Kind_Symbol, Symbols.Names.With_Meta); + + I := I + 1; -- Skip the initial ^. + + Skip_Ignored; + if Source'Last < I then + raise Reader_Error with "incomplete 'with-meta'"; + end if; + Args (3) := Read_Form; + + Skip_Ignored; + if Source'Last < I then + raise Reader_Error with "incomplete 'with-meta'"; + end if; + Args (2) := Read_Form; + + return Lists.List (Args); + end Read_With_Meta; + + procedure Skip_Digits is + use Ada.Characters.Handling; + begin + loop + I := I + 1; + exit when Source'Last < I or else not Is_Digit (Source (I)); + end loop; + end Skip_Digits; + + procedure Skip_Ignored is + use Ada.Characters.Handling; + use Ada.Strings.Maps; + begin + Ignored : while I <= Source'Last + and then Is_In (Source (I), Ignored_Set) + loop + if Source (I) = ';' then + Comment : loop + I := I + 1; + exit Ignored when Source'Last < I; + exit Comment when Is_Line_Terminator (Source (I)); + end loop Comment; + end if; + I := I + 1; + end loop Ignored; + end Skip_Ignored; + + procedure Skip_Symbol is + use Ada.Strings.Maps; + begin + while I <= Source'Last and then Is_In (Source (I), Symbol_Set) loop + I := I + 1; + end loop; + end Skip_Symbol; + ---------------------------------------------------------------------- - begin - Find_Next_Token; - if Source'Last < First then + Result : Mal.T; + begin -- Read_Str + Skip_Ignored; + if Source'Last < I then raise Empty_Source with "attempting to read an empty line"; end if; - return Read_Form; + Result := Read_Form; + Skip_Ignored; + if I <= Source'Last then + raise Reader_Error + with "unexpected characters '" & Source (I .. Source'Last) + & "' after '" & Source (Source'First .. I - 1) & '''; + end if; + return Result; end Read_Str; end Reader; From 1dc35df4871ed7200c239d492771fffd420907f5 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 10 Mar 2019 01:07:53 +0100 Subject: [PATCH 0491/1998] ada2: give an explicit prefix to fields in record invariants. This hopefully fixes the build with gnat-4.9. --- ada2/envs.ads | 2 +- ada2/types-atoms.ads | 2 +- ada2/types-builtins.ads | 2 +- ada2/types-functions.ads | 2 +- ada2/types-lists.ads | 2 +- ada2/types-maps.ads | 2 +- ada2/types-symbols.ads | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ada2/envs.ads b/ada2/envs.ads index fdf73944df..00c58102a7 100644 --- a/ada2/envs.ads +++ b/ada2/envs.ads @@ -126,7 +126,7 @@ private type Ptr is new Ada.Finalization.Limited_Controlled with record Index : Stack_Index := 0; end record - with Invariant => Index in 1 .. Top; + with Invariant => Ptr.Index in 1 .. Top; overriding procedure Finalize (Object : in out Ptr) with Inline; pragma Finalize_Storage_Only (Ptr); diff --git a/ada2/types-atoms.ads b/ada2/types-atoms.ads index 19ef44b372..057ef036cb 100644 --- a/ada2/types-atoms.ads +++ b/ada2/types-atoms.ads @@ -22,7 +22,7 @@ private type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record - with Invariant => Ref /= null; + with Invariant => Ptr.Ref /= null; overriding procedure Adjust (Object : in out Ptr) with Inline; overriding procedure Finalize (Object : in out Ptr) with Inline; pragma Finalize_Storage_Only (Ptr); diff --git a/ada2/types-builtins.ads b/ada2/types-builtins.ads index 2bd05be061..e5d99fbdc7 100644 --- a/ada2/types-builtins.ads +++ b/ada2/types-builtins.ads @@ -25,7 +25,7 @@ private type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record - with Invariant => Ref /= null; + with Invariant => Ptr.Ref /= null; overriding procedure Adjust (Object : in out Ptr) with Inline; overriding procedure Finalize (Object : in out Ptr) with Inline; pragma Finalize_Storage_Only (Ptr); diff --git a/ada2/types-functions.ads b/ada2/types-functions.ads index 99a342edea..8326245dcc 100644 --- a/ada2/types-functions.ads +++ b/ada2/types-functions.ads @@ -41,7 +41,7 @@ private type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record - with Invariant => Ref /= null; + with Invariant => Ptr.Ref /= null; overriding procedure Adjust (Object : in out Ptr) with Inline; overriding procedure Finalize (Object : in out Ptr) with Inline; pragma Finalize_Storage_Only (Ptr); diff --git a/ada2/types-lists.ads b/ada2/types-lists.ads index c33d3ca47f..7eefc0eb3e 100644 --- a/ada2/types-lists.ads +++ b/ada2/types-lists.ads @@ -66,7 +66,7 @@ private type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record - with Invariant => Ref /= null; + with Invariant => Ptr.Ref /= null; overriding procedure Adjust (Object : in out Ptr) with Inline; overriding procedure Finalize (Object : in out Ptr) with Inline; overriding function "=" (Left, Right : in Ptr) return Boolean; diff --git a/ada2/types-maps.ads b/ada2/types-maps.ads index de9cc9a4c8..aa67b5f479 100644 --- a/ada2/types-maps.ads +++ b/ada2/types-maps.ads @@ -48,7 +48,7 @@ private type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record - with Invariant => Ref /= null; + with Invariant => Ptr.Ref /= null; overriding procedure Adjust (Object : in out Ptr) with Inline; overriding procedure Finalize (Object : in out Ptr) with Inline; overriding function "=" (Left, Right : in Ptr) return Boolean with Inline; diff --git a/ada2/types-symbols.ads b/ada2/types-symbols.ads index fea08366b2..91be3a00b5 100644 --- a/ada2/types-symbols.ads +++ b/ada2/types-symbols.ads @@ -45,7 +45,7 @@ private type Ptr is new Ada.Finalization.Controlled with record Ref : Acc := null; end record - with Invariant => Ref /= null; + with Invariant => Ptr.Ref /= null; overriding procedure Adjust (Object : in out Ptr) with Inline; overriding procedure Finalize (Object : in out Ptr) with Inline; -- Predefined equality is fine. From e3b1335caa155273d1dde9ec8e6530ca1748ae79 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 10 Mar 2019 01:13:57 +0100 Subject: [PATCH 0492/1998] ada2: rename to ada.2 --- Makefile | 4 ++-- {ada2 => ada.2}/Makefile | 0 {ada2 => ada.2}/README | 0 {ada2 => ada.2}/core.adb | 0 {ada2 => ada.2}/core.ads | 0 {ada2 => ada.2}/envs.adb | 0 {ada2 => ada.2}/envs.ads | 0 {ada2 => ada.2}/eval_cb.ads | 0 {ada2 => ada.2}/printer.adb | 0 {ada2 => ada.2}/printer.ads | 0 {ada2 => ada.2}/reader.adb | 0 {ada2 => ada.2}/reader.ads | 0 {ada2 => ada.2}/readline.adb | 0 {ada2 => ada.2}/readline.ads | 0 {ada2 => ada.2}/run | 0 {ada2 => ada.2}/step0_repl.adb | 0 {ada2 => ada.2}/step1_read_print.adb | 0 {ada2 => ada.2}/step2_eval.adb | 0 {ada2 => ada.2}/step3_env.adb | 0 {ada2 => ada.2}/step4_if_fn_do.adb | 0 {ada2 => ada.2}/step5_tco.adb | 0 {ada2 => ada.2}/step6_file.adb | 0 {ada2 => ada.2}/step7_quote.adb | 0 {ada2 => ada.2}/step8_macros.adb | 0 {ada2 => ada.2}/step9_try.adb | 0 {ada2 => ada.2}/stepa_mal.adb | 0 {ada2 => ada.2}/types-atoms.adb | 0 {ada2 => ada.2}/types-atoms.ads | 0 {ada2 => ada.2}/types-builtins.adb | 0 {ada2 => ada.2}/types-builtins.ads | 0 {ada2 => ada.2}/types-functions.adb | 0 {ada2 => ada.2}/types-functions.ads | 0 {ada2 => ada.2}/types-lists.adb | 0 {ada2 => ada.2}/types-lists.ads | 0 {ada2 => ada.2}/types-mal.adb | 0 {ada2 => ada.2}/types-mal.ads | 0 {ada2 => ada.2}/types-maps.adb | 0 {ada2 => ada.2}/types-maps.ads | 0 {ada2 => ada.2}/types-symbols-names.ads | 0 {ada2 => ada.2}/types-symbols.adb | 0 {ada2 => ada.2}/types-symbols.ads | 0 {ada2 => ada.2}/types.ads | 0 42 files changed, 2 insertions(+), 2 deletions(-) rename {ada2 => ada.2}/Makefile (100%) rename {ada2 => ada.2}/README (100%) rename {ada2 => ada.2}/core.adb (100%) rename {ada2 => ada.2}/core.ads (100%) rename {ada2 => ada.2}/envs.adb (100%) rename {ada2 => ada.2}/envs.ads (100%) rename {ada2 => ada.2}/eval_cb.ads (100%) rename {ada2 => ada.2}/printer.adb (100%) rename {ada2 => ada.2}/printer.ads (100%) rename {ada2 => ada.2}/reader.adb (100%) rename {ada2 => ada.2}/reader.ads (100%) rename {ada2 => ada.2}/readline.adb (100%) rename {ada2 => ada.2}/readline.ads (100%) rename {ada2 => ada.2}/run (100%) rename {ada2 => ada.2}/step0_repl.adb (100%) rename {ada2 => ada.2}/step1_read_print.adb (100%) rename {ada2 => ada.2}/step2_eval.adb (100%) rename {ada2 => ada.2}/step3_env.adb (100%) rename {ada2 => ada.2}/step4_if_fn_do.adb (100%) rename {ada2 => ada.2}/step5_tco.adb (100%) rename {ada2 => ada.2}/step6_file.adb (100%) rename {ada2 => ada.2}/step7_quote.adb (100%) rename {ada2 => ada.2}/step8_macros.adb (100%) rename {ada2 => ada.2}/step9_try.adb (100%) rename {ada2 => ada.2}/stepa_mal.adb (100%) rename {ada2 => ada.2}/types-atoms.adb (100%) rename {ada2 => ada.2}/types-atoms.ads (100%) rename {ada2 => ada.2}/types-builtins.adb (100%) rename {ada2 => ada.2}/types-builtins.ads (100%) rename {ada2 => ada.2}/types-functions.adb (100%) rename {ada2 => ada.2}/types-functions.ads (100%) rename {ada2 => ada.2}/types-lists.adb (100%) rename {ada2 => ada.2}/types-lists.ads (100%) rename {ada2 => ada.2}/types-mal.adb (100%) rename {ada2 => ada.2}/types-mal.ads (100%) rename {ada2 => ada.2}/types-maps.adb (100%) rename {ada2 => ada.2}/types-maps.ads (100%) rename {ada2 => ada.2}/types-symbols-names.ads (100%) rename {ada2 => ada.2}/types-symbols.adb (100%) rename {ada2 => ada.2}/types-symbols.ads (100%) rename {ada2 => ada.2}/types.ads (100%) diff --git a/Makefile b/Makefile index d80bd7d2c6..08607e6ed9 100644 --- a/Makefile +++ b/Makefile @@ -81,7 +81,7 @@ DOCKERIZE = # Implementation specific settings # -IMPLS = ada ada2 awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ +IMPLS = ada ada.2 awk bash basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ elisp elixir elm erlang es6 factor fantom forth fsharp go groovy gnu-smalltalk \ guile haskell haxe hy io java js julia kotlin livescript logo lua make mal \ matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp plpgsql \ @@ -173,7 +173,7 @@ scheme_STEP_TO_PROG_foment = scheme/$($(1)).scm # Map of step (e.g. "step8") to executable file for that step ada_STEP_TO_PROG = ada/$($(1)) -ada2_STEP_TO_PROG = ada2/$($(1)) +ada.2_STEP_TO_PROG = ada.2/$($(1)) awk_STEP_TO_PROG = awk/$($(1)).awk bash_STEP_TO_PROG = bash/$($(1)).sh basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) diff --git a/ada2/Makefile b/ada.2/Makefile similarity index 100% rename from ada2/Makefile rename to ada.2/Makefile diff --git a/ada2/README b/ada.2/README similarity index 100% rename from ada2/README rename to ada.2/README diff --git a/ada2/core.adb b/ada.2/core.adb similarity index 100% rename from ada2/core.adb rename to ada.2/core.adb diff --git a/ada2/core.ads b/ada.2/core.ads similarity index 100% rename from ada2/core.ads rename to ada.2/core.ads diff --git a/ada2/envs.adb b/ada.2/envs.adb similarity index 100% rename from ada2/envs.adb rename to ada.2/envs.adb diff --git a/ada2/envs.ads b/ada.2/envs.ads similarity index 100% rename from ada2/envs.ads rename to ada.2/envs.ads diff --git a/ada2/eval_cb.ads b/ada.2/eval_cb.ads similarity index 100% rename from ada2/eval_cb.ads rename to ada.2/eval_cb.ads diff --git a/ada2/printer.adb b/ada.2/printer.adb similarity index 100% rename from ada2/printer.adb rename to ada.2/printer.adb diff --git a/ada2/printer.ads b/ada.2/printer.ads similarity index 100% rename from ada2/printer.ads rename to ada.2/printer.ads diff --git a/ada2/reader.adb b/ada.2/reader.adb similarity index 100% rename from ada2/reader.adb rename to ada.2/reader.adb diff --git a/ada2/reader.ads b/ada.2/reader.ads similarity index 100% rename from ada2/reader.ads rename to ada.2/reader.ads diff --git a/ada2/readline.adb b/ada.2/readline.adb similarity index 100% rename from ada2/readline.adb rename to ada.2/readline.adb diff --git a/ada2/readline.ads b/ada.2/readline.ads similarity index 100% rename from ada2/readline.ads rename to ada.2/readline.ads diff --git a/ada2/run b/ada.2/run similarity index 100% rename from ada2/run rename to ada.2/run diff --git a/ada2/step0_repl.adb b/ada.2/step0_repl.adb similarity index 100% rename from ada2/step0_repl.adb rename to ada.2/step0_repl.adb diff --git a/ada2/step1_read_print.adb b/ada.2/step1_read_print.adb similarity index 100% rename from ada2/step1_read_print.adb rename to ada.2/step1_read_print.adb diff --git a/ada2/step2_eval.adb b/ada.2/step2_eval.adb similarity index 100% rename from ada2/step2_eval.adb rename to ada.2/step2_eval.adb diff --git a/ada2/step3_env.adb b/ada.2/step3_env.adb similarity index 100% rename from ada2/step3_env.adb rename to ada.2/step3_env.adb diff --git a/ada2/step4_if_fn_do.adb b/ada.2/step4_if_fn_do.adb similarity index 100% rename from ada2/step4_if_fn_do.adb rename to ada.2/step4_if_fn_do.adb diff --git a/ada2/step5_tco.adb b/ada.2/step5_tco.adb similarity index 100% rename from ada2/step5_tco.adb rename to ada.2/step5_tco.adb diff --git a/ada2/step6_file.adb b/ada.2/step6_file.adb similarity index 100% rename from ada2/step6_file.adb rename to ada.2/step6_file.adb diff --git a/ada2/step7_quote.adb b/ada.2/step7_quote.adb similarity index 100% rename from ada2/step7_quote.adb rename to ada.2/step7_quote.adb diff --git a/ada2/step8_macros.adb b/ada.2/step8_macros.adb similarity index 100% rename from ada2/step8_macros.adb rename to ada.2/step8_macros.adb diff --git a/ada2/step9_try.adb b/ada.2/step9_try.adb similarity index 100% rename from ada2/step9_try.adb rename to ada.2/step9_try.adb diff --git a/ada2/stepa_mal.adb b/ada.2/stepa_mal.adb similarity index 100% rename from ada2/stepa_mal.adb rename to ada.2/stepa_mal.adb diff --git a/ada2/types-atoms.adb b/ada.2/types-atoms.adb similarity index 100% rename from ada2/types-atoms.adb rename to ada.2/types-atoms.adb diff --git a/ada2/types-atoms.ads b/ada.2/types-atoms.ads similarity index 100% rename from ada2/types-atoms.ads rename to ada.2/types-atoms.ads diff --git a/ada2/types-builtins.adb b/ada.2/types-builtins.adb similarity index 100% rename from ada2/types-builtins.adb rename to ada.2/types-builtins.adb diff --git a/ada2/types-builtins.ads b/ada.2/types-builtins.ads similarity index 100% rename from ada2/types-builtins.ads rename to ada.2/types-builtins.ads diff --git a/ada2/types-functions.adb b/ada.2/types-functions.adb similarity index 100% rename from ada2/types-functions.adb rename to ada.2/types-functions.adb diff --git a/ada2/types-functions.ads b/ada.2/types-functions.ads similarity index 100% rename from ada2/types-functions.ads rename to ada.2/types-functions.ads diff --git a/ada2/types-lists.adb b/ada.2/types-lists.adb similarity index 100% rename from ada2/types-lists.adb rename to ada.2/types-lists.adb diff --git a/ada2/types-lists.ads b/ada.2/types-lists.ads similarity index 100% rename from ada2/types-lists.ads rename to ada.2/types-lists.ads diff --git a/ada2/types-mal.adb b/ada.2/types-mal.adb similarity index 100% rename from ada2/types-mal.adb rename to ada.2/types-mal.adb diff --git a/ada2/types-mal.ads b/ada.2/types-mal.ads similarity index 100% rename from ada2/types-mal.ads rename to ada.2/types-mal.ads diff --git a/ada2/types-maps.adb b/ada.2/types-maps.adb similarity index 100% rename from ada2/types-maps.adb rename to ada.2/types-maps.adb diff --git a/ada2/types-maps.ads b/ada.2/types-maps.ads similarity index 100% rename from ada2/types-maps.ads rename to ada.2/types-maps.ads diff --git a/ada2/types-symbols-names.ads b/ada.2/types-symbols-names.ads similarity index 100% rename from ada2/types-symbols-names.ads rename to ada.2/types-symbols-names.ads diff --git a/ada2/types-symbols.adb b/ada.2/types-symbols.adb similarity index 100% rename from ada2/types-symbols.adb rename to ada.2/types-symbols.adb diff --git a/ada2/types-symbols.ads b/ada.2/types-symbols.ads similarity index 100% rename from ada2/types-symbols.ads rename to ada.2/types-symbols.ads diff --git a/ada2/types.ads b/ada.2/types.ads similarity index 100% rename from ada2/types.ads rename to ada.2/types.ads From 0b4ab1a5262efc26d22f7df33fba41917c68ad03 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 10 Mar 2019 01:14:23 +0100 Subject: [PATCH 0493/1998] ada.2: add to .travis.yml --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 77a921a4da..aba4459fe3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,6 +6,7 @@ sudo: required matrix: include: - {env: IMPL=ada, services: [docker]} + - {env: IMPL=ada.2, services: [docker]} - {env: IMPL=awk, services: [docker]} - {env: IMPL=bash, services: [docker]} - {env: IMPL=basic basic_MODE=cbm, services: [docker]} From 73b7847ef6cb6db645a6504aa5ecf013c1cfee6b Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 13 Mar 2019 17:31:57 -0500 Subject: [PATCH 0494/1998] rexx, ruby: remove extraneous mal files. --- rexx/t.mal | 1 - ruby/suggest.mal | 7 ------- 2 files changed, 8 deletions(-) delete mode 100644 rexx/t.mal delete mode 100644 ruby/suggest.mal diff --git a/rexx/t.mal b/rexx/t.mal deleted file mode 100644 index 0c27e43547..0000000000 --- a/rexx/t.mal +++ /dev/null @@ -1 +0,0 @@ -(prn (+ 4 5)) diff --git a/ruby/suggest.mal b/ruby/suggest.mal deleted file mode 100644 index 685a5d1db2..0000000000 --- a/ruby/suggest.mal +++ /dev/null @@ -1,7 +0,0 @@ -(def! read-args (fn* [args] - (let* [arg (readline "arg> ")] - (if (or (nil? arg) (empty? arg)) - args - (read-args (conj args arg)))))) - -(prn "The args you entered are:" (read-args [])) From 00c3a3c33da116e5622bd596b002de6c110af3fc Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 17 Mar 2019 11:24:03 +0100 Subject: [PATCH 0495/1998] ada.2: spring cleaning before final pull request. Two changes require approval. * The 'do' special becomes a built-in function similar to first. This small change reduces the complexity of eval. The last evaluation cannot benefit from TCO, but the performance change seems invisible. * read/eval/print acts on each item found in the input string, as if they were enclosed with (do ..). The guide does not specify what should happen to text following the first AST, and this change actually simplifies some things (like dealing with zero AST). The read-string built-in function only returns the first AST, as changing this would be much more intrusive. Other changes seem straightforward. Global: * Ada 2020 target assignments (like +=, but more general). * Use Constant_Indexing aspect for sequences, so that they can be indexed in source code like native arrays. * consistency renamings. 'fn' does not include built-in functions, 'function' does. 'list' does not include vectors, 'sequence' does. Move error handling to a separate package. * This simplifies code everywhere else. * Uncaught expressions now report a stack trace. Types: * Count allocations and deallocations, check that counts match. * Share more code between functions and macros. Core: * Replace the Core.Ns function returning an array with a procedure (The intermediate object was preventing the reference counting code from deallocating some unused objects). * Implement Prn with Pr_Str. Printer: * Change the profile so that the caller spares some allocations. Reader: * Share a single buffer of mal values between all recursions. This significantly reduces the stack footprint. Steps: * Fix implementation name (ada.2) in the startup script. * Let environment variables trigger debugging information. --- ada.2/Makefile | 7 +- ada.2/README | 60 ++- ada.2/core.adb | 484 +++++++++--------- ada.2/core.ads | 21 +- ada.2/envs.adb | 247 +++++---- ada.2/envs.ads | 45 +- ada.2/err.adb | 53 ++ ada.2/err.ads | 40 ++ ada.2/printer.adb | 77 +-- ada.2/printer.ads | 12 +- ada.2/reader.adb | 196 +++---- ada.2/reader.ads | 8 +- ada.2/step1_read_print.adb | 33 +- ada.2/step2_eval.adb | 79 +-- ada.2/step3_env.adb | 115 +++-- ada.2/step4_if_fn_do.adb | 198 +++---- ada.2/step5_tco.adb | 206 ++++---- ada.2/step6_file.adb | 218 ++++---- ada.2/step7_quote.adb | 284 +++++----- ada.2/step8_macros.adb | 345 ++++++------- ada.2/step9_try.adb | 397 +++++++------- ada.2/stepa_mal.adb | 404 +++++++-------- ada.2/types-atoms.adb | 62 +-- ada.2/types-atoms.ads | 3 + ada.2/types-builtins.adb | 24 +- ada.2/types-builtins.ads | 2 + ada.2/{types-functions.adb => types-fns.adb} | 90 ++-- ada.2/{types-functions.ads => types-fns.ads} | 11 +- ada.2/types-lists.adb | 313 ----------- ada.2/types-mal.adb | 11 +- ada.2/types-mal.ads | 14 +- ada.2/types-maps.adb | 211 ++++---- ada.2/types-maps.ads | 3 + ada.2/types-sequences.adb | 335 ++++++++++++ .../{types-lists.ads => types-sequences.ads} | 21 +- ada.2/types-symbols-names.ads | 1 - ada.2/types-symbols.adb | 36 +- ada.2/types-symbols.ads | 6 +- ada.2/types.ads | 14 +- 39 files changed, 2402 insertions(+), 2284 deletions(-) create mode 100644 ada.2/err.adb create mode 100644 ada.2/err.ads rename ada.2/{types-functions.adb => types-fns.adb} (57%) rename ada.2/{types-functions.ads => types-fns.ads} (86%) delete mode 100644 ada.2/types-lists.adb create mode 100644 ada.2/types-sequences.adb rename ada.2/{types-lists.ads => types-sequences.ads} (85%) diff --git a/ada.2/Makefile b/ada.2/Makefile index 4bbee5d0c9..342e56a917 100644 --- a/ada.2/Makefile +++ b/ada.2/Makefile @@ -10,7 +10,7 @@ else endif # Compiler arguments. -CARGS = -gnat2012 $(OPT) $(ADAFLAGS) +CARGS = -gnat2020 $(OPT) $(ADAFLAGS) # Linker arguments. LARGS = $(LDFLAGS) -lreadline @@ -36,14 +36,15 @@ clean: # the rest when it must be executed. TYPES := \ envs.ads envs.adb \ + err.ads err.adb \ eval_cb.ads \ printer.ads printer.adb \ reader.ads reader.adb \ readline.ads \ types-atoms.ads types-atoms.adb \ types-builtins.ads types-builtins.adb \ - types-functions.ads types-functions.adb \ - types-lists.ads types-lists.adb \ + types-fns.ads types-fns.adb \ + types-sequences.ads types-sequences.adb \ types-mal.ads types-mal.adb \ types-maps.ads types-maps.adb \ types-symbols-names.ads \ diff --git a/ada.2/README b/ada.2/README index c2d8e560b7..21a1292423 100644 --- a/ada.2/README +++ b/ada.2/README @@ -1,21 +1,22 @@ Comparison with the first Ada implementation. +-- The first implementation was deliberately compatible with all Ada -compilers, while this one illustrates various Ada 2012 features: +compilers, while this one illustrates various Ada 2020 features: assertions, preconditions, invariants, initial assignment for limited -types, limited imports... +types, limited imports, indexing aspects... The variant MAL type is implemented with a discriminant instead of object-style dispatching. This allows more static and dynamic checks, but also two crucial performance improvements: -* Nil, boolean, integers and built-in functions are passed by value - without dynamic allocation. +* Nil, boolean, integers and pointers to built-in functions are passed + by value without dynamic allocation. * Lists are implemented as C-style arrays, and most of them can be allocated on the stack. Once each component has an explicit interface, various optimizations have been added: unique allocation of symbols, stack-style allocation -of environments in the current execution path, reuse of existing +of environments in the current execution path, reuse of allocated memory when the reference count reaches 1... The eventual performances compete with C-style languages, allthough @@ -23,17 +24,21 @@ all user input is checked (implicit language-defined checks like array bounds and discriminant consistency are only enabled during tests). There are also similarities with the first implementation. For -example, both rely on user-defined finalization to handle recursive -structures without garbage collecting. Also, most pointer types are -wrapped into a finalized type counting references. +example, both rely on user-defined finalization to count references in +recursive structures instead of a posteriori garbage collection. -Some remarks if anyone works on this. +Notes for contributors that do not fit in a specific package. +-- -* The default value for such wrapped pointers is invalid, new - variables must be assigned immediately. This is usually enforced by - a hidden discriminant, but this would prevent the type to become a - field inside Types.Mal.T. So we usse a private invariant as a a - fallback. +* All packages can call Eval back via a reference in the Eval_Cb + package, set during startup. I am interested in a prettier solution + ensuring a valid value during elaboration. + Note that generic packages cannot export access values. + +* All wrapped pointers are non null, new variables must be assigned + immediately. This is usually enforced by a hidden discriminant, but + here we want the type to become a field inside Types.Mal.T. So the + check happens at run time with a private invariant. * The finalize procedure may be called twice, so it does nothing when the reference count is zero, meaning that we are reaching Finalize @@ -43,6 +48,27 @@ Some remarks if anyone works on this. automatically) must be built before any exception is raised by user code (for example the 'map' built-in function may run user code). -Known bugs: the third step of the perf^ada2 target fails during the -final storage deallocation when the executable is built with -gnatp. I -have failed to understand why so far. +* Each module encapsulating dynamic allocation counts allocations and + deallocations. With debugging options, a failure is reported if + - too many deallocation happen (via a numeric range check) + - all storage is not freed (via a dedicated call from the step file) + +Known bugs +-- + +The third step of the perf^ada2 target fails during the final storage +deallocation when the executable is built with -gnatp. I have failed +to understand why so far. + +Debugging +-- + +Uncaught exceptions are reported with an execution trace (excluding +TCO cycles). This has become possible in step9, but has been +backported to former steps as this is really handy for debugging. + +Some environment variables increase verbosity. +# dbg_reader= ./stepAmal trace reader recursion +# dbgeval= ./stepAmal eval recursion (or TCO) +# dbgenv0= ./stepAmal eval recursion and environments contents +# dbgenv1= ./stepAmal eval recursion and environment internals diff --git a/ada.2/core.adb b/ada.2/core.adb index c4db4ef609..00c9e5aa5e 100644 --- a/ada.2/core.adb +++ b/ada.2/core.adb @@ -4,12 +4,13 @@ with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; with Envs; +with Err; with Eval_Cb; with Types.Atoms; with Types.Builtins; -with Types.Functions; -with Types.Lists; +with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; with Printer; with Reader; @@ -22,109 +23,106 @@ package body Core is -- Used by time_ms. Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; - -- In the following helpers, "name" is the one reported by error - -- messages. - generic Kind : in Kind_Type; - Name : in String; function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T; - function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with Name & ": expects 1 argument" - else - (Kind_Boolean, Args (Args'First).Kind = Kind)); + function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind = Kind); + end Generic_Kind_Test; generic with function Ada_Operator (Left, Right : in Integer) return Integer; - Name : in String; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 then - raise Argument_Error with Name & ": expects 2 arguments" - elsif (for some A of Args => A.Kind /= Kind_Number) then - raise Argument_Error with Name & ": expects numbers" - else - (Kind_Number, Ada_Operator (Args (Args'First).Number, - Args (Args'Last).Number))); + function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'First).Kind = Kind_Number, + "parameter 1 must be a number"); + Err.Check (Args (Args'Last).Kind = Kind_Number, + "parameter 2 must be a number"); + return (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + end Generic_Mal_Operator; + generic with function Ada_Operator (Left, Right : in Integer) return Boolean; - Name : in String; function Generic_Comparison (Args : in Mal.T_Array) return Mal.T; - function Generic_Comparison (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 then - raise Argument_Error with Name & ": expects 2 arguments" - elsif (for some A of Args => A.Kind /= Kind_Number) then - raise Argument_Error with Name & ": expects numbers" - else - (Kind_Boolean, Ada_Operator (Args (Args'First).Number, - Args (Args'Last).Number))); - - function Addition is new Generic_Mal_Operator ("+", "+"); + function Generic_Comparison (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'First).Kind = Kind_Number, + "parameter 1 must be a number"); + Err.Check (Args (Args'Last).Kind = Kind_Number, + "parameter 2 must be a number"); + return (Kind_Boolean, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + end Generic_Comparison; + + function Addition is new Generic_Mal_Operator ("+"); function Apply (Args : in Mal.T_Array) return Mal.T; - function Division is new Generic_Mal_Operator ("/", "/"); + function Division is new Generic_Mal_Operator ("/"); function Equals (Args : in Mal.T_Array) return Mal.T; function Eval (Args : in Mal.T_Array) return Mal.T; - function Greater_Equal is new Generic_Comparison (">=", ">="); - function Greater_Than is new Generic_Comparison (">", ">"); - function Is_Atom is new Generic_Kind_Test (Kind_Atom, "atom?"); + function Greater_Equal is new Generic_Comparison (">="); + function Greater_Than is new Generic_Comparison (">"); + function Is_Atom is new Generic_Kind_Test (Kind_Atom); function Is_False (Args : in Mal.T_Array) return Mal.T; function Is_Function (Args : in Mal.T_Array) return Mal.T; - function Is_Keyword is new Generic_Kind_Test (Kind_Keyword, "keyword?"); - function Is_List is new Generic_Kind_Test (Kind_List, "list?"); - function Is_Macro is new Generic_Kind_Test (Kind_Macro, "macro?"); - function Is_Map is new Generic_Kind_Test (Kind_Map, "map?"); - function Is_Nil is new Generic_Kind_Test (Kind_Nil, "nil?"); - function Is_Number is new Generic_Kind_Test (Kind_Number, "number?"); + function Is_Keyword is new Generic_Kind_Test (Kind_Keyword); + function Is_List is new Generic_Kind_Test (Kind_List); + function Is_Macro is new Generic_Kind_Test (Kind_Macro); + function Is_Map is new Generic_Kind_Test (Kind_Map); + function Is_Nil is new Generic_Kind_Test (Kind_Nil); + function Is_Number is new Generic_Kind_Test (Kind_Number); function Is_Sequential (Args : in Mal.T_Array) return Mal.T; - function Is_String is new Generic_Kind_Test (Kind_String, "string?"); - function Is_Symbol is new Generic_Kind_Test (Kind_Symbol, "symbol?"); + function Is_String is new Generic_Kind_Test (Kind_String); + function Is_Symbol is new Generic_Kind_Test (Kind_Symbol); function Is_True (Args : in Mal.T_Array) return Mal.T; - function Is_Vector is new Generic_Kind_Test (Kind_Vector, "vector?"); + function Is_Vector is new Generic_Kind_Test (Kind_Vector); function Keyword (Args : in Mal.T_Array) return Mal.T; - function Less_Equal is new Generic_Comparison ("<=", "<="); - function Less_Than is new Generic_Comparison ("<", "<"); + function Less_Equal is new Generic_Comparison ("<="); + function Less_Than is new Generic_Comparison ("<"); + function Mal_Do (Args : in Mal.T_Array) return Mal.T; function Meta (Args : in Mal.T_Array) return Mal.T; function Pr_Str (Args : in Mal.T_Array) return Mal.T; function Println (Args : in Mal.T_Array) return Mal.T; function Prn (Args : in Mal.T_Array) return Mal.T; - function Product is new Generic_Mal_Operator ("*", "*"); + function Product is new Generic_Mal_Operator ("*"); function Read_String (Args : in Mal.T_Array) return Mal.T; function Readline (Args : in Mal.T_Array) return Mal.T; function Seq (Args : in Mal.T_Array) return Mal.T; function Slurp (Args : in Mal.T_Array) return Mal.T; function Str (Args : in Mal.T_Array) return Mal.T; - function Subtraction is new Generic_Mal_Operator ("-", "-"); + function Subtraction is new Generic_Mal_Operator ("-"); function Symbol (Args : in Mal.T_Array) return Mal.T; - function Throw (Args : in Mal.T_Array) return Mal.T; function Time_Ms (Args : in Mal.T_Array) return Mal.T; function With_Meta (Args : in Mal.T_Array) return Mal.T; ---------------------------------------------------------------------- function Apply (Args : in Mal.T_Array) return Mal.T is - use type Lists.Ptr; begin - if Args'Length < 2 then - raise Argument_Error with "apply: expects at least 2 arguments"; - elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "apply: last arg must be a list or vector"; - end if; + Err.Check (2 <= Args'Length, "expected at least 2 parameters"); + Err.Check (Args (Args'Last).Kind in Kind_Sequence, + "last parameter must be a sequence"); declare + use type Sequences.Ptr; F : Mal.T renames Args (Args'First); A : constant Mal.T_Array - := Args (Args'First + 1 .. Args'Last - 1) & Args (Args'Last).List; + := Args (Args'First + 1 .. Args'Last - 1) + & Args (Args'Last).Sequence; begin case F.Kind is when Kind_Builtin => return F.Builtin.all (A); when Kind_Builtin_With_Meta => return F.Builtin_With_Meta.Builtin.all (A); - when Kind_Function => + when Kind_Fn => return F.Fn.Apply (A); when others => - raise Argument_Error - with "apply: cannot call " & Printer.Img (F); + Err.Raise_With ("parameter 1 must be a function"); end case; end; end Apply; @@ -132,146 +130,155 @@ package body Core is function Equals (Args : in Mal.T_Array) return Mal.T is use type Mal.T; begin - if Args'Length /= 2 then - raise Argument_Error with "=: expects 2 arguments"; - else - return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); - end if; + Err.Check (Args'Length = 2, "expected 2 parameters"); + return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); end Equals; - function Eval (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "eval: expects 1 argument" - else - Eval_Cb.Cb.all (Ast => Args (Args'First), - Env => Envs.Repl)); - - function Is_False (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "false?: expects 1 argument" - else - (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean - and then not Args (Args'First).Ada_Boolean)); - - function Is_Function (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "count: expects 1 argument" - else - (Kind_Boolean, Args (Args'First).Kind in - Kind_Function | Kind_Builtin | Kind_Builtin_With_Meta)); - - function Is_Sequential (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "sequential?: expects 1 argument" - else - (Kind_Boolean, Args (Args'First).Kind in Kind_List | Kind_Vector)); - - function Is_True (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "true?: expects 1 argument" - else - (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean - and then Args (Args'First).Ada_Boolean)); - - function Keyword (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "keyword: expects 1 argument" - elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then - raise Argument_Error with "keyword: expects a keyword or a string" - else - (Kind_Keyword, Args (Args'First).S)); + function Eval (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval_Cb.Cb.all (Ast => Args (Args'First), + Env => Envs.Repl); + end Eval; + + function Is_False (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then not Args (Args'First).Ada_Boolean); + end Is_False; + + function Is_Function (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind in Kind_Function); + end Is_Function; + + function Is_Sequential (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind in Kind_Sequence); + end Is_Sequential; + + function Is_True (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then Args (Args'First).Ada_Boolean); + end Is_True; + + function Keyword (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_String, "expected a string"); + return (Kind_Keyword, Args (Args'First).S); + end Keyword; + + function Mal_Do (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (0 < Args'Length, "expected at least 1 parameter"); + return Args (Args'Last); + end Mal_Do; function Meta (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 1 then - raise Argument_Error with "meta: expects 1 argument"; - end if; + Err.Check (Args'Length = 1, "expected 1 parameter"); declare A1 : Mal.T renames Args (Args'First); begin case A1.Kind is - when Kind_List | Kind_Vector => - return A1.List.Meta; + when Kind_Sequence => + return A1.Sequence.Meta; when Kind_Map => return A1.Map.Meta; - when Kind_Function => + when Kind_Fn => return A1.Fn.Meta; when Kind_Builtin_With_Meta => return A1.Builtin_With_Meta.Meta; when Kind_Builtin => return Mal.Nil; when others => - raise Argument_Error - with "meta: expects a list, vector, map or function"; + Err.Raise_With ("expected a function, map or sequence"); end case; end; end Meta; - function Ns return Binding_List - is ((Symbols.Constructor ("+"), Addition'Access), - (Symbols.Constructor ("apply"), Apply'Access), - (Symbols.Constructor ("assoc"), Maps.Assoc'Access), - (Symbols.Constructor ("atom"), Atoms.Atom'Access), - (Symbols.Constructor ("concat"), Lists.Concat'Access), - (Symbols.Constructor ("conj"), Lists.Conj'Access), - (Symbols.Constructor ("cons"), Lists.Cons'Access), - (Symbols.Constructor ("contains?"), Maps.Contains'Access), - (Symbols.Constructor ("count"), Lists.Count'Access), - (Symbols.Names.Deref, Atoms.Deref'Access), - (Symbols.Constructor ("dissoc"), Maps.Dissoc'Access), - (Symbols.Constructor ("/"), Division'Access), - (Symbols.Constructor ("="), Equals'Access), - (Symbols.Constructor ("eval"), Eval'Access), - (Symbols.Constructor ("first"), Lists.First'Access), - (Symbols.Constructor ("get"), Maps.Get'Access), - (Symbols.Constructor (">="), Greater_Equal'Access), - (Symbols.Constructor (">"), Greater_Than'Access), - (Symbols.Constructor ("hash-map"), Maps.Hash_Map'Access), - (Symbols.Constructor ("atom?"), Is_Atom'Access), - (Symbols.Constructor ("empty?"), Lists.Is_Empty'Access), - (Symbols.Constructor ("false?"), Is_False'Access), - (Symbols.Constructor ("fn?"), Is_Function'Access), - (Symbols.Constructor ("keyword?"), Is_Keyword'Access), - (Symbols.Constructor ("list?"), Is_List'Access), - (Symbols.Constructor ("macro?"), Is_Macro'Access), - (Symbols.Constructor ("map?"), Is_Map'Access), - (Symbols.Constructor ("nil?"), Is_Nil'Access), - (Symbols.Constructor ("number?"), Is_Number'Access), - (Symbols.Constructor ("sequential?"), Is_Sequential'Access), - (Symbols.Constructor ("string?"), Is_String'Access), - (Symbols.Constructor ("symbol?"), Is_Symbol'Access), - (Symbols.Constructor ("true?"), Is_True'Access), - (Symbols.Constructor ("vector?"), Is_Vector'Access), - (Symbols.Constructor ("keys"), Maps.Keys'Access), - (Symbols.Constructor ("keyword"), Keyword'Access), - (Symbols.Constructor ("<="), Less_Equal'Access), - (Symbols.Constructor ("<"), Less_Than'Access), - (Symbols.Constructor ("list"), Lists.List'Access), - (Symbols.Constructor ("map"), Lists.Map'Access), - (Symbols.Constructor ("meta"), Meta'Access), - (Symbols.Constructor ("nth"), Lists.Nth'Access), - (Symbols.Constructor ("pr-str"), Pr_Str'Access), - (Symbols.Constructor ("println"), Println'Access), - (Symbols.Constructor ("prn"), Prn'Access), - (Symbols.Constructor ("*"), Product'Access), - (Symbols.Constructor ("read-string"), Read_String'Access), - (Symbols.Constructor ("readline"), Readline'Access), - (Symbols.Constructor ("reset!"), Atoms.Reset'Access), - (Symbols.Constructor ("rest"), Lists.Rest'Access), - (Symbols.Constructor ("seq"), Seq'Access), - (Symbols.Constructor ("slurp"), Slurp'Access), - (Symbols.Constructor ("str"), Str'Access), - (Symbols.Constructor ("-"), Subtraction'Access), - (Symbols.Constructor ("swap!"), Atoms.Swap'Access), - (Symbols.Constructor ("symbol"), Symbol'Access), - (Symbols.Constructor ("throw"), Throw'Access), - (Symbols.Constructor ("time-ms"), Time_Ms'Access), - (Symbols.Constructor ("vals"), Maps.Vals'Access), - (Symbols.Constructor ("vector"), Lists.Vector'Access), - (Symbols.Names.With_Meta, With_Meta'Access)); + procedure NS_Add_To_Repl is + procedure P (S : in Symbols.Ptr; + B : in Mal.Builtin_Ptr) with Inline; + procedure P (S : in Symbols.Ptr; + B : in Mal.Builtin_Ptr) + is + begin + Envs.Repl.Set (S, (Kind_Builtin, B)); + end P; + begin + P (Symbols.Constructor ("+"), Addition'Access); + P (Symbols.Constructor ("apply"), Apply'Access); + P (Symbols.Constructor ("assoc"), Maps.Assoc'Access); + P (Symbols.Constructor ("atom"), Atoms.Atom'Access); + P (Symbols.Constructor ("concat"), Sequences.Concat'Access); + P (Symbols.Constructor ("conj"), Sequences.Conj'Access); + P (Symbols.Constructor ("cons"), Sequences.Cons'Access); + P (Symbols.Constructor ("contains?"), Maps.Contains'Access); + P (Symbols.Constructor ("count"), Sequences.Count'Access); + P (Symbols.Names.Deref, Atoms.Deref'Access); + P (Symbols.Constructor ("dissoc"), Maps.Dissoc'Access); + P (Symbols.Constructor ("/"), Division'Access); + P (Symbols.Constructor ("do"), Mal_Do'Access); + P (Symbols.Constructor ("="), Equals'Access); + P (Symbols.Constructor ("eval"), Eval'Access); + P (Symbols.Constructor ("first"), Sequences.First'Access); + P (Symbols.Constructor ("get"), Maps.Get'Access); + P (Symbols.Constructor (">="), Greater_Equal'Access); + P (Symbols.Constructor (">"), Greater_Than'Access); + P (Symbols.Constructor ("hash-map"), Maps.Hash_Map'Access); + P (Symbols.Constructor ("atom?"), Is_Atom'Access); + P (Symbols.Constructor ("empty?"), Sequences.Is_Empty'Access); + P (Symbols.Constructor ("false?"), Is_False'Access); + P (Symbols.Constructor ("fn?"), Is_Function'Access); + P (Symbols.Constructor ("keyword?"), Is_Keyword'Access); + P (Symbols.Constructor ("list?"), Is_List'Access); + P (Symbols.Constructor ("macro?"), Is_Macro'Access); + P (Symbols.Constructor ("map?"), Is_Map'Access); + P (Symbols.Constructor ("nil?"), Is_Nil'Access); + P (Symbols.Constructor ("number?"), Is_Number'Access); + P (Symbols.Constructor ("sequential?"), Is_Sequential'Access); + P (Symbols.Constructor ("string?"), Is_String'Access); + P (Symbols.Constructor ("symbol?"), Is_Symbol'Access); + P (Symbols.Constructor ("true?"), Is_True'Access); + P (Symbols.Constructor ("vector?"), Is_Vector'Access); + P (Symbols.Constructor ("keys"), Maps.Keys'Access); + P (Symbols.Constructor ("keyword"), Keyword'Access); + P (Symbols.Constructor ("<="), Less_Equal'Access); + P (Symbols.Constructor ("<"), Less_Than'Access); + P (Symbols.Constructor ("list"), Sequences.List'Access); + P (Symbols.Constructor ("map"), Sequences.Map'Access); + P (Symbols.Constructor ("meta"), Meta'Access); + P (Symbols.Constructor ("nth"), Sequences.Nth'Access); + P (Symbols.Constructor ("pr-str"), Pr_Str'Access); + P (Symbols.Constructor ("println"), Println'Access); + P (Symbols.Constructor ("prn"), Prn'Access); + P (Symbols.Constructor ("*"), Product'Access); + P (Symbols.Constructor ("read-string"), Read_String'Access); + P (Symbols.Constructor ("readline"), Readline'Access); + P (Symbols.Constructor ("reset!"), Atoms.Reset'Access); + P (Symbols.Constructor ("rest"), Sequences.Rest'Access); + P (Symbols.Constructor ("seq"), Seq'Access); + P (Symbols.Constructor ("slurp"), Slurp'Access); + P (Symbols.Constructor ("str"), Str'Access); + P (Symbols.Constructor ("-"), Subtraction'Access); + P (Symbols.Constructor ("swap!"), Atoms.Swap'Access); + P (Symbols.Constructor ("symbol"), Symbol'Access); + P (Symbols.Constructor ("throw"), Err.Throw'Access); + P (Symbols.Constructor ("time-ms"), Time_Ms'Access); + P (Symbols.Constructor ("vals"), Maps.Vals'Access); + P (Symbols.Constructor ("vector"), Sequences.Vector'Access); + P (Symbols.Names.With_Meta, With_Meta'Access); + end NS_Add_To_Repl; function Pr_Str (Args : in Mal.T_Array) return Mal.T is - R : ASU.Unbounded_String := ASU.Null_Unbounded_String; + R : ASU.Unbounded_String; Started : Boolean := False; begin for A of Args loop @@ -280,48 +287,37 @@ package body Core is else Started := True; end if; - ASU.Append (R, Printer.Pr_Str (A)); + Printer.Pr_Str (R, A); end loop; return (Kind_String, R); end Pr_Str; function Println (Args : in Mal.T_Array) return Mal.T is Started : Boolean := False; + Buffer : ASU.Unbounded_String; begin for A of Args loop if Started then - Ada.Text_IO.Put (' '); + ASU.Append (Buffer, ' '); else Started := True; end if; - Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (A, Readably => False)); + Printer.Pr_Str (Buffer, A, Readably => False); end loop; - Ada.Text_IO.New_Line; + Ada.Text_IO.Unbounded_IO.Put_Line (Buffer); return Mal.Nil; end Println; function Prn (Args : in Mal.T_Array) return Mal.T is - Started : Boolean := False; begin - for A of Args loop - if Started then - Ada.Text_IO.Put (' '); - else - Started := True; - end if; - Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (A)); - end loop; - Ada.Text_IO.New_Line; + Ada.Text_IO.Unbounded_IO.Put_Line (Pr_Str (Args).S); return Mal.Nil; end Prn; function Readline (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 1 then - raise Argument_Error with "readline: expects 1 argument"; - elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then - raise Argument_Error with "readline: expects a keyword or string"; - end if; + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_String, "expected a string"); Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S); if Ada.Text_IO.End_Of_File then return Mal.Nil; @@ -330,19 +326,22 @@ package body Core is end if; end Readline; - function Read_String (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "read-string: expects 1 argument" - elsif Args (Args'First).Kind /= Kind_String then - raise Argument_Error with "read-string: expects a string" - else - Reader.Read_Str (ASU.To_String (Args (Args'First).S))); + function Read_String (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_String, "expected a string"); + declare + R : constant Mal.T_Array + := Reader.Read_Str (ASU.To_String (Args (Args'First).S)); + begin + Err.Check (R'Length = 1, "parameter must contain 1 expression"); + return R (R'First); + end; + end Read_String; function Seq (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 1 then - raise Argument_Error with "seq: expects 1 argument"; - end if; + Err.Check (Args'Length = 1, "expected 1 parameter"); case Args (Args'First).Kind is when Kind_Nil => return Mal.Nil; @@ -357,17 +356,17 @@ package body Core is for I in R'Range loop R (I) := (Kind_String, ASU.Unbounded_Slice (A1, I, I)); end loop; - return Lists.List (R); + return Sequences.List (R); end; end if; - when Kind_List | Kind_Vector => - if Args (Args'First).List.Length = 0 then + when Kind_Sequence => + if Args (Args'First).Sequence.Length = 0 then return Mal.Nil; else - return (Kind_List, Args (Args'First).List); + return (Kind_List, Args (Args'First).Sequence); end if; when others => - raise Argument_Error with "seq: expects a string, list or vector"; + Err.Raise_With ("expected nil, a sequence or a string"); end case; end Seq; @@ -376,19 +375,15 @@ package body Core is File : File_Type; Buffer : ASU.Unbounded_String; begin - if Args'Length /= 1 then - raise Argument_Error with "slurp: expects 1 argument"; - elsif Args (Args'First).Kind /= Kind_String then - raise Argument_Error with "slurp: expects a string"; - else - Open (File, In_File, ASU.To_String (Args (Args'First).S)); - while not End_Of_File (File) loop - ASU.Append (Buffer, Get_Line (File)); - ASU.Append (Buffer, Ada.Characters.Latin_1.LF); - end loop; - Close (File); - return (Kind_String, Buffer); - end if; + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_String, "expected a string"); + Open (File, In_File, ASU.To_String (Args (Args'First).S)); + while not End_Of_File (File) loop + ASU.Append (Buffer, Get_Line (File)); + ASU.Append (Buffer, Ada.Characters.Latin_1.LF); + end loop; + Close (File); + return (Kind_String, Buffer); exception when others => Close (File); @@ -396,46 +391,33 @@ package body Core is end Slurp; function Str (Args : in Mal.T_Array) return Mal.T is - R : ASU.Unbounded_String := ASU.Null_Unbounded_String; + R : ASU.Unbounded_String; begin for A of Args loop - ASU.Append (R, Printer.Pr_Str (A, Readably => False)); + Printer.Pr_Str (R, A, Readably => False); end loop; return (Kind_String, R); end Str; - function Symbol (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "symbol: expects 1 argument" - else - (Kind_Symbol, - Symbols.Constructor (ASU.To_String (Args (Args'First).S)))); - - function Throw (Args : in Mal.T_Array) return Mal.T is + function Symbol (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 1 then - raise Argument_Error with "throw: expects 1 argument"; - end if; - Last_Exception := Args (Args'First); - raise Exception_Throwed; - return Mal.Nil; -- GNAT wants a return - end Throw; + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_String, "expected a string"); + return (Kind_Symbol, + Symbols.Constructor (ASU.To_String (Args (Args'First).S))); + end Symbol; function Time_Ms (Args : in Mal.T_Array) return Mal.T is use type Ada.Calendar.Time; begin - if 0 < Args'Length then - raise Argument_Error with "time: expects no argument"; - end if; + Err.Check (Args'Length = 0, "expected no parameter"); return (Kind_Number, Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); end Time_Ms; function With_Meta (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 2 then - raise Argument_Error with "with-meta: expects 2 arguments"; - end if; + Err.Check (Args'Length = 2, "expected 2 parameters"); declare A1 : Mal.T renames Args (Args'First); A2 : Mal.T renames Args (Args'Last); @@ -446,16 +428,16 @@ package body Core is when Kind_Builtin => return Builtins.With_Meta (A1.Builtin, A2); when Kind_List => - return (Kind_List, A1.List.With_Meta (A2)); + return (Kind_List, A1.Sequence.With_Meta (A2)); when Kind_Vector => - return (Kind_Vector, A1.List.With_Meta (A2)); + return (Kind_Vector, A1.Sequence.With_Meta (A2)); when Kind_Map => return A1.Map.With_Meta (A2); - when Kind_Function => + when Kind_Fn => return A1.Fn.With_Meta (A2); when others => - raise Argument_Error - with "with-meta: expects a list, vector, map or function"; + Err.Raise_With + ("parameter 1 must be a function, map or sequence"); end case; end; end With_Meta; diff --git a/ada.2/core.ads b/ada.2/core.ads index b276093cd0..faa8abb4d9 100644 --- a/ada.2/core.ads +++ b/ada.2/core.ads @@ -1,23 +1,6 @@ -with Types.Symbols; -with Types.Mal; - package Core with Elaborate_Body is - type Binding is record - Symbol : Types.Symbols.Ptr; - Builtin : Types.Mal.Builtin_Ptr; - end record; - - type Binding_List is array (Positive range <>) of Binding; - - function Ns return Binding_List; - -- A list of built-in symbols and functionse. - -- A constant would make sense, but - -- * implementing it in the private part - - Exception_Throwed : exception; - Last_Exception : Types.Mal.T := Types.Mal.Nil; - -- When the "throw" builtin is executed, it assigns its argument - -- to Last_Exception, then raises this Ada exception. + procedure NS_Add_To_Repl; + -- Add built-in functions to Envs.Repl. end Core; diff --git a/ada.2/envs.adb b/ada.2/envs.adb index cab3d403fc..6e51c74d83 100644 --- a/ada.2/envs.adb +++ b/ada.2/envs.adb @@ -1,8 +1,10 @@ with Ada.Containers.Hashed_Maps; --- with Ada.Text_IO.Unbounded_IO; +with Ada.Text_IO.Unbounded_IO; with Ada.Unchecked_Deallocation; --- with Printer; +with Err; +with Printer; +with Types.Sequences; with Types.Symbols.Names; package body Envs is @@ -65,99 +67,110 @@ package body Envs is -- compatible with the Repl constant. procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access); + Allocations : Natural := 0; + procedure Unreference (Reference : in out Heap_Access); procedure Set_Binds (M : in out HM.Map; Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array) - with Inline; - procedure Set_Binds_Macro (M : in out HM.Map; - Binds : in Symbols.Symbol_Array; - Exprs : in Lists.Ptr) - with Inline; - -- These two procedures are redundant, but sharing the code would - -- be ugly or inefficient. They are separated as inline procedures - -- in order to ease comparison, though. + Exprs : in Mal.T_Array); ---------------------------------------------------------------------- procedure Adjust (Object : in out Closure_Ptr) is begin if Object.Ref /= null then - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + Object.Ref.all.Refs := @ + 1; end if; end Adjust; + procedure Clear_And_Check_Allocations is + begin + pragma Assert (Top = 1); + pragma Assert (Stack (1).Refs = 1); + Stack (1).Data.Clear; + if Stack (1).Alias /= null then + pragma Assert (Stack (1).Alias.all.Refs = 0); + Allocations := Allocations - 1; + Free (Stack (1).Alias); + end if; + pragma Assert (Allocations = 0); + end Clear_And_Check_Allocations; + function Copy_Pointer (Env : in Ptr) return Ptr is begin - Stack (Env.Index).Refs := Stack (Env.Index).Refs + 1; + Stack (Env.Index).Refs := @ + 1; return (Ada.Finalization.Limited_Controlled with Env.Index); end Copy_Pointer; - -- procedure Dump_Stack (Long : in Boolean := False) is - -- use Ada.Text_IO; - -- use Ada.Text_IO.Unbounded_IO; - -- begin - -- for I in 1 .. Top loop - -- if Long then - -- Put ("Level"); - -- end if; - -- Put (I'Img); - -- if Long then - -- New_Line; - -- Put_Line (" refs=" & Stack (I).Refs'Img); - -- if Stack (I).Alias = null then - -- Put_Line (" no alias"); - -- else - -- Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img - -- & " refs"); - -- end if; - -- end if; - -- if Long then - -- Put (" outer="); - -- else - -- Put (" (->"); - -- end if; - -- if Stack (I).Outer_On_Stack then - -- Put (Stack (I).Outer_Index'Img); - -- elsif Stack (I).Outer_Ref.all.Outer = null then - -- if Long then - -- Put ("alias for "); - -- end if; - -- Put (Stack (I).Outer_Ref.all.Index'Img); - -- else - -- Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img); - -- end if; - -- if Long then - -- New_Line; - -- else - -- Put ("):"); - -- end if; - -- for P in Stack (I).Data.Iterate loop - -- if HM.Element (P).Kind /= Kind_Builtin then -- skip built-ins. - -- if Long then - -- Put (" "); - -- else - -- Put (' '); - -- end if; - -- Put (HM.Key (P).To_String); - -- Put (':'); - -- Put (Printer.Pr_Str (HM.Element (P))); - -- if Long then - -- New_Line; - -- end if; - -- end if; - -- end loop; - -- if Long then - -- Put (" ... built-ins"); - -- else - -- New_Line; - -- end if; - -- end loop; - -- if Long then - -- New_Line; - -- end if; - -- end Dump_Stack; + procedure Dump_Stack (Long : in Boolean) is + use Ada.Text_IO; + Builtins : Natural := 0; + begin + for I in 1 .. Top loop + if Long then + Put ("Level"); + end if; + Put (I'Img); + if Long then + New_Line; + Put_Line (" refs=" & Stack (I).Refs'Img); + if Stack (I).Alias = null then + Put_Line (" no alias"); + else + Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img + & " refs"); + end if; + end if; + if Long then + Put (" outer="); + else + Put (" (->"); + end if; + if Stack (I).Outer_On_Stack then + Put (Stack (I).Outer_Index'Img); + elsif Stack (I).Outer_Ref.all.Outer = null then + if Long then + Put ("alias for "); + end if; + Put (Stack (I).Outer_Ref.all.Index'Img); + else + Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img); + end if; + if Long then + New_Line; + else + Put ("):"); + end if; + for P in Stack (I).Data.Iterate loop + if HM.Element (P).Kind = Kind_Builtin then + Builtins := Builtins + 1; + else + if Long then + Put (" "); + else + Put (' '); + end if; + Put (HM.Key (P).To_String); + Put (':'); + Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P))); + if Long then + New_Line; + end if; + end if; + end loop; + if Long then + Put (" ..."); + Put (Integer'Image (Builtins)); + Put (" built-ins"); + else + New_Line; + end if; + end loop; + if Long then + New_Line; + end if; + end Dump_Stack; procedure Finalize (Object : in out Closure_Ptr) is begin @@ -168,7 +181,7 @@ package body Envs is begin if 0 < Object.Index then if 0 < Stack (Object.Index).Refs then - Stack (Object.Index).Refs := Stack (Object.Index).Refs - 1; + Stack (Object.Index).Refs := @ - 1; end if; Object.Index := 0; @@ -185,6 +198,7 @@ package body Envs is if R.Alias /= null then pragma Assert (R.Alias.all.Outer = null); pragma Assert (R.Alias.all.Refs = 0); + Allocations := Allocations - 1; Free (R.Alias); end if; exit; @@ -195,6 +209,7 @@ package body Envs is end if; elsif R.Alias.all.Refs = 0 then pragma Assert (R.Alias.all.Outer = null); + Allocations := Allocations - 1; Free (R.Alias); R.Data.Clear; if not R.Outer_On_Stack then @@ -217,10 +232,11 @@ package body Envs is O : Stack_Record renames Stack (R.Outer_Index); begin if O.Alias = null then + Allocations := Allocations + 1; O.Alias := new Heap_Record'(Index => R.Outer_Index, others => <>); else - O.Alias.all.Refs := O.Alias.all.Refs + 1; + O.Alias.all.Refs := @ + 1; end if; R.Alias.all.Outer := O.Alias; end; @@ -263,16 +279,17 @@ package body Envs is end loop Ref_Loop; Index := Ref.all.Index; end loop Main_Loop; - raise Unknown_Key with "'" & Key.To_String & "' not found"; + Err.Raise_With ("'" & Key.To_String & "' not found"); end Get; function New_Closure (Env : in Ptr'Class) return Closure_Ptr is Alias : Heap_Access renames Stack (Env.Index).Alias; begin if Alias = null then + Allocations := Allocations + 1; Alias := new Heap_Record'(Index => Env.Index, others => <>); else - Alias.all.Refs := Alias.all.Refs + 1; + Alias.all.Refs := @ + 1; end if; return (Ada.Finalization.Controlled with Alias); end New_Closure; @@ -283,7 +300,7 @@ package body Envs is if Env.Index < Top or 1 < R.Refs or (R.Alias /= null and then 0 < R.Alias.all.Refs) then - R.Refs := R.Refs - 1; + R.Refs := @ - 1; Top := Top + 1; pragma Assert (Stack (Top).Data.Is_Empty); pragma Assert (Stack (Top).Alias = null); @@ -304,9 +321,9 @@ package body Envs is -- Finalize Env before creating the new environment, in case -- this is the last reference and it can be forgotten. -- Automatic assignment would construct the new value before - -- finalizing the old one (because this is safer in general). + -- finalizing the old one. Finalize (Env); - Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + Outer.Ref.all.Refs := @ + 1; Top := Top + 1; pragma Assert (Stack (Top).Data.Is_Empty); pragma Assert (Stack (Top).Alias = null); @@ -318,14 +335,14 @@ package body Envs is Set_Binds (Stack (Top).Data, Binds, Exprs); end Replace_With_Sub; - procedure Replace_With_Sub_Macro (Env : in out Ptr; - Binds : in Symbols.Symbol_Array; - Exprs : in Lists.Ptr) + procedure Replace_With_Sub (Env : in out Ptr; + Binds : in Symbols.Symbol_Array; + Exprs : in Mal.T_Array) is begin Replace_With_Sub (Env); - Set_Binds_Macro (Stack (Top).Data, Binds, Exprs); - end Replace_With_Sub_Macro; + Set_Binds (Stack (Top).Data, Binds, Exprs); + end Replace_With_Sub; procedure Set (Env : in Ptr; Key : in Symbols.Ptr; @@ -342,62 +359,31 @@ package body Envs is Varargs : constant Boolean := 1 < Binds'Length and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand; begin - if (if Varargs then - Exprs'Length < Binds'Length - 2 - else - Exprs'Length /= Binds'Length) - then - raise Argument_Error with "function expected " - & Symbols.To_String (Binds) & ", got" - & Integer'Image (Exprs'Length) & " actual parameter(s)"; - end if; + Err.Check ((if Varargs then Binds'Length - 2 <= Exprs'Length + else Exprs'Length = Binds'Length), + "actual parameters do not match formal parameters"); for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I)); end loop; if Varargs then - M.Include (Binds (Binds'Last), - Lists.List (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); + M.Include (Binds (Binds'Last), Sequences.List + (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); end if; end Set_Binds; - procedure Set_Binds_Macro (M : in out HM.Map; - Binds : in Symbols.Symbol_Array; - Exprs : in Lists.Ptr) - is - use type Symbols.Ptr; - Varargs : constant Boolean := 1 < Binds'Length and then - Binds (Binds'Last - 1) = Symbols.Names.Ampersand; - begin - if (if Varargs then - Exprs.Length - 1 < Binds'Length - 2 - else - Exprs.Length - 1 /= Binds'Length) - then - raise Argument_Error with "macro expected " - & Symbols.To_String (Binds) & ", got" - & Integer'Image (Exprs.Length - 1) & " actual parameter(s)"; - end if; - for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop - M.Include (Binds (Binds'First + I), Exprs.Element (2 + I)); - end loop; - if Varargs then - M.Include (Binds (Binds'Last), Exprs.Slice (Start => Binds'Length)); - end if; - end Set_Binds_Macro; - function Sub (Outer : in Ptr; Binds : in Symbols.Symbol_Array; - Exprs : in Lists.Ptr) return Ptr + Exprs : in Mal.T_Array) return Ptr is R : Stack_Record renames Stack (Outer.Index); begin - R.Refs := R.Refs + 1; + R.Refs := @ + 1; Top := Top + 1; pragma Assert (Stack (Top).Data.Is_Empty); pragma Assert (Stack (Top).Alias = null); Stack (Top) := (Outer_Index => Outer.Index, others => <>); - Set_Binds_Macro (Stack (Top).Data, Binds, Exprs); + Set_Binds (Stack (Top).Data, Binds, Exprs); return (Ada.Finalization.Limited_Controlled with Top); end Sub; @@ -406,7 +392,7 @@ package body Envs is Exprs : in Mal.T_Array) return Ptr is begin - Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1; + Outer.Ref.all.Refs := @ + 1; Top := Top + 1; pragma Assert (Stack (Top).Data.Is_Empty); pragma Assert (Stack (Top).Alias = null); @@ -429,7 +415,7 @@ package body Envs is loop exit when Ref = null; exit when Ref.all.Refs = 0; - Ref.all.Refs := Ref.all.Refs - 1; + Ref.all.Refs := @ - 1; exit when 0 < Ref.all.Refs; exit when Ref.all.Outer = null; -- An alias. Do not free it -- now, it may be useful for another closure. @@ -437,6 +423,7 @@ package body Envs is Tmp : Heap_Access := Ref; begin Ref := Ref.all.Outer; + Allocations := Allocations - 1; Free (Tmp); pragma Unreferenced (Tmp); end; diff --git a/ada.2/envs.ads b/ada.2/envs.ads index 00c58102a7..59bee9c39b 100644 --- a/ada.2/envs.ads +++ b/ada.2/envs.ads @@ -1,6 +1,5 @@ private with Ada.Finalization; -with Types.Lists; with Types.Mal; with Types.Symbols; @@ -26,7 +25,6 @@ package Envs with Elaborate_Body is -- given environment, even during exception propagation. -- Since Ptr is limited with a hidden discriminant, any variable -- must immediately be assigned with one of - -- * Repl (in which case a renaming is probably better), -- * Copy_Pointer, -- * Sub (either from a Ptr or from a Closure_Ptr). -- Usual assignment with reference counting is not provided @@ -42,17 +40,12 @@ package Envs with Elaborate_Body is -- elsewhere. procedure Replace_With_Sub (Env : in out Ptr) with Inline; - -- Equivalent to Env := Sub (Outer => Env, empty Binds and Exprs), - -- except that such an assignment is forbidden for performance - -- reasons. - - procedure Replace_With_Sub_Macro (Env : in out Ptr; - Binds : in Types.Symbols.Symbol_Array; - Exprs : in Types.Lists.Ptr); - -- Equivalent to Env := Sub (Outer => Env, Binds, Expr), except - -- that such an assignment is forbidden for performance reasons. - -- This version is intended for macros: the Exprs argument is a - -- list, and its first element is skipped. + -- for let* + + procedure Replace_With_Sub (Env : in out Ptr; + Binds : in Types.Symbols.Symbol_Array; + Exprs : in Types.Mal.T_Array) with Inline; + -- when expanding macros. procedure Set (Env : in Ptr; Key : in Types.Symbols.Ptr; @@ -63,7 +56,7 @@ package Envs with Elaborate_Body is function Get (Evt : in Ptr; Key : in Types.Symbols.Ptr) return Types.Mal.T; - Unknown_Key : exception; + -- Raises Core.Error_Exception if the key is not found. -- Function closures. @@ -77,28 +70,28 @@ package Envs with Elaborate_Body is function Sub (Outer : in Closure_Ptr'Class; Binds : in Types.Symbols.Symbol_Array; Exprs : in Types.Mal.T_Array) return Ptr; - -- Construct a new environment with the given closure as outer parent. + -- when applying functions without tail call optimization. + -- Construct a new environment with the given outer parent. -- Then call Set with the paired elements of Binds and Exprs, -- handling the "&" special formal parameter if present. - -- May raise Argument_Count. + -- May raise Error. procedure Replace_With_Sub (Env : in out Ptr; Outer : in Closure_Ptr'Class; Binds : in Types.Symbols.Symbol_Array; Exprs : in Types.Mal.T_Array); - -- Equivalent to Env := Sub (Outer, Binds, Expr); except that such - -- an assignment is forbidden for performance reasons. + -- when applying functions with tail call optimization. + -- Equivalent to Env := Sub (Env, Binds, Exprs), except that such + -- an assignment is forbidden or discouraged for performance reasons. function Sub (Outer : in Ptr; Binds : in Types.Symbols.Symbol_Array; - Exprs : in Types.Lists.Ptr) return Ptr; - -- Like Sub above, but dedicated to macros. - -- * The Outer parameter is the current environment, not a closure. - -- * The Exprs argument is a list. - -- * Its first element is skipped. - - -- procedure Dump_Stack (Long : in Boolean := False); - -- For debugging. + Exprs : in Types.Mal.T_Array) return Ptr; + -- when applying macros + + -- Debugging. + procedure Dump_Stack (Long : in Boolean); + procedure Clear_And_Check_Allocations; private diff --git a/ada.2/err.adb b/ada.2/err.adb new file mode 100644 index 0000000000..4d579cc30b --- /dev/null +++ b/ada.2/err.adb @@ -0,0 +1,53 @@ +with Ada.Characters.Latin_1; + +with Printer; + +package body Err is + + use Ada.Strings.Unbounded; + use Types; + + ---------------------------------------------------------------------- + + procedure Add_Trace_Line (Action : in String; + Ast : in Types.Mal.T) + is + begin + Append (Trace, " in "); + Append (Trace, Action); + Append (Trace, ": "); + Printer.Pr_Str (Trace, Ast); + Append (Trace, Ada.Characters.Latin_1.LF); + end Add_Trace_Line; + + procedure Check (Condition : in Boolean; + Message : in String) + is + begin + if not Condition then + Raise_With (Message); + end if; + end Check; + + procedure Raise_With (Message : in String) is + begin + Data := (Kind_String, To_Unbounded_String (Message)); + Set_Unbounded_String (Trace, "Uncaught exception: "); + Append (Trace, Message); + Append (Trace, Ada.Characters.Latin_1.LF); + raise Error; + end Raise_With; + + function Throw (Args : in Mal.T_Array) return Mal.T is + begin + Check (Args'Length = 1, "expected 1 parameter"); + Data := Args (Args'First); + Set_Unbounded_String (Trace, "Uncaught exception: "); + Printer.Pr_Str (Trace, Data); + Append (Trace, Ada.Characters.Latin_1.LF); + -- A raise value is equivalent to a raise statement, but + -- silents a compiler warning. + return raise Error; + end Throw; + +end Err; diff --git a/ada.2/err.ads b/ada.2/err.ads new file mode 100644 index 0000000000..126295c673 --- /dev/null +++ b/ada.2/err.ads @@ -0,0 +1,40 @@ +with Ada.Strings.Unbounded; + +with Types.Mal; + +-- We declare a variable of type Types.Mal.T. +pragma Elaborate (Types.Mal); + +package Err with Elaborate_Body is + + -- Error handling. + + -- Built-in function. + function Throw (Args : in Types.Mal.T_Array) return Types.Mal.T; + + -- Ada exceptions can only carry an immutable String in each + -- occurence, so we require a global variable to store the last + -- exception as a Mal object anyway, and may as well use it for + -- simple string messages. + + Error : exception; + Data : Types.Mal.T; + Trace : Ada.Strings.Unbounded.Unbounded_String; + + -- Convenient shortcuts. + + procedure Raise_With (Message : in String) with Inline, No_Return; + -- Similar to a "raise with Message" Ada statement. + -- Store the message into Data, + -- store the message and "Uncaught exception: " into Trace, + -- then raise Error. + + procedure Add_Trace_Line (Action : in String; + Ast : in Types.Mal.T) with Inline; + -- Appends a line like "Action: Ast" to Trace. + + procedure Check (Condition : in Boolean; + Message : in String) with Inline; + -- Raise_With if Condition fails. + +end Err; diff --git a/ada.2/printer.adb b/ada.2/printer.adb index 11b9b9b5e2..f5ddb4deba 100644 --- a/ada.2/printer.adb +++ b/ada.2/printer.adb @@ -1,9 +1,9 @@ with Ada.Characters.Latin_1; with Types.Atoms; -with Types.Functions; +with Types.Fns; +with Types.Sequences; with Types.Symbols; -with Types.Lists; with Types.Maps; package body Printer is @@ -11,8 +11,9 @@ package body Printer is use Ada.Strings.Unbounded; use Types; - function Pr_Str (Ast : in Mal.T; - Readably : in Boolean := True) return Unbounded_String + procedure Pr_Str (Buffer : in out Unbounded_String; + Ast : in Mal.T; + Readably : in Boolean := True) is procedure Print_Form (Form_Ast : in Mal.T); @@ -21,13 +22,10 @@ package body Printer is -- Helpers for Print_Form. procedure Print_Number (Number : in Integer) with Inline; - procedure Print_List (List : in Lists.Ptr) with Inline; + procedure Print_List (List : in Sequences.Ptr) with Inline; procedure Print_Map (Map : in Maps.Ptr) with Inline; procedure Print_Readably (S : in Unbounded_String) with Inline; - procedure Print_Symbols (List : in Symbols.Symbol_Array) with Inline; - - Buffer : Unbounded_String := Null_Unbounded_String; - -- is appended the result character after character. + procedure Print_Function (Fn : in Fns.Ptr) with Inline; ---------------------------------------------------------------------- @@ -59,11 +57,11 @@ package body Printer is end if; when Kind_List => Append (Buffer, '('); - Print_List (Form_Ast.List); + Print_List (Form_Ast.Sequence); Append (Buffer, ')'); when Kind_Vector => Append (Buffer, '['); - Print_List (Form_Ast.List); + Print_List (Form_Ast.Sequence); Append (Buffer, ']'); when Kind_Map => Append (Buffer, '{'); @@ -71,17 +69,13 @@ package body Printer is Append (Buffer, '}'); when Kind_Builtin | Kind_Builtin_With_Meta => Append (Buffer, "#"); - when Kind_Function => + when Kind_Fn => Append (Buffer, "# "); - Print_Form (Form_Ast.Fn.Ast); + Print_Function (Form_Ast.Fn); Append (Buffer, '>'); when Kind_Macro => Append (Buffer, "# "); - Print_Form (Form_Ast.Fn.Ast); + Print_Function (Form_Ast.Fn); Append (Buffer, '>'); when Kind_Atom => Append (Buffer, "(atom "); @@ -90,22 +84,36 @@ package body Printer is end case; end Print_Form; - procedure Print_List (List : in Lists.Ptr) is + procedure Print_Function (Fn : in Fns.Ptr) is Started : Boolean := False; begin - for I in 1 .. List.Length loop + Append (Buffer, '('); + for Param of Fn.Params loop if Started then Append (Buffer, ' '); else Started := True; end if; - Print_Form (List.Element (I)); + Append (Buffer, Param.To_String); end loop; + Append (Buffer, ") -> "); + Print_Form (Fn.Ast); + end Print_Function; + + procedure Print_List (List : in Sequences.Ptr) is + begin + if 0 < List.Length then + Print_Form (List (1)); + for I in 2 .. List.Length loop + Append (Buffer, ' '); + Print_Form (List (I)); + end loop; + end if; end Print_List; procedure Print_Map (Map : in Maps.Ptr) is procedure Process (Key : in Mal.T; - Element : in Mal.T); + Element : in Mal.T) with Inline; procedure Iterate is new Maps.Iterate (Process); Started : Boolean := False; procedure Process (Key : in Mal.T; @@ -154,24 +162,19 @@ package body Printer is end loop; end Print_Readably; - procedure Print_Symbols (List : in Symbols.Symbol_Array) is - Started : Boolean := False; - begin - for S of List loop - if Started then - Append (Buffer, ' '); - else - Started := True; - end if; - Append (Buffer, S.To_String); - end loop; - end Print_Symbols; - ---------------------------------------------------------------------- begin -- Pr_Str - Print_Form (Form_Ast => Ast); - return Buffer; + Print_Form (Ast); + end Pr_Str; + + function Pr_Str (Ast : in Mal.T; + Readably : in Boolean := True) return Unbounded_String + is + begin + return Buffer : Unbounded_String do + Pr_Str (Buffer, Ast, Readably); + end return; end Pr_Str; end Printer; diff --git a/ada.2/printer.ads b/ada.2/printer.ads index b50d32a60d..02cf6036d5 100644 --- a/ada.2/printer.ads +++ b/ada.2/printer.ads @@ -4,13 +4,15 @@ with Types.Mal; package Printer with Elaborate_Body is + procedure Pr_Str + (Buffer : in out Ada.Strings.Unbounded.Unbounded_String; + Ast : in Types.Mal.T; + Readably : in Boolean := True); + -- Append the text to Buffer. + function Pr_Str (Ast : in Types.Mal.T; Readably : in Boolean := True) return Ada.Strings.Unbounded.Unbounded_String; - - function Img (Ast : in Types.Mal.T) return String - is (Ada.Strings.Unbounded.To_String (Pr_Str (Ast))) with Inline; - -- This form is convenient for reporting errors, but the - -- conversion should be avoided when possible. + -- Return a freshly created unbounded string. end Printer; diff --git a/ada.2/reader.adb b/ada.2/reader.adb index b2ec6b365b..99d5c57c74 100644 --- a/ada.2/reader.adb +++ b/ada.2/reader.adb @@ -1,14 +1,20 @@ with Ada.Characters.Handling; with Ada.Characters.Latin_1; +with Ada.Environment_Variables; with Ada.Strings.Maps.Constants; with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; -with Types.Lists; +with Err; +with Printer; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; package body Reader is + Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbg_reader"); + use Types; use type Ada.Strings.Maps.Character_Set; @@ -19,12 +25,19 @@ package body Reader is Symbol_Set : constant Ada.Strings.Maps.Character_Set := not (Ignored_Set or Ada.Strings.Maps.To_Set ("""'()@[]^`{}~")); - function Read_Str (Source : in String) return Types.Mal.T is + function Read_Str (Source : in String) return Types.Mal.T_Array is I : Positive := Source'First; - -- Index of the currently considered character. + -- Index in Source of the currently read character. + + -- Big arrays on the stack are faster than repeated dynamic + -- reallocations. This single buffer is used by all Read_List + -- recursive invocations, and by Read_Str. + Buffer : Mal.T_Array (1 .. Source'Length); + B_Last : Natural := Buffer'First - 1; + -- Index in Buffer of the currently written MAL expression. - function Read_Form return Mal.T; + procedure Read_Form; -- The recursive part of Read_Str. -- Helpers for Read_Form: @@ -40,163 +53,167 @@ package body Reader is procedure Skip_Symbol with Inline; -- Check if the current character is allowed in a symbol name. - -- Increment I uuntil it exceeds Source'Last or stops + -- Increment I until it exceeds Source'Last or stops -- designating an allowed character. -- Read_Atom has been merged into the same case/switch -- statement, for clarity and efficiency. - function Read_List (Ending : in Character) return Mal.T_Array + procedure Read_List (Ending : in Character; + Constructor : in not null Mal.Builtin_Ptr) with Inline; - function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline; - function Read_String return Mal.T with Inline; - function Read_With_Meta return Mal.T with Inline; + procedure Read_Quote (Symbol : in Symbols.Ptr) with Inline; + procedure Read_String with Inline; + procedure Read_With_Meta with Inline; ---------------------------------------------------------------------- - function Read_List (Ending : in Character) return Mal.T_Array is - -- Big arrays on the stack are faster than repeated - -- dynamic reallocations. + procedure Read_List (Ending : in Character; + Constructor : in not null Mal.Builtin_Ptr) is Opening : constant Character := Source (I); - Buffer : Mal.T_Array (I + 1 .. Source'Last); - B_Last : Natural := I; + B_First : constant Positive := B_Last; begin I := I + 1; -- Skip (, [ or {. loop Skip_Ignored; - if Source'Last < I then - raise Reader_Error with "unbalanced '" & Opening & "'"; - end if; + Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'"); exit when Source (I) = Ending; + Read_Form; B_Last := B_Last + 1; - Buffer (B_Last) := Read_Form; end loop; I := I + 1; -- Skip ), ] or }. - return Buffer (Buffer'First .. B_Last); + Buffer (B_First) := Constructor.all (Buffer (B_First .. B_Last - 1)); + B_Last := B_First; end Read_List; - function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is + procedure Read_Quote (Symbol : in Symbols.Ptr) is begin + Buffer (B_Last) := (Kind_Symbol, Symbol); I := I + 1; -- Skip the initial ' or similar. Skip_Ignored; - if Source'Last < I then - raise Reader_Error with "Incomplete '" & Symbol.To_String & "'"; - end if; - return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form)); + Err.Check (I <= Source'Last, "Incomplete '" & Symbol.To_String & "'"); + B_Last := B_Last + 1; + Read_Form; + B_Last := B_Last - 1; + Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 1)); end Read_Quote; - function Read_Form return Mal.T is + procedure Read_Form is + -- After I has been increased, current token is be + -- Source (F .. I - 1). F : Positive; begin case Source (I) is when ')' | ']' | '}' => - raise Reader_Error with "unbalanced '" & Source (I) & "'"; + Err.Raise_With ("unbalanced '" & Source (I) & "'"); when '"' => - return Read_String; + Read_String; when ':' => I := I + 1; F := I; Skip_Symbol; - return (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String - (Source (F .. I - 1))); + Buffer (B_Last) := (Kind_Keyword, + Ada.Strings.Unbounded.To_Unbounded_String + (Source (F .. I - 1))); when '-' => F := I; Skip_Digits; if F + 1 < I then - return (Kind_Number, Integer'Value (Source (F .. I - 1))); + Buffer (B_Last) := (Kind_Number, + Integer'Value (Source (F .. I - 1))); + else + Skip_Symbol; + Buffer (B_Last) := (Kind_Symbol, + Symbols.Constructor (Source (F .. I - 1))); end if; - Skip_Symbol; - return (Kind_Symbol, Symbols.Constructor (Source (F .. I - 1))); when '~' => if I < Source'Last and then Source (I + 1) = '@' then I := I + 1; - return Read_Quote (Symbols.Names.Splice_Unquote); + Read_Quote (Symbols.Names.Splice_Unquote); + else + Read_Quote (Symbols.Names.Unquote); end if; - return Read_Quote (Symbols.Names.Unquote); when '0' .. '9' => F := I; Skip_Digits; - return (Kind_Number, Integer'Value (Source (F .. I - 1))); + Buffer (B_Last) := (Kind_Number, + Integer'Value (Source (F .. I - 1))); when ''' => - return Read_Quote (Symbols.Names.Quote); + Read_Quote (Symbols.Names.Quote); when '`' => - return Read_Quote (Symbols.Names.Quasiquote); + Read_Quote (Symbols.Names.Quasiquote); when '@' => - return Read_Quote (Symbols.Names.Deref); + Read_Quote (Symbols.Names.Deref); when '^' => - return Read_With_Meta; + Read_With_Meta; when '(' => - return Lists.List (Read_List (')')); + Read_List (')', Sequences.List'Access); when '[' => - return Lists.Vector (Read_List (']')); + Read_List (']', Sequences.Vector'Access); when '{' => - return Maps.Hash_Map (Read_List ('}')); + Read_List ('}', Maps.Hash_Map'Access); when others => F := I; Skip_Symbol; if Source (F .. I - 1) = "false" then - return (Kind_Boolean, False); + Buffer (B_Last) := (Kind_Boolean, False); elsif Source (F .. I - 1) = "nil" then - return Mal.Nil; + Buffer (B_Last) := Mal.Nil; elsif Source (F .. I - 1) = "true" then - return (Kind_Boolean, True); + Buffer (B_Last) := (Kind_Boolean, True); + else + Buffer (B_Last) := (Kind_Symbol, + Symbols.Constructor (Source (F .. I - 1))); end if; - return (Kind_Symbol, Symbols.Constructor (Source (F .. I - 1))); end case; + if Debug then + Ada.Text_IO.Put ("reader: "); + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Buffer + (B_Last))); + end if; end Read_Form; - function Read_String return Mal.T is + procedure Read_String is use Ada.Strings.Unbounded; - S : Unbounded_String; begin + Buffer (B_Last) := (Kind_String, Null_Unbounded_String); loop I := I + 1; - if Source'Last < I then - raise Reader_Error with "unbalanced '""'"; - end if; + Err.Check (I <= Source'Last, "unbalanced '""'"); case Source (I) is when '"' => exit; when '\' => I := I + 1; - if Source'Last < I then - raise Reader_Error with "unbalanced '""'"; - end if; + Err.Check (I <= Source'Last, "unbalanced '""'"); case Source (I) is when '\' | '"' => - Append (S, Source (I)); + Append (Buffer (B_Last).S, Source (I)); when 'n' => - Append (S, Ada.Characters.Latin_1.LF); + Append (Buffer (B_Last).S, Ada.Characters.Latin_1.LF); when others => - Append (S, Source (I - 1 .. I)); + Append (Buffer (B_Last).S, Source (I - 1 .. I)); end case; when others => - Append (S, Source (I)); + Append (Buffer (B_Last).S, Source (I)); end case; end loop; I := I + 1; -- Skip closing double quote. - return (Kind_String, S); end Read_String; - function Read_With_Meta return Mal.T is - Args : Mal.T_Array (1 .. 3); + procedure Read_With_Meta is begin - Args (1) := (Kind_Symbol, Symbols.Names.With_Meta); - - I := I + 1; -- Skip the initial ^. - - Skip_Ignored; - if Source'Last < I then - raise Reader_Error with "incomplete 'with-meta'"; - end if; - Args (3) := Read_Form; - - Skip_Ignored; - if Source'Last < I then - raise Reader_Error with "incomplete 'with-meta'"; - end if; - Args (2) := Read_Form; - - return Lists.List (Args); + I := I + 1; -- Skip the initial ^. + for Argument in 1 .. 2 loop + Skip_Ignored; + Err.Check (I <= Source'Last, "Incomplete 'with-meta'"); + Read_Form; + B_Last := B_Last + 1; + end loop; + -- Replace (metadata data) with (with-meta data metadata). + B_Last := B_Last - 2; + Buffer (B_Last + 2) := Buffer (B_Last); + Buffer (B_Last) := (Kind_Symbol, Symbols.Names.With_Meta); + Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 2)); end Read_With_Meta; procedure Skip_Digits is @@ -204,7 +221,8 @@ package body Reader is begin loop I := I + 1; - exit when Source'Last < I or else not Is_Digit (Source (I)); + exit when Source'Last < I; + exit when not Is_Digit (Source (I)); end loop; end Skip_Digits; @@ -236,20 +254,14 @@ package body Reader is ---------------------------------------------------------------------- - Result : Mal.T; begin -- Read_Str - Skip_Ignored; - if Source'Last < I then - raise Empty_Source with "attempting to read an empty line"; - end if; - Result := Read_Form; - Skip_Ignored; - if I <= Source'Last then - raise Reader_Error - with "unexpected characters '" & Source (I .. Source'Last) - & "' after '" & Source (Source'First .. I - 1) & '''; - end if; - return Result; + loop + Skip_Ignored; + exit when Source'Last < I; + B_Last := B_Last + 1; + Read_Form; + end loop; + return Buffer (Buffer'First .. B_Last); end Read_Str; end Reader; diff --git a/ada.2/reader.ads b/ada.2/reader.ads index 0d9d185b91..88a6ca4df6 100644 --- a/ada.2/reader.ads +++ b/ada.2/reader.ads @@ -2,9 +2,9 @@ with Types.Mal; package Reader with Elaborate_Body is - function Read_Str (Source : in String) return Types.Mal.T; - - Empty_Source : exception; - Reader_Error : exception; + function Read_Str (Source : in String) return Types.Mal.T_Array; + -- The language does not explicitly define what happens when the + -- input string contains more than one expression. + -- This implementation returns all of them. end Reader; diff --git a/ada.2/step1_read_print.adb b/ada.2/step1_read_print.adb index 67b3277621..f0e3ad6878 100644 --- a/ada.2/step1_read_print.adb +++ b/ada.2/step1_read_print.adb @@ -1,16 +1,22 @@ -with Ada.Exceptions; with Ada.Text_IO.Unbounded_IO; +with Err; with Printer; with Reader; with Readline; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; +with Types.Maps; +with Types.Sequences; +with Types.Symbols; procedure Step1_Read_Print is use Types; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast : in Mal.T) return Mal.T; @@ -27,11 +33,14 @@ procedure Step1_Read_Print is Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); end Print; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep is begin - Print (Eval (Read)); + for Expression of Read loop + Print (Eval (Expression)); + end loop; end Rep; ---------------------------------------------------------------------- @@ -43,12 +52,18 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Reader.Reader_Error => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step1_Read_Print; diff --git a/ada.2/step2_eval.adb b/ada.2/step2_eval.adb index 101734b46c..a8928f855b 100644 --- a/ada.2/step2_eval.adb +++ b/ada.2/step2_eval.adb @@ -1,17 +1,24 @@ +with Ada.Environment_Variables; with Ada.Containers.Indefinite_Hashed_Maps; -with Ada.Exceptions; with Ada.Strings.Hash; with Ada.Text_IO.Unbounded_IO; +with Err; with Printer; with Reader; with Readline; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; +with Types.Symbols; procedure Step2_Eval is + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + use Types; package Envs is new Ada.Containers.Indefinite_Hashed_Maps @@ -20,9 +27,8 @@ procedure Step2_Eval is Hash => Ada.Strings.Hash, Equivalent_Keys => "=", "=" => Mal."="); - Unknown_Key : exception; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast : in Mal.T; Env : in Envs.Map) return Mal.T; @@ -35,8 +41,8 @@ procedure Step2_Eval is with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Map, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Map, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval); ---------------------------------------------------------------------- @@ -45,39 +51,37 @@ procedure Step2_Eval is is First : Mal.T; begin - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => declare S : constant String := Ast.Symbol.To_String; C : constant Envs.Cursor := Env.Find (S); begin - if Envs.Has_Element (C) then - return (Kind_Builtin, Envs.Element (C)); - else - -- The predefined message does not pass tests. - raise Unknown_Key with "'" & S & "' not found"; - end if; + -- The predefined error message does not pass tests. + Err.Check (Envs.Has_Element (C), "'" & S & "' not found"); + return (Kind_Builtin, Envs.Element (C)); end; when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Eval (Ast.List.Element (1), Env); + First := Eval (Ast.Sequence (1), Env); -- Apply phase. -- Ast is a non-empty list, @@ -85,16 +89,20 @@ procedure Step2_Eval is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function"); end case; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; end Eval; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T @@ -106,11 +114,14 @@ procedure Step2_Eval is Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); end Print; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Map) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- @@ -132,12 +143,18 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Reader.Reader_Error | Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step2_Eval; diff --git a/ada.2/step3_env.adb b/ada.2/step3_env.adb index 9a4294f31c..1585dee9b1 100644 --- a/ada.2/step3_env.adb +++ b/ada.2/step3_env.adb @@ -1,20 +1,30 @@ -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Text_IO.Unbounded_IO; with Envs; +with Err; with Printer; with Reader; with Readline; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step3_Env is + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast : in Mal.T; Env : in Envs.Ptr) return Mal.T; @@ -27,8 +37,8 @@ procedure Step3_Env is with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); ---------------------------------------------------------------------- @@ -38,67 +48,64 @@ procedure Step3_Env is use type Symbols.Ptr; First : Mal.T; begin - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; -- This curious syntax is useful for later steps. New_Env : Envs.Ptr := Env.Copy_Pointer; begin + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); New_Env.Replace_With_Sub; - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - New_Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), New_Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + New_Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), New_Env)); end loop; - return Eval (Ast.List.Element (3), New_Env); + return Eval (Ast.Sequence (3), New_Env); end; else First := Eval (First, Env); @@ -113,16 +120,20 @@ procedure Step3_Env is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function"); end case; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; end Eval; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T @@ -134,11 +145,14 @@ procedure Step3_Env is Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); end Print; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- @@ -164,12 +178,19 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step3_Env; diff --git a/ada.2/step4_if_fn_do.adb b/ada.2/step4_if_fn_do.adb index 342f9dd737..d8c1ca2a2f 100644 --- a/ada.2/step4_if_fn_do.adb +++ b/ada.2/step4_if_fn_do.adb @@ -1,23 +1,33 @@ -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step4_If_Fn_Do is + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast : in Mal.T; Env : in Envs.Ptr) return Mal.T; @@ -26,13 +36,12 @@ procedure Step4_If_Fn_Do is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -42,107 +51,86 @@ procedure Step4_If_Fn_Do is use type Symbols.Ptr; First : Mal.T; begin - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - return Eval (Ast.List.Element (Ast.List.Length), Env); + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - return Eval (Ast.List.Element (3), Env); - elsif Ast.List.Length = 3 then + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + return Eval (Ast.Sequence (3), Env); + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - return Eval (Ast.List.Element (4), Env); + return Eval (Ast.Sequence (4), Env); end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; -- This curious syntax is useful for later steps. New_Env : Envs.Ptr := Env.Copy_Pointer; begin + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); New_Env.Replace_With_Sub; - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - New_Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), New_Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + New_Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), New_Env)); end loop; - return Eval (Ast.List.Element (3), New_Env); + return Eval (Ast.Sequence (3), New_Env); end; else First := Eval (First, Env); @@ -157,74 +145,88 @@ procedure Step4_If_Fn_Do is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Fn.Apply (Args); end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function"); end case; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); end Print; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" - & ")"; + Startup : constant String + := "(def! not (fn* (a) (if a false true)))"; Repl : Envs.Ptr renames Envs.Repl; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); loop begin Rep (Repl); exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step4_If_Fn_Do; diff --git a/ada.2/step5_tco.adb b/ada.2/step5_tco.adb index 2e109e393a..540e5a4f49 100644 --- a/ada.2/step5_tco.adb +++ b/ada.2/step5_tco.adb @@ -1,23 +1,33 @@ -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step5_Tco is + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; @@ -26,13 +36,12 @@ procedure Step5_Tco is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -47,108 +56,86 @@ procedure Step5_Tco is First : Mal.T; begin <> - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - Ast := Ast.List.Element (Ast.List.Length); - goto Restart; + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - Ast := Ast.List.Element (3); + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + Ast := Ast.Sequence (3); goto Restart; - elsif Ast.List.Length = 3 then + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - Ast := Ast.List.Element (4); + Ast := Ast.Sequence (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; begin - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); Env.Replace_With_Sub; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), Env)); end loop; - Ast := Ast.List.Element (3); + Ast := Ast.Sequence (3); goto Restart; end; else @@ -156,13 +143,12 @@ procedure Step5_Tco is -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. null; - when Kind_List | Kind_Vector | Kind_Map => + when Kind_Sequence | Kind_Map => -- Lists are definitely worth a recursion, and the two other -- cases should be rare (they will report an error later). First := Eval (First, Env); @@ -174,19 +160,19 @@ procedure Step5_Tco is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; Env.Replace_With_Sub (Outer => First.Fn.Env, Binds => First.Fn.Params, @@ -195,57 +181,71 @@ procedure Step5_Tco is goto Restart; end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function"); end case; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); end Print; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" - & ")"; + Startup : constant String + := "(def! not (fn* (a) (if a false true)))"; Repl : Envs.Ptr renames Envs.Repl; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); loop begin Rep (Repl); exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step5_Tco; diff --git a/ada.2/step6_file.adb b/ada.2/step6_file.adb index 42294855b9..37da996794 100644 --- a/ada.2/step6_file.adb +++ b/ada.2/step6_file.adb @@ -1,26 +1,36 @@ with Ada.Command_Line; -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step6_File is - package ASU renames Ada.Strings.Unbounded; + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; + package ASU renames Ada.Strings.Unbounded; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; @@ -29,13 +39,12 @@ procedure Step6_File is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -50,108 +59,86 @@ procedure Step6_File is First : Mal.T; begin <> - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - Ast := Ast.List.Element (Ast.List.Length); - goto Restart; + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - Ast := Ast.List.Element (3); + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + Ast := Ast.Sequence (3); goto Restart; - elsif Ast.List.Length = 3 then + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - Ast := Ast.List.Element (4); + Ast := Ast.Sequence (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; begin - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); Env.Replace_With_Sub; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), Env)); end loop; - Ast := Ast.List.Element (3); + Ast := Ast.Sequence (3); goto Restart; end; else @@ -159,13 +146,12 @@ procedure Step6_File is -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. null; - when Kind_List | Kind_Vector | Kind_Map => + when Kind_Sequence | Kind_Map => -- Lists are definitely worth a recursion, and the two other -- cases should be rare (they will report an error later). First := Eval (First, Env); @@ -177,19 +163,19 @@ procedure Step6_File is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; Env.Replace_With_Sub (Outer => First.Fn.Env, Binds => First.Fn.Params, @@ -198,60 +184,67 @@ procedure Step6_File is goto Restart; end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function"); end case; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); end Print; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" - & ")"; + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))"; Repl : Envs.Ptr renames Envs.Repl; - use Ada.Command_Line; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); -- Define ARGV from command line arguments. declare + use Ada.Command_Line; Args : Mal.T_Array (2 .. Argument_Count); begin for I in Args'Range loop Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); end; -- Script? - if 0 < Argument_Count then - Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); + if 0 < Ada.Command_Line.Argument_Count then + Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); else loop begin @@ -259,13 +252,20 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step6_File; diff --git a/ada.2/step7_quote.adb b/ada.2/step7_quote.adb index 2d517a65e4..35cca20666 100644 --- a/ada.2/step7_quote.adb +++ b/ada.2/step7_quote.adb @@ -1,26 +1,36 @@ with Ada.Command_Line; -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step7_Quote is - package ASU renames Ada.Strings.Unbounded; + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; + package ASU renames Ada.Strings.Unbounded; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; @@ -36,13 +46,12 @@ procedure Step7_Quote is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -57,132 +66,105 @@ procedure Step7_Quote is First : Mal.T; begin <> - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - Ast := Ast.List.Element (Ast.List.Length); - goto Restart; + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - Ast := Ast.List.Element (3); + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + Ast := Ast.Sequence (3); goto Restart; - elsif Ast.List.Length = 3 then + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - Ast := Ast.List.Element (4); + Ast := Ast.Sequence (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; begin - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); Env.Replace_With_Sub; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), Env)); end loop; - Ast := Ast.List.Element (3); + Ast := Ast.Sequence (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quasiquote: expects 1 argument"; - end if; - return Quasiquote (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quote: expects 1 argument"; - end if; - return Ast.List.Element (2); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Ast.Sequence (2); else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. null; - when Kind_List | Kind_Vector | Kind_Map => + when Kind_Sequence | Kind_Map => -- Lists are definitely worth a recursion, and the two other -- cases should be rare (they will report an error later). First := Eval (First, Env); @@ -194,19 +176,19 @@ procedure Step7_Quote is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; Env.Replace_With_Sub (Outer => First.Fn.Env, Binds => First.Fn.Params, @@ -215,17 +197,24 @@ procedure Step7_Quote is goto Restart; end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function"); end case; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin @@ -236,97 +225,93 @@ procedure Step7_Quote is Env : in Envs.Ptr) return Mal.T is - use type Symbols.Ptr; - - function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is -- The final return concatenates these lists. R : Mal.T_Array (1 .. List.Length); begin for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).List.Length - and then R (I).List.Element (1).Kind = Kind_Symbol - and then R (I).List.Element (1).Symbol - = Symbols.Names.Splice_Unquote + R (I) := List (I); + if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length + and then R (I).Sequence (1) = (Kind_Symbol, + Symbols.Names.Splice_Unquote) then - if R (I).List.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 arg"; - end if; - R (I) := Eval (R (I).List.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; - end if; + Err.Check (R (I).Sequence.Length = 2, + "splice-unquote expects 1 parameter"); + R (I) := Eval (@.Sequence (2), Env); + Err.Check (R (I).Kind = Kind_List, + "splice_unquote expects a list"); else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), - Env))); + R (I) := Sequences.List + (Mal.T_Array'(1 => Quasiquote (@, Env))); end if; end loop; - return Lists.Concat (R); + return Sequences.Concat (R); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); when Kind_List => - if 0 < Ast.List.Length - and then Ast.List.Element (1).Kind = Kind_Symbol - and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.Sequence.Length + and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) then - if 2 < Ast.List.Length then - raise Argument_Error with "unquote: expects 1 argument"; - end if; - return Eval (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence (2), Env); else - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); end if; when others => return Ast; end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; end Quasiquote; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" - & ")"; + & " (eval (read-string (str ""(do "" (slurp f) "")"")))))"; Repl : Envs.Ptr renames Envs.Repl; - use Ada.Command_Line; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); -- Define ARGV from command line arguments. declare + use Ada.Command_Line; Args : Mal.T_Array (2 .. Argument_Count); begin for I in Args'Range loop Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); end; -- Script? - if 0 < Argument_Count then - Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); + if 0 < Ada.Command_Line.Argument_Count then + Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); else loop begin @@ -334,13 +319,20 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step7_Quote; diff --git a/ada.2/step8_macros.adb b/ada.2/step8_macros.adb index a1b00ed02a..e969e48a7f 100644 --- a/ada.2/step8_macros.adb +++ b/ada.2/step8_macros.adb @@ -1,26 +1,36 @@ with Ada.Command_Line; -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step8_Macros is - package ASU renames Ada.Strings.Unbounded; + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; + package ASU renames Ada.Strings.Unbounded; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; @@ -36,13 +46,12 @@ procedure Step8_Macros is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -58,155 +67,122 @@ procedure Step8_Macros is First : Mal.T; begin <> - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - if Ast.List.Length /= 3 then - raise Argument_Error with "defmacro!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "defmacro!: arg 1 must be a symbol"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); declare - F : constant Mal.T := Eval (Ast.List.Element (3), Env); + F : constant Mal.T := Eval (Ast.Sequence (3), Env); begin - if F.Kind /= Kind_Function then - raise Argument_Error with "defmacro!: expects a function"; - end if; + Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function"); return R : constant Mal.T := F.Fn.New_Macro do - Env.Set (Ast.List.Element (2).Symbol, R); + Env.Set (Ast.Sequence (2).Symbol, R); end return; end; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - Ast := Ast.List.Element (Ast.List.Length); - goto Restart; + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - Ast := Ast.List.Element (3); + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + Ast := Ast.Sequence (3); goto Restart; - elsif Ast.List.Length = 3 then + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - Ast := Ast.List.Element (4); + Ast := Ast.Sequence (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; begin - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); Env.Replace_With_Sub; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), Env)); end loop; - Ast := Ast.List.Element (3); + Ast := Ast.Sequence (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - if Ast.List.Length /= 2 then - raise Argument_Error with "macroexpand: expects 1 argument"; - end if; + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); Macroexpanding := True; - Ast := Ast.List.Element (2); + Ast := Ast.Sequence (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quasiquote: expects 1 argument"; - end if; - return Quasiquote (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quote: expects 1 argument"; - end if; - return Ast.List.Element (2); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Ast.Sequence (2); else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. null; - when Kind_List | Kind_Vector | Kind_Map => + when Kind_Sequence | Kind_Map => -- Lists are definitely worth a recursion, and the two other -- cases should be rare (they will report an error later). First := Eval (First, Env); @@ -218,19 +194,19 @@ procedure Step8_Macros is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; Env.Replace_With_Sub (Outer => First.Fn.Env, Binds => First.Fn.Params, @@ -239,33 +215,49 @@ procedure Step8_Macros is goto Restart; end; when Kind_Macro => - if Macroexpanding then - -- Evaluate the macro with tail call optimization. - Env.Replace_With_Sub_Macro (Binds => First.Fn.Params, - Exprs => Ast.List); - Ast := First.Fn.Ast; - goto Restart; - else - -- Evaluate the macro normally. - Ast := Eval (Ast0 => First.Fn.Ast, - Env0 => Envs.Sub (Outer => Env, - Binds => First.Fn.Params, - Exprs => Ast.List)); - -- Then evaluate the result with TCO. - goto Restart; - end if; + declare + Args : constant Mal.T_Array + := Ast.Sequence.Tail (Ast.Sequence.Length - 1); + begin + if Macroexpanding then + -- Evaluate the macro with tail call optimization. + Env.Replace_With_Sub (Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; + goto Restart; + else + -- Evaluate the macro normally. + Ast := Eval (First.Fn.Ast, Envs.Sub + (Outer => Env, + Binds => First.Fn.Params, + Exprs => Args)); + -- Then evaluate the result with TCO. + goto Restart; + end if; + end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function or macro"); end case; + exception + when Err.Error => + if Macroexpanding then + Err.Add_Trace_Line ("macroexpand", Ast); + else + Err.Add_Trace_Line ("eval", Ast); + end if; + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin @@ -276,71 +268,70 @@ procedure Step8_Macros is Env : in Envs.Ptr) return Mal.T is - use type Symbols.Ptr; - - function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is -- The final return concatenates these lists. R : Mal.T_Array (1 .. List.Length); begin for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).List.Length - and then R (I).List.Element (1).Kind = Kind_Symbol - and then R (I).List.Element (1).Symbol - = Symbols.Names.Splice_Unquote + R (I) := List (I); + if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length + and then R (I).Sequence (1) = (Kind_Symbol, + Symbols.Names.Splice_Unquote) then - if R (I).List.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 arg"; - end if; - R (I) := Eval (R (I).List.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; - end if; + Err.Check (R (I).Sequence.Length = 2, + "splice-unquote expects 1 parameter"); + R (I) := Eval (@.Sequence (2), Env); + Err.Check (R (I).Kind = Kind_List, + "splice_unquote expects a list"); else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), - Env))); + R (I) := Sequences.List + (Mal.T_Array'(1 => Quasiquote (@, Env))); end if; end loop; - return Lists.Concat (R); + return Sequences.Concat (R); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); when Kind_List => - if 0 < Ast.List.Length - and then Ast.List.Element (1).Kind = Kind_Symbol - and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.Sequence.Length + and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) then - if 2 < Ast.List.Length then - raise Argument_Error with "unquote: expects 1 argument"; - end if; - return Eval (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence (2), Env); else - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); end if; when others => return Ast; end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; end Quasiquote; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" & "(defmacro! cond (fn* (& xs)" @@ -353,31 +344,28 @@ procedure Step8_Macros is & " (if (empty? xs) nil" & " (if (= 1 (count xs)) (first xs)" & " `(let* (or_FIXME ~(first xs))" - & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))" - & ")"; + & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"; Repl : Envs.Ptr renames Envs.Repl; - use Ada.Command_Line; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); -- Define ARGV from command line arguments. declare + use Ada.Command_Line; Args : Mal.T_Array (2 .. Argument_Count); begin for I in Args'Range loop Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); end; -- Script? - if 0 < Argument_Count then - Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); + if 0 < Ada.Command_Line.Argument_Count then + Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); else loop begin @@ -385,13 +373,20 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step8_Macros; diff --git a/ada.2/step9_try.adb b/ada.2/step9_try.adb index 8291002fff..71b065ba09 100644 --- a/ada.2/step9_try.adb +++ b/ada.2/step9_try.adb @@ -1,26 +1,36 @@ with Ada.Command_Line; -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure Step9_Try is - package ASU renames Ada.Strings.Unbounded; + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; + package ASU renames Ada.Strings.Unbounded; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; @@ -36,13 +46,12 @@ procedure Step9_Try is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -58,181 +67,135 @@ procedure Step9_Try is First : Mal.T; begin <> - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - if Ast.List.Length /= 3 then - raise Argument_Error with "defmacro!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "defmacro!: arg 1 must be a symbol"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); declare - F : constant Mal.T := Eval (Ast.List.Element (3), Env); + F : constant Mal.T := Eval (Ast.Sequence (3), Env); begin - if F.Kind /= Kind_Function then - raise Argument_Error with "defmacro!: expects a function"; - end if; + Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function"); return R : constant Mal.T := F.Fn.New_Macro do - Env.Set (Ast.List.Element (2).Symbol, R); + Env.Set (Ast.Sequence (2).Symbol, R); end return; end; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - Ast := Ast.List.Element (Ast.List.Length); - goto Restart; + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - Ast := Ast.List.Element (3); + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + Ast := Ast.Sequence (3); goto Restart; - elsif Ast.List.Length = 3 then + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - Ast := Ast.List.Element (4); + Ast := Ast.Sequence (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; begin - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); Env.Replace_With_Sub; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), Env)); end loop; - Ast := Ast.List.Element (3); + Ast := Ast.Sequence (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - if Ast.List.Length /= 2 then - raise Argument_Error with "macroexpand: expects 1 argument"; - end if; + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); Macroexpanding := True; - Ast := Ast.List.Element (2); + Ast := Ast.Sequence (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quasiquote: expects 1 argument"; - end if; - return Quasiquote (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quote: expects 1 argument"; - end if; - return Ast.List.Element (2); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Ast.Sequence (2); elsif First.Symbol = Symbols.Names.Try then - if Ast.List.Length = 2 then - Ast := Ast.List.Element (2); + if Ast.Sequence.Length = 2 then + Ast := Ast.Sequence (2); goto Restart; - elsif Ast.List.Length /= 3 then - raise Argument_Error with "try*: expects 1 or 2 arguments"; - elsif Ast.List.Element (3).Kind /= Kind_List then - raise Argument_Error with "try*: argument 2 must be a list"; end if; + Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters"); + Err.Check (Ast.Sequence (3).Kind = Kind_List, + "parameter 2 must be a list"); declare - A3 : constant Lists.Ptr := Ast.List.Element (3).List; + A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence; begin - if A3.Length /= 3 then - raise Argument_Error with "try*: arg 2 must have 3 elements"; - elsif A3.Element (1).Kind /= Kind_Symbol - or else A3.Element (1).Symbol /= Symbols.Names.Catch - then - raise Argument_Error with "try*: arg 2 must be 'catch*'"; - elsif A3.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "catch*: expects a symbol"; - end if; + Err.Check (A3.Length = 3, "length of parameter 2 must be 3"); + Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch), + "parameter 3 must start with 'catch*'"); + Err.Check (A3 (2).Kind = Kind_Symbol, + "a symbol must follow catch*"); begin - return Eval (Ast.List.Element (2), Env); + return Eval (Ast.Sequence (2), Env); exception - when E : Reader.Empty_Source | Argument_Error - | Reader.Reader_Error | Envs.Unknown_Key => - Env.Replace_With_Sub; - Env.Set (A3.Element (2).Symbol, - Mal.T'(Kind_String, ASU.To_Unbounded_String - (Ada.Exceptions.Exception_Message (E)))); - Ast := A3.Element (3); - goto Restart; - when Core.Exception_Throwed => - Env.Replace_With_Sub; - Env.Set (A3.Element (2).Symbol, Core.Last_Exception); - Ast := A3.Element (3); - goto Restart; - -- Other exceptions are unexpected. + when Err.Error => + Env.Replace_With_Sub; + Env.Set (A3 (2).Symbol, Err.Data); + Ast := A3 (3); + goto Restart; end; end; else @@ -240,13 +203,12 @@ procedure Step9_Try is -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. null; - when Kind_List | Kind_Vector | Kind_Map => + when Kind_Sequence | Kind_Map => -- Lists are definitely worth a recursion, and the two other -- cases should be rare (they will report an error later). First := Eval (First, Env); @@ -258,19 +220,19 @@ procedure Step9_Try is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; Env.Replace_With_Sub (Outer => First.Fn.Env, Binds => First.Fn.Params, @@ -279,33 +241,49 @@ procedure Step9_Try is goto Restart; end; when Kind_Macro => - if Macroexpanding then - -- Evaluate the macro with tail call optimization. - Env.Replace_With_Sub_Macro (Binds => First.Fn.Params, - Exprs => Ast.List); - Ast := First.Fn.Ast; - goto Restart; - else - -- Evaluate the macro normally. - Ast := Eval (Ast0 => First.Fn.Ast, - Env0 => Envs.Sub (Outer => Env, - Binds => First.Fn.Params, - Exprs => Ast.List)); - -- Then evaluate the result with TCO. - goto Restart; - end if; + declare + Args : constant Mal.T_Array + := Ast.Sequence.Tail (Ast.Sequence.Length - 1); + begin + if Macroexpanding then + -- Evaluate the macro with tail call optimization. + Env.Replace_With_Sub (Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; + goto Restart; + else + -- Evaluate the macro normally. + Ast := Eval (First.Fn.Ast, Envs.Sub + (Outer => Env, + Binds => First.Fn.Params, + Exprs => Args)); + -- Then evaluate the result with TCO. + goto Restart; + end if; + end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function or macro"); end case; + exception + when Err.Error => + if Macroexpanding then + Err.Add_Trace_Line ("macroexpand", Ast); + else + Err.Add_Trace_Line ("eval", Ast); + end if; + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin @@ -316,71 +294,70 @@ procedure Step9_Try is Env : in Envs.Ptr) return Mal.T is - use type Symbols.Ptr; - - function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is -- The final return concatenates these lists. R : Mal.T_Array (1 .. List.Length); begin for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).List.Length - and then R (I).List.Element (1).Kind = Kind_Symbol - and then R (I).List.Element (1).Symbol - = Symbols.Names.Splice_Unquote + R (I) := List (I); + if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length + and then R (I).Sequence (1) = (Kind_Symbol, + Symbols.Names.Splice_Unquote) then - if R (I).List.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 arg"; - end if; - R (I) := Eval (R (I).List.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; - end if; + Err.Check (R (I).Sequence.Length = 2, + "splice-unquote expects 1 parameter"); + R (I) := Eval (@.Sequence (2), Env); + Err.Check (R (I).Kind = Kind_List, + "splice_unquote expects a list"); else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), - Env))); + R (I) := Sequences.List + (Mal.T_Array'(1 => Quasiquote (@, Env))); end if; end loop; - return Lists.Concat (R); + return Sequences.Concat (R); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); when Kind_List => - if 0 < Ast.List.Length - and then Ast.List.Element (1).Kind = Kind_Symbol - and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.Sequence.Length + and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) then - if 2 < Ast.List.Length then - raise Argument_Error with "unquote: expects 1 argument"; - end if; - return Eval (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence (2), Env); else - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); end if; when others => return Ast; end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; end Quasiquote; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" & "(defmacro! cond (fn* (& xs)" @@ -393,31 +370,28 @@ procedure Step9_Try is & " (if (empty? xs) nil" & " (if (= 1 (count xs)) (first xs)" & " `(let* (or_FIXME ~(first xs))" - & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))" - & ")"; + & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"; Repl : Envs.Ptr renames Envs.Repl; - use Ada.Command_Line; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); -- Define ARGV from command line arguments. declare + use Ada.Command_Line; Args : Mal.T_Array (2 .. Argument_Count); begin for I in Args'Range loop Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); end; -- Script? - if 0 < Argument_Count then - Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); + if 0 < Ada.Command_Line.Argument_Count then + Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); else loop begin @@ -425,17 +399,20 @@ begin exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - when Core.Exception_Throwed => - Ada.Text_IO.Put ("User exception: "); - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str - (Core.Last_Exception)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end Step9_Try; diff --git a/ada.2/stepa_mal.adb b/ada.2/stepa_mal.adb index d3b44b0d95..9c24a4b6aa 100644 --- a/ada.2/stepa_mal.adb +++ b/ada.2/stepa_mal.adb @@ -1,26 +1,36 @@ with Ada.Command_Line; -with Ada.Exceptions; +with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; with Core; with Envs; +with Err; with Eval_Cb; with Printer; with Reader; with Readline; -with Types.Functions; -with Types.Lists; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; +with Types.Sequences; with Types.Symbols.Names; procedure StepA_Mal is - package ASU renames Ada.Strings.Unbounded; + Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); + Dbgenv0 : constant Boolean + := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); + Dbgeval : constant Boolean + := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + use Types; + use type Mal.T; + package ASU renames Ada.Strings.Unbounded; - function Read return Mal.T with Inline; + function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; @@ -36,13 +46,12 @@ procedure StepA_Mal is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval); - function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); + function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); + function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); - -- Procedural form of Eval. - -- Convenient when the result of eval is of no interest. - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) with Inline; + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. ---------------------------------------------------------------------- @@ -58,181 +67,135 @@ procedure StepA_Mal is First : Mal.T; begin <> - -- Ada.Text_IO.New_Line; - -- Ada.Text_IO.Put ("EVAL: "); - -- Print (Ast); - -- Envs.Dump_Stack; + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + if Dbgenv0 then + Envs.Dump_Stack (Dbgenv1); + end if; + end if; case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => return Env.Get (Ast.Symbol); when Kind_Map => return Eval_Map_Elts (Ast.Map, Env); when Kind_Vector => - return (Kind_Vector, Eval_List_Elts (Ast.List, Env)); + return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); when Kind_List => null; end case; -- Ast is a list. - if Ast.List.Length = 0 then + if Ast.Sequence.Length = 0 then return Ast; end if; - First := Ast.List.Element (1); + First := Ast.Sequence (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - if Ast.List.Length /= 3 then - raise Argument_Error with "def!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "def!: arg 1 must be a symbol"; - end if; - return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do - Env.Set (Ast.List.Element (2).Symbol, R); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); + return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do + Env.Set (Ast.Sequence (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - if Ast.List.Length /= 3 then - raise Argument_Error with "defmacro!: expects 2 arguments"; - elsif Ast.List.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "defmacro!: arg 1 must be a symbol"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + "parameter 1 must be a symbol"); declare - F : constant Mal.T := Eval (Ast.List.Element (3), Env); + F : constant Mal.T := Eval (Ast.Sequence (3), Env); begin - if F.Kind /= Kind_Function then - raise Argument_Error with "defmacro!: expects a function"; - end if; + Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function"); return R : constant Mal.T := F.Fn.New_Macro do - Env.Set (Ast.List.Element (2).Symbol, R); + Env.Set (Ast.Sequence (2).Symbol, R); end return; end; - elsif First.Symbol = Symbols.Names.Mal_Do then - if Ast.List.Length = 1 then - raise Argument_Error with "do: expects at least 1 argument"; - end if; - for I in 2 .. Ast.List.Length - 1 loop - Eval_P (Ast.List.Element (I), Env); - end loop; - Ast := Ast.List.Element (Ast.List.Length); - goto Restart; + -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - if Ast.List.Length /= 3 then - raise Argument_Error with "fn*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "fn*: arg 1 must be a list or vector"; - elsif (for some F in 1 .. Ast.List.Element (2).List.Length => - Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol) - then - raise Argument_Error with "fn*: arg 2 must contain symbols"; - end if; - return Functions.New_Function (Params => Ast.List.Element (2).List, - Ast => Ast.List.Element (3), - Env => Env.New_Closure); + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); + return Fns.New_Function (Params => Ast.Sequence (2).Sequence, + Ast => Ast.Sequence (3), + Env => Env.New_Closure); elsif First.Symbol = Symbols.Names.Mal_If then - if Ast.List.Length not in 3 .. 4 then - raise Argument_Error with "if: expects 2 or 3 arguments"; - end if; + Err.Check (Ast.Sequence.Length in 3 .. 4, + "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.List.Element (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence (2), Env); begin - if (case Test.Kind is - when Kind_Nil => False, - when Kind_Boolean => Test.Ada_Boolean, - when others => True) - then - Ast := Ast.List.Element (3); + if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then + Ast := Ast.Sequence (3); goto Restart; - elsif Ast.List.Length = 3 then + elsif Ast.Sequence.Length = 3 then return Mal.Nil; else - Ast := Ast.List.Element (4); + Ast := Ast.Sequence (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - if Ast.List.Length /= 3 then - raise Argument_Error with "let*: expects 3 arguments"; - elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "let*: expects a list or vector"; - end if; + Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + "parameter 1 must be a sequence"); declare - Bindings : constant Lists.Ptr := Ast.List.Element (2).List; + Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; begin - if Bindings.Length mod 2 /= 0 then - raise Argument_Error with "let*: odd number of bindings"; - end if; + Err.Check (Bindings.Length mod 2 = 0, + "parameter 1 must have an even length"); Env.Replace_With_Sub; for I in 1 .. Bindings.Length / 2 loop - if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then - raise Argument_Error with "let*: keys must be symbols"; - end if; - Env.Set (Bindings.Element (2 * I - 1).Symbol, - Eval (Bindings.Element (2 * I), Env)); + Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + "binding keys must be symbols"); + Env.Set (Bindings (2 * I - 1).Symbol, + Eval (Bindings (2 * I), Env)); end loop; - Ast := Ast.List.Element (3); + Ast := Ast.Sequence (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - if Ast.List.Length /= 2 then - raise Argument_Error with "macroexpand: expects 1 argument"; - end if; + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); Macroexpanding := True; - Ast := Ast.List.Element (2); + Ast := Ast.Sequence (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quasiquote: expects 1 argument"; - end if; - return Quasiquote (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence (2), Env); elsif First.Symbol = Symbols.Names.Quote then - if Ast.List.Length /= 2 then - raise Argument_Error with "quote: expects 1 argument"; - end if; - return Ast.List.Element (2); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Ast.Sequence (2); elsif First.Symbol = Symbols.Names.Try then - if Ast.List.Length = 2 then - Ast := Ast.List.Element (2); + if Ast.Sequence.Length = 2 then + Ast := Ast.Sequence (2); goto Restart; - elsif Ast.List.Length /= 3 then - raise Argument_Error with "try*: expects 1 or 2 arguments"; - elsif Ast.List.Element (3).Kind /= Kind_List then - raise Argument_Error with "try*: argument 2 must be a list"; end if; + Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters"); + Err.Check (Ast.Sequence (3).Kind = Kind_List, + "parameter 2 must be a list"); declare - A3 : constant Lists.Ptr := Ast.List.Element (3).List; + A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence; begin - if A3.Length /= 3 then - raise Argument_Error with "try*: arg 2 must have 3 elements"; - elsif A3.Element (1).Kind /= Kind_Symbol - or else A3.Element (1).Symbol /= Symbols.Names.Catch - then - raise Argument_Error with "try*: arg 2 must be 'catch*'"; - elsif A3.Element (2).Kind /= Kind_Symbol then - raise Argument_Error with "catch*: expects a symbol"; - end if; + Err.Check (A3.Length = 3, "length of parameter 2 must be 3"); + Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch), + "parameter 3 must start with 'catch*'"); + Err.Check (A3 (2).Kind = Kind_Symbol, + "a symbol must follow catch*"); begin - return Eval (Ast.List.Element (2), Env); + return Eval (Ast.Sequence (2), Env); exception - when E : Reader.Empty_Source | Argument_Error - | Reader.Reader_Error | Envs.Unknown_Key => - Env.Replace_With_Sub; - Env.Set (A3.Element (2).Symbol, - Mal.T'(Kind_String, ASU.To_Unbounded_String - (Ada.Exceptions.Exception_Message (E)))); - Ast := A3.Element (3); - goto Restart; - when Core.Exception_Throwed => - Env.Replace_With_Sub; - Env.Set (A3.Element (2).Symbol, Core.Last_Exception); - Ast := A3.Element (3); - goto Restart; - -- Other exceptions are unexpected. + when Err.Error => + Env.Replace_With_Sub; + Env.Set (A3 (2).Symbol, Err.Data); + Ast := A3 (3); + goto Restart; end; end; else @@ -240,13 +203,12 @@ procedure StepA_Mal is -- except that we already know enough to spare a recursive call. First := Env.Get (First.Symbol); end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String - | Kind_Keyword | Kind_Macro | Kind_Function - | Kind_Builtin_With_Meta | Kind_Builtin => + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key + | Kind_Macro | Kind_Function => -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. null; - when Kind_List | Kind_Vector | Kind_Map => + when Kind_Sequence | Kind_Map => -- Lists are definitely worth a recursion, and the two other -- cases should be rare (they will report an error later). First := Eval (First, Env); @@ -258,28 +220,28 @@ procedure StepA_Mal is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Builtin_With_Meta => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; return First.Builtin_With_Meta.Builtin.all (Args); end; - when Kind_Function => + when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.List.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.List.Element (I), Env); + Args (I) := Eval (Ast.Sequence (I), Env); end loop; Env.Replace_With_Sub (Outer => First.Fn.Env, Binds => First.Fn.Params, @@ -288,33 +250,49 @@ procedure StepA_Mal is goto Restart; end; when Kind_Macro => - if Macroexpanding then - -- Evaluate the macro with tail call optimization. - Env.Replace_With_Sub_Macro (Binds => First.Fn.Params, - Exprs => Ast.List); - Ast := First.Fn.Ast; - goto Restart; - else - -- Evaluate the macro normally. - Ast := Eval (Ast0 => First.Fn.Ast, - Env0 => Envs.Sub (Outer => Env, - Binds => First.Fn.Params, - Exprs => Ast.List)); - -- Then evaluate the result with TCO. - goto Restart; - end if; + declare + Args : constant Mal.T_Array + := Ast.Sequence.Tail (Ast.Sequence.Length - 1); + begin + if Macroexpanding then + -- Evaluate the macro with tail call optimization. + Env.Replace_With_Sub (Binds => First.Fn.Params, + Exprs => Args); + Ast := First.Fn.Ast; + goto Restart; + else + -- Evaluate the macro normally. + Ast := Eval (First.Fn.Ast, Envs.Sub + (Outer => Env, + Binds => First.Fn.Params, + Exprs => Args)); + -- Then evaluate the result with TCO. + goto Restart; + end if; + end; when others => - raise Argument_Error with "cannot call " & Printer.Img (First); + Err.Raise_With ("first element must be a function or macro"); end case; + exception + when Err.Error => + if Macroexpanding then + Err.Add_Trace_Line ("macroexpand", Ast); + else + Err.Add_Trace_Line ("eval", Ast); + end if; + raise; end Eval; - procedure Eval_P (Ast : in Mal.T; - Env : in Envs.Ptr) + procedure Exec (Script : in String; + Env : in Envs.Ptr) is - Result : constant Mal.T := Eval (Ast, Env); + Result : Mal.T; begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; pragma Unreferenced (Result); - end Eval_P; + end Exec; procedure Print (Ast : in Mal.T) is begin @@ -325,71 +303,70 @@ procedure StepA_Mal is Env : in Envs.Ptr) return Mal.T is - use type Symbols.Ptr; - - function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline; + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Lists.Ptr) return Mal.T is + function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is -- The final return concatenates these lists. R : Mal.T_Array (1 .. List.Length); begin for I in R'Range loop - R (I) := List.Element (I); - if R (I).Kind in Kind_List | Kind_Vector - and then 0 < R (I).List.Length - and then R (I).List.Element (1).Kind = Kind_Symbol - and then R (I).List.Element (1).Symbol - = Symbols.Names.Splice_Unquote + R (I) := List (I); + if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length + and then R (I).Sequence (1) = (Kind_Symbol, + Symbols.Names.Splice_Unquote) then - if R (I).List.Length /= 2 then - raise Argument_Error with "splice-unquote: expects 1 arg"; - end if; - R (I) := Eval (R (I).List.Element (2), Env); - if R (I).Kind /= Kind_List then - raise Argument_Error with "splice-unquote: expects a list"; - end if; + Err.Check (R (I).Sequence.Length = 2, + "splice-unquote expects 1 parameter"); + R (I) := Eval (@.Sequence (2), Env); + Err.Check (R (I).Kind = Kind_List, + "splice_unquote expects a list"); else - R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), - Env))); + R (I) := Sequences.List + (Mal.T_Array'(1 => Quasiquote (@, Env))); end if; end loop; - return Lists.Concat (R); + return Sequences.Concat (R); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); when Kind_List => - if 0 < Ast.List.Length - and then Ast.List.Element (1).Kind = Kind_Symbol - and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote + if 0 < Ast.Sequence.Length + and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) then - if 2 < Ast.List.Length then - raise Argument_Error with "unquote: expects 1 argument"; - end if; - return Eval (Ast.List.Element (2), Env); + Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence (2), Env); else - return Quasiquote_List (Ast.List); + return Quasiquote_List (Ast.Sequence); end if; when others => return Ast; end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; end Quasiquote; - function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> "))); + function Read return Mal.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); procedure Rep (Env : in Envs.Ptr) is begin - Print (Eval (Read, Env)); + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; end Rep; ---------------------------------------------------------------------- - Startup : constant String := "(do " - & "(def! not (fn* (a) (if a false true)))" + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" & "(defmacro! cond (fn* (& xs)" @@ -407,51 +384,50 @@ procedure StepA_Mal is & " (let* (condvar (gensym))" & " `(let* (~condvar ~(first xs))" & " (if ~condvar ~condvar (or ~@(rest xs)))))))))" - & "(def! *host-language* ""ada2"")" - & ")"; + & "(def! *host-language* ""ada.2"")"; Repl : Envs.Ptr renames Envs.Repl; - use Ada.Command_Line; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - for Binding of Core.Ns loop - Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin)); - end loop; + Core.NS_Add_To_Repl; -- Native startup procedure. - Eval_P (Reader.Read_Str (Startup), Repl); + Exec (Startup, Repl); -- Define ARGV from command line arguments. declare + use Ada.Command_Line; Args : Mal.T_Array (2 .. Argument_Count); begin for I in Args'Range loop Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args)); + Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); end; -- Script? - if 0 < Argument_Count then - Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl); + if 0 < Ada.Command_Line.Argument_Count then + Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); else - Eval_P (Reader.Read_Str - ("(println (str ""Mal ["" *host-language* ""]""))"), Repl); + Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl); loop begin Rep (Repl); exception when Readline.End_Of_File => exit; - when Reader.Empty_Source => - null; - when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - when Core.Exception_Throwed => - Ada.Text_IO.Put ("User exception: "); - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str - (Core.Last_Exception)); - -- Other exceptions are unexpected. + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; + -- Other exceptions are really unexpected. end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. + Err.Data := Mal.Nil; -- Remove references to other packages + pragma Debug (Envs.Clear_And_Check_Allocations); + pragma Debug (Atoms.Check_Allocations); + pragma Debug (Builtins.Check_Allocations); + pragma Debug (Fns.Check_Allocations); + pragma Debug (Maps.Check_Allocations); + pragma Debug (Sequences.Check_Allocations); + pragma Debug (Symbols.Check_Allocations); end StepA_Mal; diff --git a/ada.2/types-atoms.adb b/ada.2/types-atoms.adb index 952504a1e5..54591a5922 100644 --- a/ada.2/types-atoms.adb +++ b/ada.2/types-atoms.adb @@ -1,6 +1,6 @@ with Ada.Unchecked_Deallocation; -with Printer; +with Err; with Types.Mal; package body Types.Atoms is @@ -11,29 +11,35 @@ package body Types.Atoms is end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + Allocations : Natural := 0; ---------------------------------------------------------------------- procedure Adjust (Object : in out Ptr) is begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + Object.Ref.all.Refs := @ + 1; end Adjust; - function Atom (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "atom: expects 1 argument" - else - (Kind_Atom, (Ada.Finalization.Controlled with new Rec' - (Refs => 1, - Data => Args (Args'First))))); + function Atom (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + Allocations := Allocations + 1; + return (Kind_Atom, (Ada.Finalization.Controlled with new Rec' + (Refs => 1, + Data => Args (Args'First)))); + end Atom; + + procedure Check_Allocations is + begin + pragma Assert (Allocations = 0); + end Check_Allocations; - function Deref (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "deref: expects 1 argument" - elsif Args (Args'First).Kind /= Kind_Atom then - raise Argument_Error with "deref: expects an atom" - else - Args (Args'First).Atom.Ref.all.Data); + function Deref (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom"); + return Args (Args'First).Atom.Ref.all.Data; + end Deref; function Deref (Item : in Ptr) return Mal.T is (Item.Ref.all.Data); @@ -41,10 +47,11 @@ package body Types.Atoms is procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + Object.Ref.all.Refs := @ - 1; if 0 < Object.Ref.all.Refs then Object.Ref := null; else + Allocations := Allocations - 1; Free (Object.Ref); end if; end if; @@ -52,22 +59,18 @@ package body Types.Atoms is function Reset (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 2 then - raise Argument_Error with "reset: expects 2 arguments"; - elsif Args (Args'First).Kind /= Kind_Atom then - raise Argument_Error with "reset: first argument must be an atom"; - end if; + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'First).Kind = Kind_Atom, + "parameter 1 must be an atom"); Args (Args'First).Atom.Ref.all.Data := Args (Args'Last); return Args (Args'Last); end Reset; function Swap (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length < 2 then - raise Argument_Error with "swap!: expects at least 2 arguments"; - elsif Args (Args'First).Kind /= Kind_Atom then - raise Argument_Error with "swap!: first argument must be an atom"; - end if; + Err.Check (2 <= Args'Length, "expected at least 2 parameters"); + Err.Check (Args (Args'First).Kind = Kind_Atom, + "parameter 1 must be an atom"); declare use type Mal.T_Array; X : Mal.T renames Args (Args'First).Atom.Ref.all.Data; @@ -79,11 +82,10 @@ package body Types.Atoms is X := F.Builtin.all (A); when Kind_Builtin_With_Meta => X := F.Builtin_With_Meta.Builtin.all (A); - when Kind_Function => + when Kind_Fn => X := F.Fn.Apply (A); when others => - raise Argument_Error - with "swap!: cannot call " & Printer.Img (F); + Err.Raise_With ("parameter 2 must be a function"); end case; return X; end; diff --git a/ada.2/types-atoms.ads b/ada.2/types-atoms.ads index 057ef036cb..c9a4f09a57 100644 --- a/ada.2/types-atoms.ads +++ b/ada.2/types-atoms.ads @@ -15,6 +15,9 @@ package Types.Atoms is -- Helper for print. function Deref (Item : in Ptr) return Mal.T with Inline; + -- Debug. + procedure Check_Allocations; + private type Rec; diff --git a/ada.2/types-builtins.adb b/ada.2/types-builtins.adb index 450574795e..9506aa89b0 100644 --- a/ada.2/types-builtins.adb +++ b/ada.2/types-builtins.adb @@ -11,24 +11,31 @@ package body Types.Builtins is end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + Allocations : Natural := 0; ---------------------------------------------------------------------- procedure Adjust (Object : in out Ptr) is begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + Object.Ref.all.Refs := @ + 1; end Adjust; function Builtin (Item : in Ptr) return Mal.Builtin_Ptr is (Item.Ref.all.Builtin); + procedure Check_Allocations is + begin + pragma Assert (Allocations = 0); + end Check_Allocations; + procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + Object.Ref.all.Refs := @ - 1; if 0 < Object.Ref.all.Refs then Object.Ref := null; else + Allocations := Allocations - 1; Free (Object.Ref); end if; end if; @@ -38,11 +45,14 @@ package body Types.Builtins is is (Item.Ref.all.Meta); function With_Meta (Builtin : in Mal.Builtin_Ptr; - Metadata : in Mal.T) return Mal.T - is (Kind_Builtin_With_Meta, (Ada.Finalization.Controlled with new Rec' - (Builtin => Builtin, - Meta => Metadata, - Refs => 1))); + Metadata : in Mal.T) return Mal.T is + begin + Allocations := Allocations + 1; + return (Kind_Builtin_With_Meta, + (Ada.Finalization.Controlled with new Rec'(Builtin => Builtin, + Meta => Metadata, + Refs => 1))); + end With_Meta; function With_Meta (Item : in Ptr; Metadata : in Mal.T) return Mal.T diff --git a/ada.2/types-builtins.ads b/ada.2/types-builtins.ads index e5d99fbdc7..a5a4af9901 100644 --- a/ada.2/types-builtins.ads +++ b/ada.2/types-builtins.ads @@ -18,6 +18,8 @@ package Types.Builtins is function Meta (Item : in Ptr) return Mal.T with Inline; function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline; + procedure Check_Allocations; + private type Rec; diff --git a/ada.2/types-functions.adb b/ada.2/types-fns.adb similarity index 57% rename from ada.2/types-functions.adb rename to ada.2/types-fns.adb index 2446849341..d96790970d 100644 --- a/ada.2/types-functions.adb +++ b/ada.2/types-fns.adb @@ -1,12 +1,13 @@ with Ada.Unchecked_Deallocation; with Envs; +with Err; with Eval_Cb; -with Types.Lists; with Types.Mal; +with Types.Sequences; with Types.Symbols; -package body Types.Functions is +package body Types.Fns is subtype AFC is Ada.Finalization.Controlled; use type Envs.Closure_Ptr; @@ -20,12 +21,13 @@ package body Types.Functions is end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + Allocations : Natural := 0; ---------------------------------------------------------------------- procedure Adjust (Object : in out Ptr) is begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + Object.Ref.all.Refs := @ + 1; end Adjust; function Apply (Item : in Ptr; @@ -41,6 +43,11 @@ package body Types.Functions is function Ast (Item : in Ptr) return Mal.T is (Item.Ref.all.Ast); + procedure Check_Allocations is + begin + pragma Assert (Allocations = 0); + end Check_Allocations; + function Env (Item : in Ptr) return Envs.Closure_Ptr is begin pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); @@ -50,10 +57,11 @@ package body Types.Functions is procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + Object.Ref.all.Refs := @ - 1; if 0 < Object.Ref.all.Refs then Object.Ref := null; else + Allocations := Allocations - 1; Free (Object.Ref); end if; end if; @@ -68,37 +76,43 @@ package body Types.Functions is return Item.Ref.all.Meta; end Meta; - function New_Function (Params : in Lists.Ptr; + function New_Function (Params : in Sequences.Ptr; Ast : in Mal.T; Env : in Envs.Closure_Ptr) return Mal.T is - Ref : constant Acc := new Rec'(Params_Last => Params.Length, - Ast => Ast, - Env => Env, - others => <>); + Ref : Acc; begin - for I in 1 .. Params.Length loop - Ref.all.Params (I) := Params.Element (I).Symbol; - end loop; - return (Kind_Function, (AFC with Ref)); + Allocations := Allocations + 1; + -- Avoid exceptions until Ref is controlled. + Ref := new Rec'(Params_Last => Params.Length, + Ast => Ast, + Env => Env, + others => <>); + return R : constant Mal.T := (Kind_Fn, (AFC with Ref)) do + for I in 1 .. Params.Length loop + Err.Check (Params (I).Kind = Kind_Symbol, + "formal parameters must be symbols"); + Ref.all.Params (I) := Params (I).Symbol; + end loop; + end return; end New_Function; function New_Macro (Item : in Ptr) return Mal.T is - Old : Rec renames Item.Ref.all; - Ref : Acc; + -- Avoid raising an exception until Ref is controlled. + Ref : Acc := Item.Ref; begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Item.Ref; - Old.Refs := 2; - Old.Env := Envs.Null_Closure; + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Env := Envs.Null_Closure; -- Finalize the environment, it will not be used anymore. - Old.Meta := Mal.Nil; + Ref.all.Meta := Mal.Nil; else - Ref := new Rec'(Params_Last => Old.Params_Last, - Params => Old.Params, - Ast => Old.Ast, + Allocations := Allocations + 1; + Ref := new Rec'(Params_Last => Ref.all.Params_Last, + Params => Ref.all.Params, + Ast => Ref.all.Ast, others => <>); end if; return (Kind_Macro, (AFC with Ref)); @@ -107,24 +121,24 @@ package body Types.Functions is function With_Meta (Item : in Ptr; Metadata : in Mal.T) return Mal.T is - Old : Rec renames Item.Ref.all; - Ref : Acc; + -- Avoid raising an exception until Ref is controlled. + Ref : Acc := Item.Ref; begin - pragma Assert (Old.Env /= Envs.Null_Closure); - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Item.Ref; - Old.Refs := 2; - Old.Meta := Metadata; + pragma Assert (Ref.all.Env /= Envs.Null_Closure); + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Metadata; else - Ref := new Rec'(Params_Last => Old.Params_Last, - Params => Old.Params, - Ast => Old.Ast, - Env => Old.Env, + Allocations := Allocations + 1; + Ref := new Rec'(Params_Last => Ref.all.Params_Last, + Params => Ref.all.Params, + Ast => Ref.all.Ast, + Env => Ref.all.Env, Meta => Metadata, others => <>); end if; - return (Kind_Function, (AFC with Ref)); + return (Kind_Fn, (AFC with Ref)); end With_Meta; -end Types.Functions; +end Types.Fns; diff --git a/ada.2/types-functions.ads b/ada.2/types-fns.ads similarity index 86% rename from ada.2/types-functions.ads rename to ada.2/types-fns.ads index 8326245dcc..d3ba90fafc 100644 --- a/ada.2/types-functions.ads +++ b/ada.2/types-fns.ads @@ -1,19 +1,20 @@ private with Ada.Finalization; limited with Envs; -limited with Types.Lists; limited with Types.Mal; +limited with Types.Sequences; limited with Types.Symbols; -package Types.Functions is +package Types.Fns is type Ptr is tagged private; -- A pointer to an user-defined function or macro. - function New_Function (Params : in Lists.Ptr; + function New_Function (Params : in Sequences.Ptr; Ast : in Mal.T; Env : in Envs.Closure_Ptr) return Mal.T with Inline; + -- Raise an exception if Params contains something else than symbols. function New_Macro (Item : in Ptr) return Mal.T with Inline; @@ -34,6 +35,8 @@ package Types.Functions is Metadata : in Mal.T) return Mal.T with Inline; -- Fails for macros. + procedure Check_Allocations; + private type Rec; @@ -46,4 +49,4 @@ private overriding procedure Finalize (Object : in out Ptr) with Inline; pragma Finalize_Storage_Only (Ptr); -end Types.Functions; +end Types.Fns; diff --git a/ada.2/types-lists.adb b/ada.2/types-lists.adb deleted file mode 100644 index 37ce66df78..0000000000 --- a/ada.2/types-lists.adb +++ /dev/null @@ -1,313 +0,0 @@ -with Ada.Unchecked_Deallocation; - -with Printer; -with Types.Mal; - -package body Types.Lists is - - subtype AFC is Ada.Finalization.Controlled; - use type Mal.T_Array; - - type Rec (Last : Natural) is limited record - Refs : Natural := 1; - Meta : Mal.T := Mal.Nil; - Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil); - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); - - ---------------------------------------------------------------------- - - function "=" (Left, Right : in Ptr) return Boolean is - -- Should become Left.Ref.all.Data = Right.Ref.all.Data when - -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. - use type Mal.T; - L : Rec renames Left.Ref.all; - R : Rec renames Right.Ref.all; - begin - return L.Last = R.Last - and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I)); - end "="; - - function "&" (Left : in Mal.T_Array; - Right : in Ptr) return Mal.T_Array - is (Left & Right.Ref.all.Data); - - procedure Adjust (Object : in out Ptr) is - begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; - end Adjust; - - function Concat (Args : in Mal.T_Array) return Mal.T is - Sum : Natural := 0; - Ref : Acc; - begin - for Arg of Args loop - if Arg.Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "concat: expects lists or vectors"; - end if; - Sum := Sum + Arg.List.Ref.all.Last; - end loop; - Ref := new Rec (Sum); - for Arg of reverse Args loop - Ref.all.Data (Sum - Arg.List.Ref.all.Last + 1 .. Sum) - := Arg.List.Ref.all.Data; - Sum := Sum - Arg.List.Ref.all.Last; - end loop; - pragma Assert (Sum = 0); - return (Kind_List, (AFC with Ref)); - end Concat; - - function Conj (Args : in Mal.T_Array) return Mal.T is - begin - if Args'Length = 0 then - raise Argument_Error with "conj: expects at least 1 argument"; - end if; - declare - A1 : Mal.T renames Args (Args'First); - Last : constant Natural := Args'Length - 1 + A1.List.Ref.all.Last; - Ref : constant Acc := new Rec (Last); - Data : Mal.T_Array renames Ref.all.Data; - begin - case A1.Kind is - when Kind_List => - Data (Args'Length .. Ref.all.Last) := A1.List.Ref.all.Data; - for I in 1 .. Args'Length - 1 loop - Data (I) := Args (Args'Last - I + 1); - end loop; - return (Kind_List, (AFC with Ref)); - when Kind_Vector => - Data := A1.List.Ref.all.Data - & Args (Args'First + 1 .. Args'Last); - return (Kind_Vector, (AFC with Ref)); - when others => - raise Argument_Error - with "conj: first argument must be a list or vector"; - end case; - end; - end Conj; - - function Cons (Args : in Mal.T_Array) return Mal.T is - begin - if Args'Length /= 2 then - raise Argument_Error with "cons: expects 2 arguments"; - elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "cons: last arg must be a list or vector"; - end if; - return (Kind_List, (AFC with new Rec' - (Last => 1 + Args (Args'Last).List.Ref.all.Last, - Data => Args (Args'First) & Args (Args'Last).List.Ref.all.Data, - others => <>))); - end Cons; - - function Count (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "count: expects 1 argument" - else - (case Args (Args'First).Kind is - when Kind_Nil => - (Kind_Number, 0), - when Kind_List | Kind_Vector => - (Kind_Number, Args (Args'First).List.Ref.all.Last), - when others => - raise Argument_Error with "count: expects a list or vector")); - - function Element (Container : in Ptr; - Index : in Positive) return Mal.T - is (Container.Ref.all.Data (Index)); - - procedure Finalize (Object : in out Ptr) is - begin - if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := Object.Ref.all.Refs - 1; - if 0 < Object.Ref.all.Refs then - Object.Ref := null; - else - Free (Object.Ref); - end if; - end if; - end Finalize; - - function First (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "first: expects 1 argument" - else - (case Args (Args'First).Kind is - when Kind_Nil => - Mal.Nil, - when Kind_List | Kind_Vector => - (if Args (Args'First).List.Ref.all.Last = 0 then - Mal.Nil - else - Args (Args'First).List.Ref.all.Data (1)), - when others => - raise Argument_Error with "first: expects a list or vector")); - - function Generic_Eval (Container : in Ptr; - Env : in Env_Type) - return Ptr - is - -- Take care that automatic deallocation happens if an - -- exception is propagated by user code. - Old : Rec renames Container.Ref.all; - Ref : Acc; - begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Container.Ref; - Old.Refs := 2; - Old.Meta := Mal.Nil; - else - Ref := new Rec (Old.Last); - end if; - return R : constant Ptr := (AFC with Ref) do - for I in Old.Data'Range loop - Ref.all.Data (I) := Eval (Old.Data (I), Env); - end loop; - end return; - end Generic_Eval; - - function Is_Empty (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 1 then - raise Argument_Error with "empty?: expects 1 argument" - else - (case Args (Args'First).Kind is - when Kind_List | Kind_Vector => - (Kind_Boolean, Args (Args'First).List.Ref.all.Last = 0), - when others => - raise Argument_Error with "empty?: expects a list or vector")); - - function Length (Source : in Ptr) return Natural - is (Source.Ref.all.Last); - - function List (Args : in Mal.T_Array) return Mal.T - is (Kind_List, (AFC with new Rec'(Data => Args, - Last => Args'Length, - others => <>))); - - function Map (Args : in Mal.T_Array) return Mal.T is - begin - if Args'Length /= 2 then - raise Argument_Error with "map: expects 2 arguments"; - elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then - raise Argument_Error with "map: argument 2 must be a list or vector"; - end if; - declare - F : Mal.T renames Args (Args'First); - Old : Rec renames Args (Args'Last).List.Ref.all; - Ref : Acc; - begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Args (Args'Last).List.Ref; - Old.Refs := 2; - Old.Meta := Mal.Nil; - else - Ref := new Rec (Old.Last); - end if; - return R : constant Mal.T := (Kind_List, (AFC with Ref)) do - -- Now we can afford raising an exception. - case F.Kind is - when Kind_Builtin => - for I in Old.Data'Range loop - Ref.all.Data (I) := F.Builtin.all (Old.Data (I .. I)); - end loop; - when Kind_Builtin_With_Meta => - for I in Old.Data'Range loop - Ref.all.Data (I) - := F.Builtin_With_Meta.Builtin.all (Old.Data (I .. I)); - end loop; - when Kind_Function => - for I in Old.Data'Range loop - Ref.all.Data (I) := F.Fn.Apply (Old.Data (I .. I)); - end loop; - when others => - raise Argument_Error with "map: cannot call " & Printer.Img (F); - end case; - end return; - end; - end Map; - - function Meta (Item : in Ptr) return Mal.T - is (Item.Ref.all.Meta); - - function Nth (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 then - raise Argument_Error with "nth: expects 2 arguments" - else - (case Args (Args'First).Kind is - when Kind_List | Kind_Vector => - (if Args (Args'First + 1).Kind /= Kind_Number then - raise Argument_Error with "nth: last arg must be a number" - elsif 1 + Args (Args'Last).Number - in Args (Args'First).List.Ref.all.Data'Range - then - Args (Args'First).List.Ref.all.Data - (1 + Args (Args'Last).Number) - else - raise Argument_Error with "nth: index out of bounds"), - when others => - raise Argument_Error with "nth: expects a list or vector")); - - function Rest (Args : in Mal.T_Array) return Mal.T is - begin - if Args'Length /= 1 then - raise Argument_Error with "rest: expects 1 argument"; - end if; - declare - A1 : Mal.T renames Args (Args'First); - Ref : Acc; - begin - case A1.Kind is - when Kind_Nil => - Ref := new Rec (0); - when Kind_List | Kind_Vector => - if A1.List.Ref.all.Last = 0 then - Ref := new Rec (0); - else - Ref := new Rec' - (Last => A1.List.Ref.all.Last - 1, - Data => A1.List.Ref.all.Data (2 .. A1.List.Ref.all.Last), - others => <>); - end if; - when others => - raise Argument_Error with "rest: expects a list or vector"; - end case; - return (Kind_List, (AFC with Ref)); - end; - end Rest; - - function Slice (Item : in Ptr; - Start : in Positive) - return Mal.T - is (Kind_List, (AFC with new Rec' - (Last => Item.Ref.all.Last - Start + 1, - Data => Item.Ref.all.Data (Start .. Item.Ref.all.Last), - others => <>))); - - function Vector (Args : in Mal.T_Array) return Mal.T - is (Kind_Vector, (AFC with new Rec'(Data => Args, - Last => Args'Length, - others => <>))); - - function With_Meta (Data : in Ptr; - Metadata : in Mal.T) return Ptr - is - Old : Rec renames Data.Ref.all; - Ref : Acc; - begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Data.Ref; - Old.Refs := 2; - Old.Meta := Metadata; - else - Ref := new Rec'(Last => Old.Last, - Data => Old.Data, - Meta => Metadata, - others => <>); - end if; - return (AFC with Ref); - end With_Meta; - -end Types.Lists; diff --git a/ada.2/types-mal.adb b/ada.2/types-mal.adb index 93c41409dd..47bcc9059f 100644 --- a/ada.2/types-mal.adb +++ b/ada.2/types-mal.adb @@ -1,8 +1,8 @@ package body Types.Mal is use type Ada.Strings.Unbounded.Unbounded_String; - use type Lists.Ptr; use type Maps.Ptr; + use type Sequences.Ptr; use type Symbols.Ptr; ---------------------------------------------------------------------- @@ -18,13 +18,14 @@ package body Types.Mal is Right.Kind = Kind_Number and then Left.Number = Right.Number, when Kind_Symbol => Right.Kind = Kind_Symbol and then Left.Symbol = Right.Symbol, - -- Here is the part that differs from the predefined equality. - when Kind_Keyword | Kind_String => + when Kind_Key => Right.Kind = Left.Kind and then Left.S = Right.S, - when Kind_List | Kind_Vector => - Right.Kind in Kind_List | Kind_Vector and then Left.List = Right.List, + -- Here comes the part that differs from the predefined equality. + when Kind_Sequence => + Right.Kind in Kind_Sequence and then Left.Sequence = Right.Sequence, when Kind_Map => Right.Kind = Kind_Map and then Left.Map = Right.Map, + -- Also, comparing functions is an interesting problem. when others => False); diff --git a/ada.2/types-mal.ads b/ada.2/types-mal.ads index 955d7a44e3..33f5a2c813 100644 --- a/ada.2/types-mal.ads +++ b/ada.2/types-mal.ads @@ -2,9 +2,9 @@ with Ada.Strings.Unbounded; with Types.Atoms; with Types.Builtins; -with Types.Functions; -with Types.Lists; +with Types.Fns; with Types.Maps; +with Types.Sequences; with Types.Symbols; package Types.Mal is @@ -60,20 +60,20 @@ package Types.Mal is Number : Integer; when Kind_Atom => Atom : Atoms.Ptr; - when Kind_Keyword | Kind_String => + when Kind_Key => S : Ada.Strings.Unbounded.Unbounded_String; when Kind_Symbol => Symbol : Symbols.Ptr; - when Kind_List | Kind_Vector => - List : Lists.Ptr; + when Kind_Sequence => + Sequence : Sequences.Ptr; when Kind_Map => Map : Maps.Ptr; when Kind_Builtin => Builtin : Builtin_Ptr; when Kind_Builtin_With_Meta => Builtin_With_Meta : Builtins.Ptr; - when Kind_Function | Kind_Macro => - Fn : Functions.Ptr; + when Kind_Fn | Kind_Macro => + Fn : Fns.Ptr; end case; end record; diff --git a/ada.2/types-maps.adb b/ada.2/types-maps.adb index 6e70d5929a..f56ae48405 100644 --- a/ada.2/types-maps.adb +++ b/ada.2/types-maps.adb @@ -2,7 +2,8 @@ with Ada.Containers.Hashed_Maps; with Ada.Strings.Unbounded.Hash; with Ada.Unchecked_Deallocation; -with Types.Lists; +with Err; +with Types.Sequences; with Types.Mal; package body Types.Maps is @@ -11,7 +12,9 @@ package body Types.Maps is use type Ada.Containers.Count_Type; function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type - with Inline, Pre => Item.Kind in Kind_Keyword | Kind_String; + with Inline; + -- This function also checks the kind of the key, and raise an + -- error in case of problem. package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T, Element_Type => Mal.T, @@ -27,6 +30,7 @@ package body Types.Maps is end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + Allocations : Natural := 0; ---------------------------------------------------------------------- @@ -35,87 +39,82 @@ package body Types.Maps is procedure Adjust (Object : in out Ptr) is begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + Object.Ref.all.Refs := @ + 1; end Adjust; function Assoc (Args : in Mal.T_Array) return Mal.T is - Binds : constant Natural := Args'Length / 2; + Ref : Acc; begin - if Args'Length mod 2 /= 1 then - raise Argument_Error with "assoc: expects an odd argument count"; - elsif Args (Args'First).Kind /= Kind_Map then - raise Argument_Error with "assoc: first argument must be a map"; - elsif (for some I in 1 .. Binds => Args (Args'First + 2 * I - 1).Kind - not in Kind_Keyword | Kind_String) - then - raise Argument_Error with "assoc: keys must be strings or symbols"; + Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count"); + Err.Check (Args (Args'First).Kind = Kind_Map, + "parameter 1 must be a map"); + -- Avoid exceptions until Ref is controlled. + Ref := Args (Args'First).Map.Ref; + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Mal.Nil; + else + Allocations := Allocations + 1; + Ref := new Rec'(Data => Ref.all.Data, + others => <>); end if; - declare - Old : Rec renames Args (Args'First).Map.Ref.all; - Ref : Acc; - begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Args (Args'First).Map.Ref; - Old.Refs := 2; - Old.Meta := Mal.Nil; - else - Ref := new Rec'(Data => Old.Data, others => <>); - end if; - for I in 1 .. Binds loop + return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do + for I in 1 .. Args'Length / 2 loop Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1), New_Item => Args (Args'First + 2 * I)); + -- This call checks the kind of the key. end loop; - return (Kind_Map, (AFC with Ref)); - end; + end return; end Assoc; - function Contains (Args : in Mal.T_Array) return Mal.T - is (if Args'Length /= 2 then - raise Argument_Error with "contains: expects 2 arguments" - elsif Args (Args'First).Kind /= Kind_Map then - raise Argument_Error with "contains: first arguement must be a map" - else - (Kind_Boolean, - Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)))); + procedure Check_Allocations is + begin + pragma Assert (Allocations = 0); + end Check_Allocations; + + function Contains (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'First).Kind = Kind_Map, + "parameter 1 must be a map"); + return (Kind_Boolean, + Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last))); + end Contains; function Dissoc (Args : in Mal.T_Array) return Mal.T is + Ref : Acc; begin - if Args'Length = 0 then - raise Argument_Error with "dissoc: expects at least 1 argument"; - elsif Args (Args'First).Kind /= Kind_Map then - raise Argument_Error with "dissoc: first argument must be a map"; - elsif (for some I in Args'First + 1 .. Args'Last => - Args (I).Kind not in Kind_Keyword | Kind_String) - then - raise Argument_Error with "dissoc: keys must be strings or symbols"; + Err.Check (0 < Args'Length, "expected at least 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_Map, + "parameter 1 must be a map"); + -- Avoid exceptions until Ref is controlled. + Ref := Args (Args'First).Map.Ref; + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Mal.Nil; + else + Allocations := Allocations + 1; + Ref := new Rec'(Data => Ref.all.Data, + others => <>); end if; - declare - Old : Rec renames Args (Args'First).Map.Ref.all; - Ref : Acc; - begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Args (Args'First).Map.Ref; - Old.Refs := 2; - Old.Meta := Mal.Nil; - else - Ref := new Rec'(Data => Old.Data, others => <>); - end if; + return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do for I in Args'First + 1 .. Args'Last loop Ref.all.Data.Exclude (Args (I)); + -- This call checks the kind of the key. end loop; - return (Kind_Map, (AFC with Ref)); - end; + end return; end Dissoc; procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + Object.Ref.all.Refs := @ - 1; if 0 < Object.Ref.all.Refs then Object.Ref := null; else + Allocations := Allocations - 1; Free (Object.Ref); end if; end if; @@ -128,23 +127,23 @@ package body Types.Maps is -- Copy the whole hash in order to avoid recomputing the hash -- for each key, even if it implies unneeded calls to adjust -- and finalize for Mal_Type values. - Old : Rec renames Container.Ref.all; - Ref : Acc; + -- Avoid exceptions until Ref is controlled. + Ref : Acc := Container.Ref; begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Container.Ref; - Old.Refs := 2; - Old.Meta := Mal.Nil; + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Mal.Nil; else - Ref := new Rec'(Data => Container.Ref.all.Data, others => <>); + Allocations := Allocations + 1; + Ref := new Rec'(Data => Ref.all.Data, + others => <>); end if; - -- Prepare a valid structure before running user code. In case - -- an exception is raised, we want memory to be deallocated. return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do for Position in Ref.all.Data.Iterate loop Ref.all.Data.Replace_Element (Position, Eval (HM.Element (Position), Env)); + -- This call may raise exceptions. end loop; end return; end Generic_Eval; @@ -152,48 +151,48 @@ package body Types.Maps is function Get (Args : in Mal.T_Array) return Mal.T is Position : HM.Cursor; begin - if Args'Length /= 2 then - raise Argument_Error with "get: expects 2 arguments"; - elsif Args (Args'Last).Kind not in Kind_Keyword | Kind_String then - raise Argument_Error with "get: key must be a keyword or string"; - end if; + Err.Check (Args'Length = 2, "expected 2 parameters"); case Args (Args'First).Kind is when Kind_Nil => + Err.Check (Args (Args'Last).Kind in Kind_Key, + "key must be a keyword or string"); return Mal.Nil; when Kind_Map => Position := Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last)); + -- This call checks the kind of the key. if HM.Has_Element (Position) then return HM.Element (Position); else return Mal.Nil; end if; when others => - raise Argument_Error with "get: first argument must be a map"; + Err.Raise_With ("parameter 1 must be nil or a map"); end case; end Get; - function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type - is (Ada.Strings.Unbounded.Hash (Item.S)); + function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type is + begin + Err.Check (Item.Kind in Kind_Key, "keys must be keywords or strings"); + return (Ada.Strings.Unbounded.Hash (Item.S)); + end Hash; function Hash_Map (Args : in Mal.T_Array) return Mal.T is Binds : constant Natural := Args'Length / 2; Ref : Acc; begin - if Args'Length mod 2 /= 0 then - raise Argument_Error with "hash-map: expects an even argument count"; - elsif (for some I in 0 .. Binds - 1 => Args (Args'First + 2 * I).Kind - not in Kind_Keyword | Kind_String) - then - raise Argument_Error with "hash-map: keys must be strings or symbols"; - end if; + Err.Check (Args'Length mod 2 = 0, "expected an even parameter count"); + Allocations := Allocations + 1; + -- Avoid exceptions until Ref is controlled. Ref := new Rec; Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds)); - for I in 0 .. Binds - 1 loop - Ref.all.Data.Include (Key => Args (Args'First + 2 * I), - New_Item => Args (Args'First + 2 * I + 1)); - end loop; - return (Kind_Map, (AFC with Ref)); + return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do + for I in 0 .. Binds - 1 loop + Ref.all.Data.Include (Key => Args (Args'First + 2 * I), + New_Item => Args (Args'First + 2 * I + 1)); + -- This call checks the kind of the key. + end loop; + end return; end Hash_Map; procedure Iterate (Container : in Ptr) is @@ -205,11 +204,9 @@ package body Types.Maps is function Keys (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 1 then - raise Argument_Error with "keys: expects 1 argument"; - elsif Args (Args'First).Kind /= Kind_Map then - raise Argument_Error with "keys: first argument must a map"; - end if; + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_Map, + "parameter 1 must be a map"); declare A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; R : Mal.T_Array (1 .. Natural (A1.Length)); @@ -219,7 +216,7 @@ package body Types.Maps is R (I) := HM.Key (Position); I := I + 1; end loop; - return Lists.List (R); + return Sequences.List (R); end; end Keys; @@ -228,11 +225,9 @@ package body Types.Maps is function Vals (Args : in Mal.T_Array) return Mal.T is begin - if Args'Length /= 1 then - raise Argument_Error with "vals: expects 1 argument"; - elsif Args (Args'First).Kind /= Kind_Map then - raise Argument_Error with "vals: first argument must be a map"; - end if; + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind = Kind_Map, + "parameter 1 must be a map"); declare A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; R : Mal.T_Array (1 .. Natural (A1.Length)); @@ -242,7 +237,7 @@ package body Types.Maps is R (I) := Element; I := I + 1; end loop; - return Lists.List (R); + return Sequences.List (R); end; end Vals; @@ -250,16 +245,16 @@ package body Types.Maps is Metadata : in Mal.T) return Mal.T is - Old : Rec renames Data.Ref.all; - Ref : Acc; + -- Avoid exceptions until Ref is controlled. + Ref : Acc := Data.Ref; begin - pragma Assert (0 < Old.Refs); - if Old.Refs = 1 then - Ref := Data.Ref; - Old.Refs := 2; - Old.Meta := Metadata; + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Metadata; else - Ref := new Rec'(Data => Old.Data, + Allocations := Allocations + 1; + Ref := new Rec'(Data => Ref.all.Data, Meta => Metadata, others => <>); end if; diff --git a/ada.2/types-maps.ads b/ada.2/types-maps.ads index aa67b5f479..58d8f450fb 100644 --- a/ada.2/types-maps.ads +++ b/ada.2/types-maps.ads @@ -41,6 +41,9 @@ package Types.Maps is Metadata : in Mal.T) return Mal.T; + -- Debug + procedure Check_Allocations; + private type Rec; diff --git a/ada.2/types-sequences.adb b/ada.2/types-sequences.adb new file mode 100644 index 0000000000..751f762308 --- /dev/null +++ b/ada.2/types-sequences.adb @@ -0,0 +1,335 @@ +with Ada.Unchecked_Deallocation; + +with Err; +with Types.Mal; + +package body Types.Sequences is + + subtype AFC is Ada.Finalization.Controlled; + use type Mal.T_Array; + + type Rec (Last : Natural) is limited record + Refs : Natural := 1; + Meta : Mal.T := Mal.Nil; + Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil); + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + Allocations : Natural := 0; + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in Ptr) return Boolean is + -- Should become Left.Ref.all.Data = Right.Ref.all.Data when + -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. + use type Mal.T; + L : Rec renames Left.Ref.all; + R : Rec renames Right.Ref.all; + begin + return L.Last = R.Last + and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I)); + end "="; + + function "&" (Left : in Mal.T_Array; + Right : in Ptr) return Mal.T_Array + is (Left & Right.Ref.all.Data); + + procedure Adjust (Object : in out Ptr) is + begin + Object.Ref.all.Refs := @ + 1; + end Adjust; + + procedure Check_Allocations is + begin + pragma Assert (Allocations = 0); + end Check_Allocations; + + function Concat (Args : in Mal.T_Array) return Mal.T is + Sum : Natural := 0; + First : Positive := 1; + Last : Natural; + Ref : Acc; + begin + for Arg of Args loop + Err.Check (Arg.Kind in Kind_Sequence, "expected sequences"); + Sum := Sum + Arg.Sequence.Ref.all.Data'Length; + end loop; + Allocations := Allocations + 1; + -- Avoid exceptions until Ref is controlled. + Ref := new Rec (Sum); + for Arg of Args loop + Last := First - 1 + Arg.Sequence.Ref.all.Data'Length; + Ref.all.Data (First .. Last) := Arg.Sequence.Ref.all.Data; + First := Last + 1; + end loop; + return (Kind_List, (AFC with Ref)); + end Concat; + + function Conj (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (0 < Args'Length, "expected at least 1 parameter"); + case Args (Args'First).Kind is + when Kind_Sequence => + declare + Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data; + Last : constant Natural := Args'Length - 1 + Data'Length; + -- Avoid exceptions until Ref is controlled. + Ref : constant Acc := new Rec (Last); + begin + Allocations := Allocations + 1; + if Args (Args'First).Kind = Kind_List then + for I in 1 .. Args'Length - 1 loop + Ref.all.Data (I) := Args (Args'Last - I + 1); + end loop; + Ref.all.Data (Args'Length .. Last) := Data; + return (Kind_List, (AFC with Ref)); + else + Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last); + return (Kind_Vector, (AFC with Ref)); + end if; + end; + when others => + Err.Raise_With ("parameter 1 must be a sequence"); + end case; + end Conj; + + function Cons (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'Last).Kind in Kind_Sequence, + "parameter 2 must be a sequence"); + declare + Head : Mal.T renames Args (Args'First); + Tail : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data; + begin + Allocations := Allocations + 1; + return (Kind_List, (AFC with new Rec'(Last => 1 + Tail'Length, + Data => Head & Tail, + others => <>))); + end; + end Cons; + + function Count (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + case Args (Args'First).Kind is + when Kind_Nil => + return (Kind_Number, 0); + when Kind_Sequence => + return (Kind_Number, Args (Args'First).Sequence.Ref.all.Data'Length); + when others => + Err.Raise_With ("parameter must be nil or a sequence"); + end case; + end Count; + + function Element (Container : in Ptr; + Index : in Positive) return Mal.T + is (Container.Ref.all.Data (Index)); + + procedure Finalize (Object : in out Ptr) is + begin + if Object.Ref /= null and then 0 < Object.Ref.all.Refs then + Object.Ref.all.Refs := @ - 1; + if 0 < Object.Ref.all.Refs then + Object.Ref := null; + else + Allocations := Allocations - 1; + Free (Object.Ref); + end if; + end if; + end Finalize; + + function First (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + case Args (Args'First).Kind is + when Kind_Nil => + return Mal.Nil; + when Kind_Sequence => + declare + Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data; + begin + if Data'Length = 0 then + return Mal.Nil; + else + return Data (Data'First); + end if; + end; + when others => + Err.Raise_With ("parameter must be nil or a sequence"); + end case; + end First; + + function Generic_Eval (Container : in Ptr; + Env : in Env_Type) + return Ptr + is + -- Avoid exceptions until Ref is controlled. + Ref : Acc := Container.Ref; + begin + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Mal.Nil; + else + Allocations := Allocations + 1; + Ref := new Rec (Ref.all.Last); + end if; + return R : constant Ptr := (AFC with Ref) do + for I in Container.Ref.all.Data'Range loop + Ref.all.Data (I) := Eval (Container.Ref.all.Data (I), Env); + -- This call may raise exceptions. + -- The target may be the source. + end loop; + end return; + end Generic_Eval; + + function Is_Empty (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + Err.Check (Args (Args'First).Kind in Kind_Sequence, + "parameter must be a sequence"); + return (Kind_Boolean, + Args (Args'First).Sequence.Ref.all.Data'Length = 0); + end Is_Empty; + + function Length (Source : in Ptr) return Natural + is (Source.Ref.all.Data'Length); + + function List (Args : in Mal.T_Array) return Mal.T is + begin + Allocations := Allocations + 1; + return (Kind_List, (AFC with new Rec'(Data => Args, + Last => Args'Length, + others => <>))); + end List; + + function Map (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'Last).Kind in Kind_Sequence, + "parameter 2 must be a sequence"); + declare + F : Mal.T renames Args (Args'First); + Src : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data; + -- Avoid exceptions until Ref is controlled. + Ref : Acc := Args (Args'Last).Sequence.Ref; + begin + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Mal.Nil; + else + Allocations := Allocations + 1; + Ref := new Rec (Ref.all.Last); + end if; + return R : constant Mal.T := (Kind_List, (AFC with Ref)) do + case F.Kind is + when Kind_Builtin => + for I in Src'Range loop + Ref.all.Data (I) := F.Builtin.all (Src (I .. I)); + -- This call may raise exceptions. + -- The target may be the same storage than the source. + end loop; + when Kind_Builtin_With_Meta => + for I in Src'Range loop + Ref.all.Data (I) + := F.Builtin_With_Meta.Builtin.all (Src (I .. I)); + end loop; + when Kind_Fn => + for I in Src'Range loop + Ref.all.Data (I) := F.Fn.Apply (Src (I .. I)); + end loop; + when others => + Err.Raise_With ("parameter 1 must be a function"); + end case; + end return; + end; + end Map; + + function Meta (Item : in Ptr) return Mal.T + is (Item.Ref.all.Meta); + + function Nth (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + Err.Check (Args (Args'First).Kind in Kind_Sequence, + "paramater 1 must be a sequence"); + Err.Check (Args (Args'Last).Kind = Kind_Number, + "parameter 2 must be a number"); + declare + L : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data; + I : constant Integer := Args (Args'Last).Number + 1; + begin + Err.Check (I in L'Range, "index out of bounds"); + return L (I); + end; + end Nth; + + function Rest (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + declare + A1 : Mal.T renames Args (Args'First); + Ref : Acc; + begin + -- Avoid exceptions until Ref is controlled. + case A1.Kind is + when Kind_Nil => + Allocations := Allocations + 1; + Ref := new Rec (0); + when Kind_Sequence => + Allocations := Allocations + 1; + if A1.Sequence.Ref.all.Last = 0 then + Ref := new Rec (0); + else + Ref := new Rec' + (Last => A1.Sequence.Ref.all.Last - 1, + Data => A1.Sequence.Ref.all.Data + (2 .. A1.Sequence.Ref.all.Data'Last), + others => <>); + end if; + when others => + Err.Raise_With ("parameter must be nil or a sequence"); + end case; + return (Kind_List, (AFC with Ref)); + end; + end Rest; + + function Tail (Source : in Ptr; + Count : in Natural) return Mal.T_Array is + Data : Mal.T_Array renames Source.Ref.all.Data; + begin + return Data (Data'Last - Count + 1 .. Data'Last); + end Tail; + + function Vector (Args : in Mal.T_Array) return Mal.T is + begin + Allocations := Allocations + 1; + return (Kind_Vector, (AFC with new Rec'(Data => Args, + Last => Args'Length, + others => <>))); + end Vector; + + function With_Meta (Data : in Ptr; + Metadata : in Mal.T) return Ptr + is + -- Avoid exceptions until Ref is controlled. + Ref : Acc := Data.Ref; + + begin + pragma Assert (0 < Ref.all.Refs); + if Ref.all.Refs = 1 then + Ref.all.Refs := 2; + Ref.all.Meta := Metadata; + else + Allocations := Allocations + 1; + Ref := new Rec'(Last => Ref.all.Last, + Data => Ref.all.Data, + Meta => Metadata, + others => <>); + end if; + return (AFC with Ref); + end With_Meta; + +end Types.Sequences; diff --git a/ada.2/types-lists.ads b/ada.2/types-sequences.ads similarity index 85% rename from ada.2/types-lists.ads rename to ada.2/types-sequences.ads index 7eefc0eb3e..e195dee269 100644 --- a/ada.2/types-lists.ads +++ b/ada.2/types-sequences.ads @@ -2,9 +2,10 @@ private with Ada.Finalization; limited with Types.Mal; -package Types.Lists is +package Types.Sequences is - type Ptr is tagged private; + type Ptr is tagged private + with Constant_Indexing => Element; -- Built-in functions. function Concat (Args : in Mal.T_Array) return Mal.T; @@ -23,8 +24,7 @@ package Types.Lists is function Element (Container : in Ptr; Index : in Positive) return Mal.T - with Inline; - Index_Error : exception; + with Inline, Pre => Index <= Length (Container); function "&" (Left : in Mal.T_Array; Right : in Ptr) return Mal.T_Array; @@ -41,16 +41,19 @@ package Types.Lists is Env : in Env_Type) return Ptr; - -- Used to spare an intermediate copy for & in macro arguments. - function Slice (Item : in Ptr; - Start : in Positive) - return Mal.T; + -- Used in macro implementation. + function Tail (Source : in Ptr; + Count : in Natural) return Mal.T_Array + with Inline, Pre => Count <= Length (Source); function Meta (Item : in Ptr) return Mal.T with Inline; function With_Meta (Data : in Ptr; Metadata : in Mal.T) return Ptr; + -- Debug. + procedure Check_Allocations; + private -- It is tempting to use null to represent an empty list, but the @@ -72,4 +75,4 @@ private overriding function "=" (Left, Right : in Ptr) return Boolean; pragma Finalize_Storage_Only (Ptr); -end Types.Lists; +end Types.Sequences; diff --git a/ada.2/types-symbols-names.ads b/ada.2/types-symbols-names.ads index 543f5e2d73..1478ab387a 100644 --- a/ada.2/types-symbols-names.ads +++ b/ada.2/types-symbols-names.ads @@ -16,7 +16,6 @@ package Types.Symbols.Names is Fn : constant Ptr := Constructor ("fn*"); Let : constant Ptr := Constructor ("let*"); Macroexpand : constant Ptr := Constructor ("macroexpand"); - Mal_Do : constant Ptr := Constructor ("do"); Mal_If : constant Ptr := Constructor ("if"); Quasiquote : constant Ptr := Constructor ("quasiquote"); Quote : constant Ptr := Constructor ("quote"); diff --git a/ada.2/types-symbols.adb b/ada.2/types-symbols.adb index 7aa5f530d9..4ca03c5132 100644 --- a/ada.2/types-symbols.adb +++ b/ada.2/types-symbols.adb @@ -13,6 +13,7 @@ package body Types.Symbols is Data : String (1 .. Last); end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); + Allocations : Natural := 0; function "<" (Left, Right : in Acc) return Boolean with Inline; function Eq (Left, Right : in Acc) return Boolean with Inline; @@ -38,17 +39,25 @@ package body Types.Symbols is procedure Adjust (Object : in out Ptr) is begin - Object.Ref.all.Refs := Object.Ref.all.Refs + 1; + Object.Ref.all.Refs := @ + 1; end Adjust; + procedure Check_Allocations is + begin + -- See Types.Symbols.Names. + pragma Assert (Allocations = 15); + end Check_Allocations; + function Constructor (Source : in String) return Ptr is Position : constant Sets.Cursor := Keys.Find (Dict, Source); Ref : Acc; begin + -- Avoid exceptions until Ref is controlled. if Sets.Has_Element (Position) then Ref := Sets.Element (Position); Ref.all.Refs := Ref.all.Refs + 1; else + Allocations := Allocations + 1; Ref := new Rec'(Data => Source, Hash => Ada.Strings.Hash (Source), Last => Source'Length, @@ -68,11 +77,12 @@ package body Types.Symbols is procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := Object.Ref.all.Refs - 1; + Object.Ref.all.Refs := @ - 1; if 0 < Object.Ref.all.Refs then Object.Ref := null; else Dict.Delete (Object.Ref); + Allocations := Allocations - 1; Free (Object.Ref); end if; end if; @@ -87,26 +97,4 @@ package body Types.Symbols is function To_String (Item : in Ptr) return String is (Item.Ref.all.Data); - function To_String (Item : in Symbol_Array) return String is - I : Natural := Item'Length + 1; - begin - for S of Item loop - I := I + S.Ref.all.Last; - end loop; - return R : String (1 .. I) do - R (1) := '('; - I := 2; - for S of Item loop - if 2 < I then - R (I) := ' '; - I := I + 1; - end if; - R (I .. I + S.Ref.all.Last - 1) := S.Ref.all.Data; - I := I + S.Ref.all.Last; - end loop; - pragma Assert (I = R'Last); - R (R'Last) := ')'; - end return; - end To_String; - end Types.Symbols; diff --git a/ada.2/types-symbols.ads b/ada.2/types-symbols.ads index 91be3a00b5..7b620a81c7 100644 --- a/ada.2/types-symbols.ads +++ b/ada.2/types-symbols.ads @@ -17,10 +17,8 @@ package Types.Symbols with Preelaborate is type Symbol_Array is array (Positive range <>) of Symbols.Ptr; - function To_String (Item : in Symbols.Symbol_Array) return String; - -- Returns something like "(a b)". Convenient for error - -- reporting, but redundant with Printer (where it is more - -- efficient to concatenate directly to an unbounded buffer). + -- Debug. + procedure Check_Allocations; private diff --git a/ada.2/types.ads b/ada.2/types.ads index 3e549a9b24..f01c830b77 100644 --- a/ada.2/types.ads +++ b/ada.2/types.ads @@ -1,20 +1,18 @@ package Types with Pure is - -- Similar kinds should be consecutive for efficient case - -- statements. type Kind_Type is (Kind_Nil, Kind_Atom, Kind_Boolean, Kind_Number, - Kind_String, Kind_Symbol, Kind_Keyword, + Kind_Symbol, + Kind_Keyword, Kind_String, Kind_List, Kind_Vector, Kind_Map, - Kind_Macro, Kind_Function, Kind_Builtin_With_Meta, Kind_Builtin); + Kind_Macro, Kind_Fn, Kind_Builtin_With_Meta, Kind_Builtin); - -- Raised when a program attempts to execute something else than a - -- function or a macro, or when a builtin receives a bad argument - -- count, type or value. - Argument_Error : exception; + subtype Kind_Key is Kind_Type range Kind_Keyword .. Kind_String; + subtype Kind_Sequence is Kind_Type range Kind_List .. Kind_Vector; + subtype Kind_Function is Kind_Type range Kind_Fn .. Kind_Builtin; end Types; From 265dd4e9efc1dfd3694c5da538aad4af1fed8791 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 17 Mar 2019 14:15:41 +0100 Subject: [PATCH 0496/1998] ada.2: add Dockerfile from kanaka --- ada.2/Dockerfile | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 ada.2/Dockerfile diff --git a/ada.2/Dockerfile b/ada.2/Dockerfile new file mode 100644 index 0000000000..b05b41362e --- /dev/null +++ b/ada.2/Dockerfile @@ -0,0 +1,25 @@ +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# GNU Ada compiler +RUN apt-get -y install gnat-8 From a4820e976b1101fe1da1c93ddfe5811845456ea1 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Sun, 17 Mar 2019 14:56:28 +0100 Subject: [PATCH 0497/1998] ada.2: remove -gnatp optimization, which crashes the perf test. --- ada.2/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ada.2/Makefile b/ada.2/Makefile index 342e56a917..e5de51b805 100644 --- a/ada.2/Makefile +++ b/ada.2/Makefile @@ -6,7 +6,7 @@ else # -O3 is not recommended as the default by the GCC documentation, # and -O2 seems to produce slightly better performances. # See README for a discussion of -gnatp. - ADAFLAGS := -O2 -gnatnp + ADAFLAGS := -O2 -gnatn endif # Compiler arguments. From c4269f9bf50a952571ae09aa3340c9ac07b65cb3 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Mar 2019 23:32:35 -0500 Subject: [PATCH 0498/1998] Convert to loccount based stats calculation. --- Makefile | 22 ++++++++++++++++++---- ada/Makefile | 17 ----------------- awk/Makefile | 20 -------------------- bash/Makefile | 9 --------- basic/Makefile | 15 +-------------- c/Makefile | 26 -------------------------- chuck/Makefile | 15 +-------------- clojure/Makefile | 9 --------- coffee/Makefile | 11 ----------- common-lisp/Makefile | 11 ----------- cpp/Makefile | 13 ------------- crystal/Makefile | 9 +-------- cs/Makefile | 17 ----------------- d/Makefile | 23 ----------------------- dart/Makefile | 13 +------------ elisp/Makefile | 14 -------------- elixir/Makefile | 10 +--------- elm/Makefile | 10 ---------- erlang/Makefile | 9 +-------- es6/Makefile | 15 --------------- factor/Makefile | 12 ------------ fantom/Makefile | 13 ------------- forth/Makefile | 9 --------- fsharp/Makefile | 17 ----------------- gnu-smalltalk/Makefile | 14 -------------- go/Makefile | 12 ------------ groovy/Makefile | 13 ------------- guile/Makefile | 9 --------- haskell/Makefile | 15 --------------- haxe/Makefile | 12 ------------ hy/Makefile | 14 -------------- io/Makefile | 22 +++------------------- java/Makefile | 13 ------------- js/Makefile | 9 +-------- julia/Makefile | 13 ------------- kotlin/Makefile | 11 ----------- livescript/Makefile | 9 --------- logo/Makefile | 9 +-------- lua/Makefile | 12 ------------ make/Makefile | 9 +-------- mal/Makefile | 23 ----------------------- matlab/Makefile | 16 ---------------- miniMAL/Makefile | 9 --------- nasm/Makefile | 15 --------------- nim/Makefile | 11 ----------- objc/Makefile | 12 ------------ objpascal/Makefile | 14 -------------- ocaml/Makefile | 9 +-------- perl/Makefile | 17 ----------------- perl6/Makefile | 16 +--------------- php/Makefile | 18 ------------------ picolisp/Makefile | 14 -------------- plpgsql/Makefile | 13 +------------ plsql/Makefile | 13 ++----------- powershell/Makefile | 13 +------------ ps/Makefile | 19 ------------------- python/Makefile | 19 ------------------- r/Makefile | 12 ------------ racket/Makefile | 9 --------- rexx/Makefile | 21 +-------------------- rpython/Makefile | 13 +------------ ruby/Makefile | 17 ----------------- rust/Makefile | 14 +------------- scala/Makefile | 17 +---------------- scheme/Makefile | 12 +----------- skew/Makefile | 11 +---------- swift/Makefile | 13 ------------- swift3/Makefile | 11 ----------- swift4/Makefile | 12 ------------ tcl/Makefile | 10 ---------- ts/Makefile | 13 +------------ vb/Makefile | 17 ----------------- vhdl/Makefile | 23 ----------------------- vimscript/Makefile | 9 +-------- wasm/Makefile | 13 ------------- yorick/Makefile | 9 +-------- 76 files changed, 45 insertions(+), 997 deletions(-) diff --git a/Makefile b/Makefile index 9843ed9c3f..75a08b77ff 100644 --- a/Makefile +++ b/Makefile @@ -62,6 +62,9 @@ scheme_MODE = chibi # js wace_libc wace_fooboot wasm_MODE = wace_libc +# Path to loccount for counting LOC stats +LOCCOUNT = loccount + # Extra options to pass to runtest.py TEST_OPTS = @@ -337,6 +340,8 @@ DOCKER_SHELL = $(foreach impl,$(DO_IMPLS),docker-shell^$(impl)) IMPL_PERF = $(foreach impl,$(filter-out $(perf_EXCLUDES),$(DO_IMPLS)),perf^$(impl)) +IMPL_STATS = $(foreach impl,$(DO_IMPLS),stats^$(impl)) + IMPL_REPL = $(foreach impl,$(DO_IMPLS),repl^$(impl)) ALL_REPL = $(strip $(sort \ $(foreach impl,$(DO_IMPLS),\ @@ -453,6 +458,19 @@ $(ALL_REPL): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(su # Allow repl^IMPL^STEP and repl^IMPL (which starts REPL of stepA) $(IMPL_REPL): $$@^stepA +# +# Stats test rules +# + +# For a concise summary: +# make stats | egrep -A1 "^Stats for|^all" | egrep -v "^all|^--" +stats: $(IMPL_STATS) + +$(IMPL_STATS): + @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + echo "Stats for $(impl):"; \ + $(LOCCOUNT) -x "Makefile|node_modules" $(impl)) + # # Utility functions # @@ -481,9 +499,5 @@ recur_impls_ = $(filter-out $(foreach impl,$($(1)_EXCLUDES),$(1)^$(impl)),$(fore # recursive clean $(eval $(call recur_template,clean,$(call recur_impls_,clean))) -# recursive stats -$(eval $(call recur_template,stats,$(call recur_impls_,stats))) -$(eval $(call recur_template,stats-lisp,$(call recur_impls_,stats-lisp))) - # recursive dist $(eval $(call recur_template,dist,$(call recur_impls_,dist))) diff --git a/ada/Makefile b/ada/Makefile index 02e02edba9..7ee47a99d2 100644 --- a/ada/Makefile +++ b/ada/Makefile @@ -2,11 +2,6 @@ DIRS=obj PROGS=step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ step5_tco step6_file step7_quote step8_macros step9_try -SOURCES_LISP=envs.ad[bs] eval_callback.ads core.ad[bs] stepa_mal.adb -SOURCES=$(SOURCES_LISP) \ - types.ad[bs] types-vector.ad[bs] types-hash_map.ad[bs] \ - reader.ad[bs] printer.ad[bs] smart_pointers.ad[bs] - all: ${DIRS} ${PROGS} stepA_mal ${DIRS}: @@ -23,15 +18,3 @@ stepA_mal: stepa_mal clean: rm -f ${PROGS} rm -rf obj - -.PHONY: stats stats-lisp force - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -force: diff --git a/awk/Makefile b/awk/Makefile index 1136bc0bf6..ce864e0845 100644 --- a/awk/Makefile +++ b/awk/Makefile @@ -1,7 +1,3 @@ - -TESTS = - - SOURCES_BASE = types.awk reader.awk printer.awk SOURCES_LISP = env.awk core.awk stepA_mal.awk SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -22,19 +18,3 @@ mal: mal.awk clean: rm -f mal.awk mal - - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - python $@ || exit 1; \ diff --git a/bash/Makefile b/bash/Makefile index 488a4ffe4e..0f7bc0396a 100644 --- a/bash/Makefile +++ b/bash/Makefile @@ -17,12 +17,3 @@ mal: mal.sh clean: rm -f mal.sh mal - -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/basic/Makefile b/basic/Makefile index e2cd4bb3f5..03b655809b 100644 --- a/basic/Makefile +++ b/basic/Makefile @@ -54,21 +54,8 @@ mal.d64: mal.prg .args.mal.prg core.mal.prg # Clean and Stats rules -.PHONY: clean stats +.PHONY: clean clean: rm -f $(STEPS0_A) $(subst .bas,,$(STEPS0_A)) *.d64 *.prg qb64 rm -rf ./internal - - -SOURCES_LISP = env.in.bas core.in.bas stepA_mal.in.bas -SOURCES = readline.in.bas readline_line.in.bas readline_char.in.bas \ - types.in.bas reader.in.bas printer.in.bas $(SOURCES_LISP) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*REM |^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*REM |^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/c/Makefile b/c/Makefile index 98ceee60b7..4c11393748 100644 --- a/c/Makefile +++ b/c/Makefile @@ -3,17 +3,6 @@ USE_GC ?= 1 CFLAGS += -g -O2 LDFLAGS += -g -##################### - -TESTS = - -SOURCES_BASE = readline.h readline.c types.h types.c \ - reader.h reader.c printer.h printer.c \ - interop.h interop.c -SOURCES_LISP = env.c core.h core.c stepA_mal.c -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - - ##################### SRCS = step0_repl.c step1_read_print.c step2_eval.c step3_env.c \ @@ -69,18 +58,3 @@ $(BINS): %: %.o clean: rm -f $(OBJS) $(BINS) $(OTHER_OBJS) mal - -.PHONY: stats stats-lisp tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ./$@ || exit 1; \ diff --git a/chuck/Makefile b/chuck/Makefile index f851639feb..bee2d7baae 100644 --- a/chuck/Makefile +++ b/chuck/Makefile @@ -1,18 +1,5 @@ -SOURCES_BASE = readline.ck reader.ck printer.ck \ - types/MalObject.ck types/MalSubr.ck \ - types/**/*.ck util/*.ck -SOURCES_LISP = env.ck core.ck stepA_mal.ck -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: clean: -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -.PHONY: all clean stats stats-lisp +.PHONY: all clean diff --git a/clojure/Makefile b/clojure/Makefile index f5b4f20ccc..55a0948c3b 100644 --- a/clojure/Makefile +++ b/clojure/Makefile @@ -34,12 +34,3 @@ node_modules: clean: rm -rf target/ mal.jar mal - -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/coffee/Makefile b/coffee/Makefile index 0c2b36737a..74b3c96c35 100644 --- a/coffee/Makefile +++ b/coffee/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = node_readline.coffee types.coffee \ reader.coffee printer.coffee SOURCES_LISP = env.coffee core.coffee stepA_mal.coffee @@ -23,12 +21,3 @@ mal: mal.coffee clean: rm -f mal.coffee mal - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" diff --git a/common-lisp/Makefile b/common-lisp/Makefile index a80f34f58c..7572f4f878 100644 --- a/common-lisp/Makefile +++ b/common-lisp/Makefile @@ -20,8 +20,6 @@ MKCL ?= mkcl STANDALONE_EXE = sbcl clisp ccl ecl cmucl ROOT_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) -SOURCES_LISP := src/env.lisp src/core.lisp src/stepA_mal.lisp -SOURCES := src/utils.lisp src/types.lisp src/reader.lisp src/printer.lisp $(SOURCES_LISP) # Record the Common Lisp implementation used for all steps built in this # invocation This is used in the targets to rebuild the step if the @@ -29,7 +27,6 @@ SOURCES := src/utils.lisp src/types.lisp src/reader.lisp src/printer.lisp $(SOUR $(foreach step, $(call steps), $(call record_lisp,$(patsubst step%,%,$(step)),$(LISP))) .PRECIOUS: hist/%_impl -.PHONY: stats all : stepA_mal @@ -68,11 +65,3 @@ endif clean: find . -maxdepth 1 -name 'step*' -executable -delete rm -f *.lib *.fas[l] images/* hist/*_impl - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/cpp/Makefile b/cpp/Makefile index ad20eb8360..2377031883 100644 --- a/cpp/Makefile +++ b/cpp/Makefile @@ -52,16 +52,3 @@ clean: rm -rf *.o $(TARGETS) libmal.a .deps mal -include .deps - - -### Stats - -.PHONY: stats stats-lisp - -stats: $(LIBSOURCES) stepA_mal.cpp - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: Core.cpp Environment.cpp stepA_mal.cpp - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/crystal/Makefile b/crystal/Makefile index 8373692259..42739be52c 100644 --- a/crystal/Makefile +++ b/crystal/Makefile @@ -29,12 +29,5 @@ step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal clean: rm -rf $(STEP_BINS) mal .crystal -stats: types.cr error.cr reader.cr printer.cr env.cr core.cr stepA_mal.cr - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: env.cr core.cr stepA_mal.cr - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -.PHONY: all clean stats stats-lisp +.PHONY: all clean diff --git a/cs/Makefile b/cs/Makefile index 8431f704c1..52529a915b 100644 --- a/cs/Makefile +++ b/cs/Makefile @@ -2,8 +2,6 @@ DEBUG = -TESTS = - SOURCES_BASE = readline.cs types.cs reader.cs printer.cs SOURCES_LISP = env.cs core.cs stepA_mal.cs SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -43,18 +41,3 @@ mal.dll: $(LIB_SRCS) clean: rm -f mal *.dll *.exe *.mdb - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ./$@ || exit 1; \ diff --git a/d/Makefile b/d/Makefile index 57d4803f3a..75a19fb7dd 100644 --- a/d/Makefile +++ b/d/Makefile @@ -3,14 +3,6 @@ LDFLAGS += -lreadline ##################### -TESTS = - -SOURCES_BASE = readline.d types.d reader.d printer.d -SOURCES_LISP = env.d mal_core.d stepA_mal.d -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -##################### - EARLY_SRCS = step0_repl.d step1_read_print.d step2_eval.d LATE_SRCS = step3_env.d step4_if_fn_do.d step5_tco.d step6_file.d \ step7_quote.d step8_macros.d step9_try.d stepA_mal.d @@ -42,18 +34,3 @@ $(BINS): %: %.o clean: rm -f $(OBJS) $(BINS) $(OTHER_OBJS) mal - -.PHONY: stats stats-lisp tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ./$@ || exit 1; \ diff --git a/dart/Makefile b/dart/Makefile index 25bd0e6d6f..b3c660f49d 100644 --- a/dart/Makefile +++ b/dart/Makefile @@ -1,16 +1,5 @@ all: @true -SOURCES_BASE = types.dart reader.dart printer.dart -SOURCES_LISP = env.dart core.dart stepA_mal.dart -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +clean: diff --git a/elisp/Makefile b/elisp/Makefile index f554c38b3d..7af3113c71 100644 --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,17 +1,3 @@ -SOURCES_BASE = mal/reader.el mal/printer.el mal/types.el -SOURCES_LISP = mal/env.el mal/func.el mal/core.el stepA_mal.el -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: clean: - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/elixir/Makefile b/elixir/Makefile index 7f922cc097..7bae647688 100644 --- a/elixir/Makefile +++ b/elixir/Makefile @@ -14,12 +14,4 @@ clean: mix clean rm -f mal -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -.PHONY: clean stats stats-lisp +.PHONY: clean diff --git a/elm/Makefile b/elm/Makefile index 1ad56ff655..0850dce973 100644 --- a/elm/Makefile +++ b/elm/Makefile @@ -2,8 +2,6 @@ SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ step3_env.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm \ step7_quote.elm step8_macros.elm step9_try.elm stepA_mal.elm -SOURCES_LISP = Env.elm Core.elm Eval.elm stepA_mal.elm - BINS = $(SOURCES:%.elm=%.js) ELM_MAKE = node_modules/.bin/elm-make @@ -40,11 +38,3 @@ stepA_mal.js: $(STEP4_SOURCES) clean: rm -f $(BINS) - -stats: $(STEP4_SOURCES) stepA_mal.elm - @wc $^ - @printf "%5s %5s %5s %s\n" `egrep "^\w*(--|\{-|-\})|^\w*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `egrep "^\w*(--|\{-|-\})|^\w*$$" $^ | wc` "[comments/blanks]" diff --git a/erlang/Makefile b/erlang/Makefile index 808a2a9019..5ad84cca76 100644 --- a/erlang/Makefile +++ b/erlang/Makefile @@ -12,7 +12,7 @@ BINS = $(SRCS:%.erl=%) ##################### -.PHONY: all dist clean stats stats-lisp +.PHONY: all dist clean all: $(BINS) @@ -35,10 +35,3 @@ $(foreach b,$(BINS),$(eval $(call dep_template,$(b)))) clean: rebar clean rm -f mal - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*%|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*%|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/es6/Makefile b/es6/Makefile index b88fd2a0d1..15ffe6aa49 100644 --- a/es6/Makefile +++ b/es6/Makefile @@ -27,18 +27,3 @@ mal: mal.js clean: rm -f mal.js mal rm -rf node_modules - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - node $@ || exit 1; \ diff --git a/factor/Makefile b/factor/Makefile index b11d591f32..e4cabeff1d 100644 --- a/factor/Makefile +++ b/factor/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = lib/types/types.factor lib/reader/reader.factor lib/printer/printer.factor SOURCES_LISP = lib/env/env.factor lib/core/core.factor stepA_mal/stepA_mal.factor SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -31,13 +29,3 @@ mal: mal.factor clean: rm -f mal.factor - -.PHONY: stats stats-lisp - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\!|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\!|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/fantom/Makefile b/fantom/Makefile index 97ebecc100..2b95720ab0 100644 --- a/fantom/Makefile +++ b/fantom/Makefile @@ -1,7 +1,3 @@ -SOURCES_BASE = src/mallib/fan/interop.fan src/mallib/fan/reader.fan src/mallib/fan/types.fan -SOURCES_LISP = src/mallib/fan/env.fan src/mallib/fan/core.fan src/stepA_mal/fan/main.fan -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: dist dist: lib/fan/mal.pod @@ -20,12 +16,3 @@ lib/fan/mallib.pod: src/mallib/build.fan src/mallib/fan/*.fan lib/fan clean: rm -rf lib - -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/forth/Makefile b/forth/Makefile index c619d19684..70617396d2 100644 --- a/forth/Makefile +++ b/forth/Makefile @@ -17,12 +17,3 @@ mal: mal.fs clean: rm -f mal.fs mal - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*[\\]|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*[\\]|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/fsharp/Makefile b/fsharp/Makefile index 9c56a1e021..505d3ee5d3 100644 --- a/fsharp/Makefile +++ b/fsharp/Makefile @@ -2,8 +2,6 @@ DEBUG = -TESTS = - SOURCES_BASE = types.fs error.fs node.fs printer.fs tokenizer.fs reader.fs \ readline.fs SOURCES_LISP = core.fs env.fs stepA_mal.fs @@ -46,18 +44,3 @@ mal.dll: $(DLL_SOURCES) Mono.Terminal.dll clean: rm -f mal *.dll *.exe *.mdb - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ./$@ || exit 1; \ diff --git a/gnu-smalltalk/Makefile b/gnu-smalltalk/Makefile index c876270e97..7af3113c71 100644 --- a/gnu-smalltalk/Makefile +++ b/gnu-smalltalk/Makefile @@ -1,17 +1,3 @@ -SOURCES_BASE = readline.st reader.st printer.st types.st util.st -SOURCES_LISP = env.st func.st core.st stepA_mal.st -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: clean: - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/go/Makefile b/go/Makefile index f35976a37d..f2094e8e14 100644 --- a/go/Makefile +++ b/go/Makefile @@ -5,9 +5,6 @@ export GOPATH := $(dir $(abspath $(lastword $(MAKEFILE_LIST)))) SOURCES_BASE = src/types/types.go src/readline/readline.go \ src/reader/reader.go src/printer/printer.go \ src/env/env.go src/core/core.go -SOURCES_LISP = src/env/env.go src/core/core.go \ - src/stepA_mal/stepA_mal.go -SOURCES = $(SOURCES_BASE) $(word $(words $(SOURCES_LISP)),${SOURCES_LISP}) ##################### @@ -34,12 +31,3 @@ $(foreach b,$(BINS),$(eval $(call dep_template,$(b)))) clean: rm -f $(BINS) mal - -.PHONY: stats stats-lisp - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/groovy/Makefile b/groovy/Makefile index b76e71f45f..888eb9fc24 100644 --- a/groovy/Makefile +++ b/groovy/Makefile @@ -1,9 +1,5 @@ CLASSES = types.class reader.class printer.class env.class core.class -SOURCES_BASE = types.groovy reader.groovy printer.groovy -SOURCES_LISP = env.groovy core.groovy stepA_mal.groovy -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: ${CLASSES} dist: mal.jar @@ -40,12 +36,3 @@ mal: mal.jar clean: rm -f *.class classes/* mal.jar mal rmdir classes || true - -.PHONY: stats tests - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/guile/Makefile b/guile/Makefile index e7e6f345a7..993bd8cdd8 100644 --- a/guile/Makefile +++ b/guile/Makefile @@ -15,12 +15,3 @@ mal.scm: $(SOURCES) clean: rm -f mal.scm - -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/haskell/Makefile b/haskell/Makefile index b5912c6927..6b1fd07a4f 100644 --- a/haskell/Makefile +++ b/haskell/Makefile @@ -1,9 +1,3 @@ -SOURCES_BASE = Readline.hs Types.hs Reader.hs Printer.hs -SOURCES_LISP = Env.hs Core.hs step9_try.hs -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -##################### - SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs \ step4_if_fn_do.hs step5_tco.hs step6_file.hs step7_quote.hs \ step8_macros.hs step9_try.hs stepA_mal.hs @@ -24,12 +18,3 @@ $(BINS): %: %.hs $(OTHER_SRCS) clean: rm -f $(BINS) mal *.hi *.o - -.PHONY: stats stats-lisp tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/haxe/Makefile b/haxe/Makefile index 0602c9edf7..4d2133ab33 100644 --- a/haxe/Makefile +++ b/haxe/Makefile @@ -1,8 +1,6 @@ STEP1_DEPS = Compat.hx types/Types.hx reader/Reader.hx printer/Printer.hx STEP3_DEPS = $(STEP1_DEPS) env/Env.hx STEP4_DEPS = $(STEP3_DEPS) core/Core.hx -SOURCES = $(STEP4_DEPS) StepA_mal.hx -SOURCES_LISP = env/Env.hx core/Core.hx StepA_mal.hx STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ @@ -104,13 +102,3 @@ clean: rm -f mal.n mal.py cpp/mal mal.js mal rm -f step*.py step*.js step*.n [ -e cpp/ ] && rm -r cpp/ || true - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/hy/Makefile b/hy/Makefile index 2e6a5d7b64..47f487eba1 100644 --- a/hy/Makefile +++ b/hy/Makefile @@ -1,7 +1,3 @@ -SOURCES_BASE = mal_types.hy reader.hy printer.hy -SOURCES_LISP = env.hy core.hy stepA_mal.hy -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: mal.hy mal.hy: stepA_mal.hy @@ -9,13 +5,3 @@ mal.hy: stepA_mal.hy clean: rm -f mal.hy *.pyc - -#.PHONY: stats tests $(TESTS) -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/io/Makefile b/io/Makefile index 5da1e5e5f7..d2e469ecd4 100644 --- a/io/Makefile +++ b/io/Makefile @@ -1,20 +1,4 @@ -TESTS = +all: + @true -SOURCES_BASE = MalReadline.io MalTypes.io MalReader.io -SOURCES_LISP = Env.io MalCore.io stepA_mal.io -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ruby $@ || exit 1; \ +clean: diff --git a/java/Makefile b/java/Makefile index 8e256e5822..34d38feb7d 100644 --- a/java/Makefile +++ b/java/Makefile @@ -1,7 +1,4 @@ -TESTS = - - SOURCES_BASE = src/main/java/mal/readline.java src/main/java/mal/types.java \ src/main/java/mal/reader.java src/main/java/mal/printer.java SOURCES_LISP = src/main/java/mal/env.java src/main/java/mal/core.java \ @@ -31,13 +28,3 @@ target/classes/mal/step%.class: src/main/java/mal/step%.java ${SOURCES} clean: mvn clean rm -f mal.jar mal - -#.PHONY: stats tests $(TESTS) -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/js/Makefile b/js/Makefile index 8e4ad35bf1..faef0bfe28 100644 --- a/js/Makefile +++ b/js/Makefile @@ -34,14 +34,7 @@ clean: rm -f mal.js web/mal.js rm -rf node_modules -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +.PHONY: tests $(TESTS) tests: $(TESTS) diff --git a/julia/Makefile b/julia/Makefile index 21f501f230..82fa2ef848 100644 --- a/julia/Makefile +++ b/julia/Makefile @@ -1,17 +1,4 @@ - -SOURCES_BASE = reader.jl printer.jl readline_mod.jl types.jl -SOURCES_LISP = env.jl core.jl stepA_mal.jl -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: clean: -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/kotlin/Makefile b/kotlin/Makefile index 8e729689cc..1a9a6dfee1 100644 --- a/kotlin/Makefile +++ b/kotlin/Makefile @@ -2,7 +2,6 @@ SOURCES_BASE = reader.kt printer.kt types.kt env.kt core.kt readline.kt SOURCES_LISP = step0_repl.kt step1_read_print.kt step2_eval.kt step3_env.kt step4_if_fn_do.kt \ step5_tco.kt step6_file.kt step7_quote.kt step8_macros.kt step9_try.kt stepA_mal.kt -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) JARS = $(SOURCES_LISP:%.kt=%.jar) all: $(JARS) @@ -22,13 +21,3 @@ clean: $(JARS): %.jar: src/mal/%.kt $(SOURCES_BASE:%.kt=src/mal/%.kt) kotlinc src/mal/$(@:%.jar=%.kt) $(SOURCES_BASE:%.kt=src/mal/%.kt) -include-runtime -d $@ - -.PHONY: stats - -stats: $(SOURCES:%.kt=src/mal/%.kt) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP:%.kt=src/mal/%.kt) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/livescript/Makefile b/livescript/Makefile index faec18c5a6..07c91d250a 100644 --- a/livescript/Makefile +++ b/livescript/Makefile @@ -2,7 +2,6 @@ SOURCES_BASE = reader.ls printer.ls env.ls core.ls utils.ls SOURCES_STEPS = step0_repl.ls step1_read_print.ls step2_eval.ls \ step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ step8_macros.ls step9_try.ls stepA_mal.ls -SOURCES_LISP = env.ls core.ls stepA_mal.ls SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) BINS = $(SOURCES:%.ls=%.js) @@ -30,11 +29,3 @@ stepA_mal.js: utils.js reader.js printer.js env.js core.js clean: rm -f $(BINS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `egrep "^\w*#|^\w*$$" $^ | wc` "[comments/blanks]" diff --git a/logo/Makefile b/logo/Makefile index 2beda63bde..bb1b747413 100644 --- a/logo/Makefile +++ b/logo/Makefile @@ -2,7 +2,7 @@ SOURCES_BASE = readline.lg types.lg reader.lg printer.lg SOURCES_LISP = env.lg core.lg stepA_mal.lg SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -.PHONY: all dist clean stats stats-lisp +.PHONY: all dist clean all: @true @@ -19,10 +19,3 @@ mal: mal.lg clean: rm -f mal.lg mal - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/lua/Makefile b/lua/Makefile index 042e3b0cde..44778cf75b 100644 --- a/lua/Makefile +++ b/lua/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = utils.lua types.lua reader.lua printer.lua SOURCES_LISP = env.lua core.lua stepA_mal.lua SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -28,16 +26,6 @@ clean: rm -f linenoise.so mal.lua mal rm -rf lib/lua/5.1 -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - - .PHONY: libs libs: linenoise.so diff --git a/make/Makefile b/make/Makefile index 913ae19dd1..f8a16ebb1c 100644 --- a/make/Makefile +++ b/make/Makefile @@ -22,14 +22,7 @@ mal: mal.mk clean: rm -f mal.mk mal -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +.PHONY: tests $(TESTS) tests: $(TESTS) diff --git a/mal/Makefile b/mal/Makefile index 322c9cad5c..e54f29c8de 100644 --- a/mal/Makefile +++ b/mal/Makefile @@ -1,10 +1,3 @@ - -TESTS = - -SOURCES_BASE = -SOURCES_LISP = env.mal core.mal stepA_mal.mal -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: mal.mal mal.mal: stepA_mal.mal @@ -12,19 +5,3 @@ mal.mal: stepA_mal.mal clean: rm -f mal.mal - -#.PHONY: stats tests $(TESTS) -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -#tests: $(TESTS) -# -#$(TESTS): -# @echo "Running $@"; \ -# python $@ || exit 1; \ diff --git a/matlab/Makefile b/matlab/Makefile index 1363956831..82fa2ef848 100644 --- a/matlab/Makefile +++ b/matlab/Makefile @@ -1,20 +1,4 @@ -SOURCES_BASE = type_utils.m Dict.m types/Nil.m types/MalException.m \ - types/Symbol.m types/List.m types/Vector.m \ - types/HashMap.m types/Function.m types/Atom.m \ - types/Reader.m reader.m printer.m -SOURCES_LISP = Env.m core.m stepA_mal.m -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: clean: -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*%|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*%|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/miniMAL/Makefile b/miniMAL/Makefile index 71c717e956..4d5a808de2 100644 --- a/miniMAL/Makefile +++ b/miniMAL/Makefile @@ -28,12 +28,3 @@ mal: mal.json chmod +x $@ clean: - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/nasm/Makefile b/nasm/Makefile index bb690ea120..a3cf08c0aa 100644 --- a/nasm/Makefile +++ b/nasm/Makefile @@ -15,18 +15,3 @@ all: $(STEPS) .PHONY: clean clean: rm -f $(STEPS) $(STEPS:%=%.o) - -###################### - -SOURCES_BASE = reader.asm printer.asm types.asm system.asm exceptions.asm -SOURCES_LISP = env.asm core.asm stepA_mal.asm -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -.PHONY: stats stats-lisp - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/nim/Makefile b/nim/Makefile index 9b145d653f..11fd6cb91f 100644 --- a/nim/Makefile +++ b/nim/Makefile @@ -1,8 +1,6 @@ ##################### SOURCES_BASE = types.nim reader.nim printer.nim -SOURCES_LISP = env.nim core.nim stepA_mal.nim -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) SOURCES_REBUILD = $(SOURCES_BASE) env.nim core.nim ##################### @@ -27,12 +25,3 @@ $(BINS): %: %.nim $(SOURCES_REBUILD) clean: rm -rf nimcache-*/ $(BINS) rm -f mal - -.PHONY: stats stats-lisp - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/objc/Makefile b/objc/Makefile index 4afffc62ae..7e6fa2a07c 100644 --- a/objc/Makefile +++ b/objc/Makefile @@ -4,9 +4,6 @@ STEP2_DEPS = $(STEP1_DEPS) STEP3_DEPS = $(STEP2_DEPS) env.m STEP4_DEPS = $(STEP3_DEPS) malfunc.h malfunc.m core.h core.m -SOURCES = $(STEP4_DEPS) stepA_mal.m -SOURCES_LISP = env.h env.m core.h core.m stepA_mal.m - STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ step8_macros step9_try stepA_mal @@ -51,12 +48,3 @@ step%: step%.m clean: rm -f $(STEPS) *.o *.d mal - -.PHONY: stats tests - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/objpascal/Makefile b/objpascal/Makefile index af938fbfd5..b8efc48c43 100644 --- a/objpascal/Makefile +++ b/objpascal/Makefile @@ -8,10 +8,6 @@ STEP1_DEPS = $(STEP0_DEPS) mal_types.pas reader.pas printer.pas STEP3_DEPS = $(STEP1_DEPS) mal_env.pas STEP4_DEPS = $(STEP3_DEPS) core.pas -SOURCES = mal_readline.pas mal_types.pas mal_func.pas \ - reader.pas printer.pas mal_env.pas core.pas stepA_mal.pas -SOURCES_LISP = mal_env.pas core.pas stepA_mal.pas - ##################### DEBUG = -gl @@ -33,13 +29,3 @@ step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal clean: rm -f $(STEPS:%.pas=%) *.o *.ppu regexpr/Source/*.o regexpr/Source/*.ppu mal - -.PHONY: stats stats-lisp - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/ocaml/Makefile b/ocaml/Makefile index 6a2bb69ae1..a12f3fc162 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -30,11 +30,4 @@ $(STEP_BINS): %: %.ml $(MAL_LIB) clean: rm -f $(STEP_BINS) mal mal_lib.* *.cmo *.cmx *.cmi *.o -stats: $(MODULES) stepA_mal.ml - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\(\*|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: env.ml core.ml stepA_mal.ml - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\(\*|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -.PHONY: all repl clean stats stats-lisp +.PHONY: all repl clean diff --git a/perl/Makefile b/perl/Makefile index 947edc46ef..ec18d485f0 100644 --- a/perl/Makefile +++ b/perl/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = readline.pm types.pm reader.pm printer.pm \ interop.pm SOURCES_LISP = env.pm core.pm stepA_mal.pl @@ -25,18 +23,3 @@ mal: mal.pl clean: rm -f mal.pl mal fatpacker.trace packlists fatlib/* [ -d fatlib ] && rmdir fatlib || true - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ruby $@ || exit 1; \ diff --git a/perl6/Makefile b/perl6/Makefile index bd88eee87c..d2e469ecd4 100644 --- a/perl6/Makefile +++ b/perl6/Makefile @@ -1,18 +1,4 @@ - -SOURCES_BASE = types.pm reader.pm printer.pm -SOURCES_LISP = env.pm core.pm stepA_mal.pl -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: @true -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - - +clean: diff --git a/php/Makefile b/php/Makefile index fbf83b0a3b..1682d6c40f 100644 --- a/php/Makefile +++ b/php/Makefile @@ -1,6 +1,3 @@ - -TESTS = - SOURCES_BASE = readline.php types.php reader.php printer.php interop.php SOURCES_LISP = env.php core.php stepA_mal.php SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -22,18 +19,3 @@ mal-web.php: mal.php clean: rm -f mal.php mal mal-web.php - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*//|^[[:space:]]/\*|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*//|^[[:space:]]/\*|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - php $@ || exit 1; \ diff --git a/picolisp/Makefile b/picolisp/Makefile index 2ee2780a22..7af3113c71 100644 --- a/picolisp/Makefile +++ b/picolisp/Makefile @@ -1,17 +1,3 @@ -SOURCES_BASE = readline.l reader.l printer.l types.l -SOURCES_LISP = env.l func.l core.l stepA_mal.l -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: clean: - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/plpgsql/Makefile b/plpgsql/Makefile index c7eb4a47ae..7af3113c71 100644 --- a/plpgsql/Makefile +++ b/plpgsql/Makefile @@ -1,14 +1,3 @@ -SOURCES_LISP = envs.sql core.sql stepA_mal.sql -SOURCES = wrap.sh io.sql init.sql types.sql reader.sql printer.sql $(SOURCES_LISP) - all: -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - +clean: diff --git a/plsql/Makefile b/plsql/Makefile index 2660df0919..7af3113c71 100644 --- a/plsql/Makefile +++ b/plsql/Makefile @@ -1,12 +1,3 @@ -SOURCES_LISP = env.sql core.sql stepA_mal.sql -SOURCES = wrap.sh login.sql io.sql types.sql reader.sql printer.sql $(SOURCES_LISP) - -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*--|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +all: +clean: diff --git a/powershell/Makefile b/powershell/Makefile index 24dd3614d6..b8722e6d92 100644 --- a/powershell/Makefile +++ b/powershell/Makefile @@ -1,15 +1,4 @@ -SOURCES_BASE = types.psm1 reader.psm1 printer.psm1 -SOURCES_LISP = env.psm1 core.psm1 stepA_mal.ps1 -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: true -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" +clean: diff --git a/ps/Makefile b/ps/Makefile index 67741380c3..98a0d37408 100644 --- a/ps/Makefile +++ b/ps/Makefile @@ -1,6 +1,3 @@ - -TESTS = - SOURCES_BASE = types.ps reader.ps printer.ps SOURCES_LISP = env.ps core.ps stepA_mal.ps SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -21,19 +18,3 @@ mal: mal.ps clean: rm -f mal.ps mal - - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*%|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*%|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - gs -q -dNODISPLAY -- $@ || exit 1; \ diff --git a/python/Makefile b/python/Makefile index c16b83ffe9..2403ecd25f 100644 --- a/python/Makefile +++ b/python/Makefile @@ -1,7 +1,3 @@ - -TESTS = - - SOURCES_BASE = mal_readline.py mal_types.py reader.py printer.py SOURCES_LISP = env.py core.py stepA_mal.py SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -24,18 +20,3 @@ mal: mal.pyz clean: rm -f mal.pyz mal - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - python $@ || exit 1; \ diff --git a/r/Makefile b/r/Makefile index 85e3247fac..f9ec4a7491 100644 --- a/r/Makefile +++ b/r/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = readline.r types.r reader.r printer.r SOURCES_LISP = env.r core.r stepA_mal.r SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -19,16 +17,6 @@ mal: mal.r clean: rm -f mal.r mal -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - - .PHONY: libs: lib/rdyncall diff --git a/racket/Makefile b/racket/Makefile index 17b07dcd28..89bcac4ae0 100644 --- a/racket/Makefile +++ b/racket/Makefile @@ -12,12 +12,3 @@ mal: $(SOURCES) clean: rm -f mal - -.PHONY: stats - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/rexx/Makefile b/rexx/Makefile index 151ff038d6..b5a49b3b94 100644 --- a/rexx/Makefile +++ b/rexx/Makefile @@ -1,9 +1,3 @@ -TESTS = - -SOURCES_BASE = readline.rexx types.rexx reader.rexx printer.rexx -SOURCES_LISP = env.rexx core.rexx stepA_mal.rexx -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - SRCS = step0_repl.rexx step1_read_print.rexx step2_eval.rexx step3_env.rexx \ step4_if_fn_do.rexx step5_tco.rexx step6_file.rexx step7_quote.rexx \ step8_macros.rexx step9_try.rexx stepA_mal.rexx @@ -27,17 +21,4 @@ $(PREPROCESSED): %.rexxpp: %.rexx readline.rexx types.rexx reader.rexx printer.r clean: rm -f mal.rexx mal *.rexxpp -.PHONY: all dist clean stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - rexx $@ || exit 1; \ +.PHONY: all dist clean diff --git a/rpython/Makefile b/rpython/Makefile index a86b4dd499..95a38adfd6 100644 --- a/rpython/Makefile +++ b/rpython/Makefile @@ -4,10 +4,6 @@ RPYTHON = rpython UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) -SOURCES_BASE = mal_readline.py mal_types.py reader.py printer.py -SOURCES_LISP = env.py core.py stepA_mal.py -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: $(STEPS) dist: mal @@ -28,16 +24,9 @@ step1_read_print step2_eval: $(STEP1_DEPS) step3_env: $(STEP3_DEPS) $(UPPER_STEPS): $(STEP4_DEPS) -.PHONY: clean stats stats-lisp +.PHONY: clean clean: rm -f mal $(STEPS) *.pyc rm -rf __pycache__ -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/ruby/Makefile b/ruby/Makefile index c677e1a237..13470a4e3d 100644 --- a/ruby/Makefile +++ b/ruby/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = mal_readline.rb types.rb reader.rb printer.rb SOURCES_LISP = env.rb core.rb stepA_mal.rb SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -19,18 +17,3 @@ mal: mal.rb clean: rm -f mal.rb mal - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ruby $@ || exit 1; \ diff --git a/rust/Makefile b/rust/Makefile index 49fc80fb21..107815fb88 100644 --- a/rust/Makefile +++ b/rust/Makefile @@ -2,10 +2,6 @@ UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) -SOURCES_BASE = types.rs reader.rs printer.rs -SOURCES_LISP = env.rs core.rs stepA_mal.rs -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - all: $(STEPS) dist: mal @@ -27,17 +23,9 @@ step1_read_print step2_eval: $(STEP1_DEPS) step3_env: $(STEP3_DEPS) $(UPPER_STEPS): $(STEP4_DEPS) -.PHONY: clean stats stats-lisp +.PHONY: clean clean: cargo clean rm -f $(STEPS) rm -f mal - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/scala/Makefile b/scala/Makefile index 1713ad5feb..12ca5b834b 100644 --- a/scala/Makefile +++ b/scala/Makefile @@ -1,5 +1,3 @@ -TESTS = - SOURCES_BASE = types.scala reader.scala printer.scala SOURCES_LISP = env.scala core.scala stepA_mal.scala SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -22,17 +20,4 @@ $(TARGET_DIR)/classes/step%.class: step%.scala $(SOURCES) clean: rm -rf mal target -.PHONY: all dist clean stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ruby $@ || exit 1; \ +.PHONY: all dist clean diff --git a/scheme/Makefile b/scheme/Makefile index 2239360349..a1a1d62dbb 100644 --- a/scheme/Makefile +++ b/scheme/Makefile @@ -1,6 +1,3 @@ -SOURCES_BASE = lib/util.sld lib/reader.sld lib/printer.sld lib/types.sld -SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco BINS += step6_file step7_quote step8_macros step9_try stepA_mal scheme_MODE ?= chibi @@ -62,7 +59,7 @@ RMR = rm -rf all: $(STEPS) -.PHONY: clean stats stats-lisp +.PHONY: clean .PRECIOUS: lib/%.scm eggs/lib.%.scm eggs/r7rs.so: @@ -105,10 +102,3 @@ clean: $(RM) lib.*.scm *.so *.c *.o $(BINS) $(RM) eggs/* $(RMR) out - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/skew/Makefile b/skew/Makefile index b13d5f5427..58bd6641fc 100644 --- a/skew/Makefile +++ b/skew/Makefile @@ -2,8 +2,6 @@ STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ step5_tco step6_file step7_quote step8_macros step9_try stepA_mal SOURCES_BASE = util.sk types.sk reader.sk printer.sk -SOURCES_LISP = env.sk core.sk stepA_mal.sk -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) STEP3_DEPS = $(SOURCES_BASE) env.sk STEP4_DEPS = $(STEP3_DEPS) core.sk @@ -26,11 +24,4 @@ mal: stepA_mal.js clean: rm -rf step*.js mal -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -.PHONY: all dist clean stats stats-lisp +.PHONY: all dist clean diff --git a/swift/Makefile b/swift/Makefile index 472d7a0aff..6372e0e043 100644 --- a/swift/Makefile +++ b/swift/Makefile @@ -226,16 +226,3 @@ dump: @echo " SWIFT = $(SWIFT)" @echo "SDKROOT = $(SDKROOT)" @echo " STEPS = $(call get_all_step_numbers)" - -# -# Display source stats -# -.PHONY: stats tests $(TESTS) - -stats: bridging-header.h $(UTIL_SRC) ./stepA_mal.swift - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: ./env.swift ./core.swift ./stepA_mal.swift - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/swift3/Makefile b/swift3/Makefile index 1a16beae7c..a76309c52c 100644 --- a/swift3/Makefile +++ b/swift3/Makefile @@ -7,9 +7,6 @@ endif STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift -SOURCES = $(STEP4_DEPS) Sources/stepA_mal/main.swift -SOURCES_LISP = Sources/env.swift Sources/core.swift Sources/stepA_mal/main.swift - STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ step8_macros step9_try stepA_mal @@ -30,11 +27,3 @@ step%: Sources/step%/main.swift clean: rm -f $(STEPS) mal -.PHONY: stats tests - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/swift4/Makefile b/swift4/Makefile index 1a16beae7c..5bb375446d 100644 --- a/swift4/Makefile +++ b/swift4/Makefile @@ -7,9 +7,6 @@ endif STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift -SOURCES = $(STEP4_DEPS) Sources/stepA_mal/main.swift -SOURCES_LISP = Sources/env.swift Sources/core.swift Sources/stepA_mal/main.swift - STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ step8_macros step9_try stepA_mal @@ -29,12 +26,3 @@ step%: Sources/step%/main.swift clean: rm -f $(STEPS) mal - -.PHONY: stats tests - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/tcl/Makefile b/tcl/Makefile index 5105437e71..ba4ddbb379 100644 --- a/tcl/Makefile +++ b/tcl/Makefile @@ -2,8 +2,6 @@ SOURCES_BASE = mal_readline.tcl types.tcl reader.tcl printer.tcl SOURCES_LISP = env.tcl core.tcl stepA_mal.tcl SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -.PHONY: stats stats-lisp - all: true @@ -19,11 +17,3 @@ mal: mal.tcl clean: rm -f mal.tcl mal - - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/ts/Makefile b/ts/Makefile index 5b36261c10..1ea5a79e59 100644 --- a/ts/Makefile +++ b/ts/Makefile @@ -1,7 +1,3 @@ -SOURCES_BASE = types.ts reader.ts printer.ts -SOURCES_LISP = env.ts core.ts stepA_mal.ts -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - STEPS = step0_repl step1_read_print step2_eval step3_env \ step4_if_fn_do step5_tco step6_file step7_quote \ step8_macros step9_try stepA_mal @@ -15,16 +11,9 @@ step%.js: node_modules types.ts reader.ts printer.ts env.ts core.ts step%.ts ./node_modules/.bin/tsc -p ./ -.PHONY: ts clean stats tests $(TESTS) +.PHONY: ts clean ts: $(foreach s,$(STEPS),$(s).js) clean: rm -f *.js - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" diff --git a/vb/Makefile b/vb/Makefile index ce5145a08f..4f269959e1 100644 --- a/vb/Makefile +++ b/vb/Makefile @@ -2,8 +2,6 @@ DEBUG = -TESTS = - SOURCES_BASE = readline.vb types.vb reader.vb printer.vb SOURCES_LISP = env.vb core.vb stepA_mal.vb SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) @@ -39,18 +37,3 @@ mal_vb.dll: mal_cs.dll $(LIB_VB_SRCS) clean: rm -f *.dll *.exe *.mdb - -.PHONY: stats tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*'|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*'|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ./$@ || exit 1; \ diff --git a/vhdl/Makefile b/vhdl/Makefile index dcca4a11f8..e76b8e104a 100644 --- a/vhdl/Makefile +++ b/vhdl/Makefile @@ -1,11 +1,3 @@ -TESTS = - -SOURCES_BASE = pkg_readline.vhdl types.vhdl printer.vhdl reader.vhdl -SOURCES_LISP = env.vhdl core.vhdl stepA_mal.vhdl -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -##################### - SRCS = step0_repl.vhdl step1_read_print.vhdl step2_eval.vhdl step3_env.vhdl \ step4_if_fn_do.vhdl step5_tco.vhdl step6_file.vhdl step7_quote.vhdl \ step8_macros.vhdl step9_try.vhdl stepA_mal.vhdl @@ -41,18 +33,3 @@ $(BINS): %: %.o clean: rm -f $(OBJS) $(BINS) $(OTHER_OBJS) work-obj93.cf mal - -.PHONY: stats stats-lisp tests $(TESTS) - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - ./$@ || exit 1; \ diff --git a/vimscript/Makefile b/vimscript/Makefile index 5062dafb31..da5409c3bf 100644 --- a/vimscript/Makefile +++ b/vimscript/Makefile @@ -27,11 +27,4 @@ vimextras.o: vimextras.c clean: rm -f vimextras.o libvimextras.so mal.vim mal -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - -.PHONY: stats stats-lisp clean +.PHONY: clean diff --git a/wasm/Makefile b/wasm/Makefile index 02d4ea1654..cd30392b34 100644 --- a/wasm/Makefile +++ b/wasm/Makefile @@ -31,16 +31,3 @@ step7_quote.wasm step8_macros.wasm step9_try.wasm stepA_mal.wasm: $(STEP4_DEPS) clean: rm -f *.wat *.wasm - -.PHONY: stats tests - -SOURCES_ALL = $(filter %.wam,$(STEP4_DEPS)) stepA_mal.wam -SOURCES_LISP = $(filter-out $(STEP1_DEPS),$(SOURCES_ALL)) - -stats: $(SOURCES_ALL) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" - diff --git a/yorick/Makefile b/yorick/Makefile index ccc3d68740..04f60c4e65 100644 --- a/yorick/Makefile +++ b/yorick/Makefile @@ -2,7 +2,7 @@ SOURCES_BASE = hash.i types.i reader.i printer.i SOURCES_LISP = env.i core.i stepA_mal.i SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -.PHONY: all dist clean stats stats-lisp +.PHONY: all dist clean all: dist @@ -15,10 +15,3 @@ mal: $(SOURCES) clean: rm -f mal - -stats: $(SOURCES) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" -stats-lisp: $(SOURCES_LISP) - @wc $^ - @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]" From 833fc8cc19b67c5805bed722d5b7d9bbcf574e33 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Mar 2019 22:50:03 -0500 Subject: [PATCH 0499/1998] README: order and names updates. --- README.md | 74 +++++++++++++++++++++++++++---------------------------- 1 file changed, 37 insertions(+), 37 deletions(-) diff --git a/README.md b/README.md index 9fc40d3c33..8506574d34 100644 --- a/README.md +++ b/README.md @@ -11,16 +11,16 @@ | Language | Creator | | -------- | ------- | | [Ada](#ada) | [Chris Moore](https://github.com/zmower) | -| [GNU awk](#gnu-awk) | [Miutsuru Kariya](https://github.com/kariya-mitsuru) | +| [GNU Awk](#gnu-awk) | [Miutsuru Kariya](https://github.com/kariya-mitsuru) | | [Bash 4](#bash-4) | [Joel Martin](https://github.com/kanaka) | | [BASIC](#basic-c64-and-qbasic) (C64 & QBasic) | [Joel Martin](https://github.com/kanaka) | | [C](#c) | [Joel Martin](https://github.com/kanaka) | | [C++](#c-1) | [Stephen Thirlwall](https://github.com/sdt) | | [C#](#c-2) | [Joel Martin](https://github.com/kanaka) | | [ChucK](#chuck) | [Vasilij Schneidermann](https://github.com/wasamasa) | -| [Common Lisp](#common-lisp) | [Iqbal Ansari](https://github.com/iqbalansari) | | [Clojure](#clojure) (Clojure & ClojureScript) | [Joel Martin](https://github.com/kanaka) | | [CoffeeScript](#coffeescript) | [Joel Martin](https://github.com/kanaka) | +| [Common Lisp](#common-lisp) | [Iqbal Ansari](https://github.com/iqbalansari) | | [Crystal](#crystal) | [Linda_pp](https://github.com/rhysd) | | [D](#d) | [Dov Murik](https://github.com/dubek) | | [Dart](#dart) | [Harry Terkelsen](https://github.com/hterkelsen) | @@ -33,10 +33,10 @@ | [Factor](#factor) | [Jordan Lewis](https://github.com/jordanlewis) | | [Fantom](#fantom) | [Dov Murik](https://github.com/dubek) | | [Forth](#forth) | [Chris Houser](https://github.com/chouser) | -| [Go](#go) | [Joel Martin](https://github.com/kanaka) | -| [Groovy](#groovy) | [Joel Martin](https://github.com/kanaka) | | [GNU Guile](#gnu-guile-21) | [Mu Lei](https://github.com/NalaGinrut) | | [GNU Smalltalk](#gnu-smalltalk) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Go](#go) | [Joel Martin](https://github.com/kanaka) | +| [Groovy](#groovy) | [Joel Martin](https://github.com/kanaka) | | [Haskell](#haskell) | [Joel Martin](https://github.com/kanaka) | | [Haxe](#haxe-neko-python-c-and-javascript) (Neko, Python, C++, & JS) | [Joel Martin](https://github.com/kanaka) | | [Hy](#hy) | [Joel Martin](https://github.com/kanaka) | @@ -50,7 +50,7 @@ | [Lua](#lua) | [Joel Martin](https://github.com/kanaka) | | [GNU Make](#gnu-make-381) | [Joel Martin](https://github.com/kanaka) | | [mal itself](#mal) | [Joel Martin](https://github.com/kanaka) | -| [Matlab](#matlab-gnu-octave-and-matlab) (GNU Octave & MATLAB) | [Joel Martin](https://github.com/kanaka) | +| [MATLAB](#matlab-gnu-octave-and-matlab) (GNU Octave & MATLAB) | [Joel Martin](https://github.com/kanaka) | | [miniMAL](#minimal) ([Repo](https://github.com/kanaka/miniMAL), [Demo](https://kanaka.github.io/miniMAL/)) | [Joel Martin](https://github.com/kanaka) | | [NASM](#nasm) | [Ben Dudson](https://github.com/bendudson) | | [Nim](#nim-0170) | [Dennis Felsing](https://github.com/def-) | @@ -63,7 +63,7 @@ | [Picolisp](#picolisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | | [PL/pgSQL](#plpgsql-postgres-sql-procedural-language) (Postgres) | [Joel Martin](https://github.com/kanaka) | | [PL/SQL](#plsql-oracle-sql-procedural-language) (Oracle) | [Joel Martin](https://github.com/kanaka) | -| [Postscript](#postscript-level-23) | [Joel Martin](https://github.com/kanaka) | +| [PostScript](#postscript-level-23) | [Joel Martin](https://github.com/kanaka) | | [PowerShell](#powershell) | [Joel Martin](https://github.com/kanaka) | | [Python](#python-2x-and-3x) (2.X & 3.X) | [Joel Martin](https://github.com/kanaka) | | [RPython](#rpython) | [Joel Martin](https://github.com/kanaka) | @@ -75,7 +75,7 @@ | [Scala](#scala) | [Joel Martin](https://github.com/kanaka) | | [Scheme (R7RS)](#scheme-r7rs) | [Vasilij Schneidermann](https://github.com/wasamasa) | | [Skew](#skew) | [Dov Murik](https://github.com/dubek) | -| [Swift](#swift) | [Keith Rollin](https://github.com/keith-rollin) | +| [Swift 2](#swift) | [Keith Rollin](https://github.com/keith-rollin) | | [Swift 3](#swift-3) | [Joel Martin](https://github.com/kanaka) | | [Swift 4](#swift-4) | [陆é¥](https://github.com/LispLY) | | [Tcl](#tcl-86) | [Dov Murik](https://github.com/dubek) | @@ -263,19 +263,6 @@ cd chuck ./run ``` -### Common Lisp - -The implementation has been tested with SBCL, CCL, CMUCL, GNU CLISP, ECL and -Allegro CL on Ubuntu 16.04 and Ubuntu 12.04, see -the [README](common-lisp/README.org) for more details. Provided you have the -dependencies mentioned installed, do the following to run the implementation - -``` -cd common-lisp -make -./run -``` - ### Clojure For the most part the Clojure implementation requires Clojure 1.5, @@ -294,6 +281,19 @@ cd coffee coffee ./stepX_YYY ``` +### Common Lisp + +The implementation has been tested with SBCL, CCL, CMUCL, GNU CLISP, ECL and +Allegro CL on Ubuntu 16.04 and Ubuntu 12.04, see +the [README](common-lisp/README.org) for more details. Provided you have the +dependencies mentioned installed, do the following to run the implementation + +``` +cd common-lisp +make +./run +``` + ### Crystal The Crystal implementation of mal has been tested with Crystal 0.26.1. @@ -427,6 +427,22 @@ cd forth gforth stepX_YYY.fs ``` +### GNU Guile 2.1+ + +``` +cd guile +guile -L ./ stepX_YYY.scm +``` + +### GNU Smalltalk + +The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. + +``` +cd gnu-smalltalk +./run +``` + ### Go The Go implementation of mal requires that go is installed on on the @@ -450,22 +466,6 @@ make groovy ./stepX_YYY.groovy ``` -### GNU Guile 2.1+ - -``` -cd guile -guile -L ./ stepX_YYY.scm -``` - -### GNU Smalltalk - -The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. - -``` -cd gnu-smalltalk -./run -``` - ### Haskell The Haskell implementation requires the ghc compiler version 7.10.1 or @@ -660,7 +660,7 @@ make ./stepX_YYY ``` -### MatLab (GNU Octave and MATLAB) +### MATLAB (GNU Octave and MATLAB) The MatLab implementation has been tested with GNU Octave 4.2.1. It has also been tested with MATLAB version R2014a on Linux. Note that From 1eff25447a0a0078b272502e15937c721c27d721 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Mon, 18 Mar 2019 00:31:02 -0500 Subject: [PATCH 0500/1998] Stats collection script, dynamic scatter plot page --- docs/graph/all_data.json | 1303 +++++++++++++++++++++++++++++++++ docs/graph/base_data.yaml | 79 ++ docs/graph/collect_data.js | 222 ++++++ docs/graph/graph_languages.js | 214 ++++++ docs/graph/index.html | 99 +++ docs/graph/package.json | 10 + 6 files changed, 1927 insertions(+) create mode 100644 docs/graph/all_data.json create mode 100644 docs/graph/base_data.yaml create mode 100755 docs/graph/collect_data.js create mode 100644 docs/graph/graph_languages.js create mode 100644 docs/graph/index.html create mode 100644 docs/graph/package.json diff --git a/docs/graph/all_data.json b/docs/graph/all_data.json new file mode 100644 index 0000000000..9126bc9f2d --- /dev/null +++ b/docs/graph/all_data.json @@ -0,0 +1,1303 @@ +{ + "ada": { + "dir": "ada", + "name": "Ada", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 9, + "perf2": 28, + "perf3": 1089, + "star_count": null, + "rank": 68, + "sloc": 5942, + "files": 29, + "author_name": "Chris Moore", + "author_url": "https://github.com/zmower", + "lloc": 3759 + }, + "awk": { + "dir": "awk", + "name": "GNU Awk", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 14, + "perf2": 47, + "perf3": 702, + "star_count": 355, + "rank": 50, + "sloc": 5213, + "files": 17, + "author_name": "Miutsuru Kariya", + "author_url": "https://github.com/kariya-mitsuru", + "lloc": 0 + }, + "bash": { + "dir": "bash", + "name": "Bash 4", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 1681, + "perf2": 7748, + "perf3": 5, + "star_count": 59906, + "rank": 14, + "sloc": 2392, + "files": 18, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "basic": { + "dir": "basic", + "name": "BASIC", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [ + "cbm", + "qbasic" + ], + "perf1": 11, + "perf2": 49, + "perf3": 871, + "star_count": null, + "rank": 68, + "sloc": 3963, + "files": 23, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 3956 + }, + "c": { + "dir": "c", + "name": "C", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0.9, + "perf2": 2, + "perf3": 17211, + "star_count": 90804, + "rank": 9, + "sloc": 3701, + "files": 26, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 2012 + }, + "cpp": { + "dir": "cpp", + "name": "C++", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0.9, + "perf2": 1, + "perf3": 16045, + "star_count": 139366, + "rank": 6, + "sloc": 3532, + "files": 29, + "author_name": "Stephen Thirlwall", + "author_url": "https://github.com/sdt", + "lloc": 1617 + }, + "cs": { + "dir": "cs", + "name": "C#", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 9, + "perf2": 10, + "perf3": 14958, + "star_count": 76670, + "rank": 10, + "sloc": 3396, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1760 + }, + "chuck": { + "dir": "chuck", + "name": "ChucK", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 35, + "perf2": 113, + "perf3": 132, + "star_count": null, + "rank": 68, + "sloc": 4962, + "files": 98, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "lloc": 1796 + }, + "clojure": { + "dir": "clojure", + "name": "Clojure", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [ + "clj", + "cljs" + ], + "perf1": 25, + "perf2": 66, + "perf3": 2373, + "star_count": 5502, + "rank": 27, + "sloc": 1207, + "files": 23, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "coffee": { + "dir": "coffee", + "name": "CoffeeScript", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 7, + "perf2": 33, + "perf3": 18111, + "star_count": 8569, + "rank": 22, + "sloc": 1073, + "files": 21, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "common-lisp": { + "dir": "common-lisp", + "name": "Common Lisp", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 1, + "perf2": 2, + "perf3": 14665, + "star_count": 1146, + "rank": 38, + "sloc": 2607, + "files": 22, + "author_name": "Iqbal Ansari", + "author_url": "https://github.com/iqbalansari", + "lloc": 0 + }, + "crystal": { + "dir": "crystal", + "name": "Crystal", + "syntax": "OTHER", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 2, + "perf3": 28255, + "star_count": 938, + "rank": 41, + "sloc": 2157, + "files": 18, + "author_name": "Linda_pp", + "author_url": "https://github.com/rhysd", + "lloc": 0 + }, + "d": { + "dir": "d", + "name": "D", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0.9, + "perf2": 2, + "perf3": 15621, + "star_count": 653, + "rank": 45, + "sloc": 2979, + "files": 18, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 1434 + }, + "dart": { + "dir": "dart", + "name": "Dart", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 14, + "perf2": 38, + "perf3": 509, + "star_count": 2498, + "rank": 34, + "sloc": 2279, + "files": 18, + "author_name": "Harry Terkelsen", + "author_url": "https://github.com/hterkelsen", + "lloc": 1142 + }, + "elixir": { + "dir": "elixir", + "name": "Elixir", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 14, + "perf2": 52, + "perf3": 765, + "star_count": 6115, + "rank": 24, + "sloc": 1824, + "files": 20, + "author_name": "Martin Ek", + "author_url": "https://github.com/ekmartin", + "lloc": 0 + }, + "elm": { + "dir": "elm", + "name": "Elm", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 69, + "perf2": 167, + "perf3": 801, + "star_count": 809, + "rank": 43, + "sloc": 5775, + "files": 24, + "author_name": "Jos van Bakel", + "author_url": "https://github.com/c0deaddict", + "lloc": 0 + }, + "elisp": { + "dir": "elisp", + "name": "Emacs Lisp", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 16, + "perf2": 77, + "perf3": 593, + "star_count": 5689, + "rank": 26, + "sloc": 1982, + "files": 20, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "lloc": 0 + }, + "erlang": { + "dir": "erlang", + "name": "Erlang", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 53, + "perf2": 175, + "perf3": 175, + "star_count": 2942, + "rank": 31, + "sloc": 2215, + "files": 18, + "author_name": "Nathan Fiedler", + "author_url": "https://github.com/nlfiedler", + "lloc": 0 + }, + "es6": { + "dir": "es6", + "name": "ES6", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 3, + "perf2": 21, + "perf3": 12079, + "star_count": 668062, + "rank": 2, + "sloc": 1230, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "fsharp": { + "dir": "fsharp", + "name": "F#", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 35, + "perf2": 29, + "perf3": 20634, + "star_count": 950, + "rank": 39, + "sloc": 3033, + "files": 22, + "author_name": "Peter Stephens", + "author_url": "https://github.com/pstephens", + "lloc": 404 + }, + "factor": { + "dir": "factor", + "name": "Factor", + "syntax": "Stack", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 1, + "perf3": 27766, + "star_count": null, + "rank": 68, + "sloc": 1305, + "files": 33, + "author_name": "Jordan Lewis", + "author_url": "https://github.com/jordanlewis", + "lloc": 0 + }, + "fantom": { + "dir": "fantom", + "name": "Fantom", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 14, + "perf2": 31, + "perf3": 40400, + "star_count": null, + "rank": 68, + "sloc": 1768, + "files": 31, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "forth": { + "dir": "forth", + "name": "Forth", + "syntax": "Stack", + "type_check": "OTHER", + "modes": [], + "perf1": 4, + "perf2": 14, + "perf3": 2448, + "star_count": null, + "rank": 68, + "sloc": 3351, + "files": 21, + "author_name": "Chris Houser", + "author_url": "https://github.com/chouser", + "lloc": 0 + }, + "guile": { + "dir": "guile", + "name": "GNU Guile", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 3, + "perf2": 9, + "perf3": 3962, + "star_count": null, + "rank": 68, + "sloc": 1547, + "files": 20, + "author_name": "Mu Lei", + "author_url": "https://github.com/NalaGinrut", + "lloc": 0 + }, + "gnu-smalltalk": { + "dir": "gnu-smalltalk", + "name": "GNU Smalltalk", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 14, + "perf2": 45, + "perf3": 787, + "star_count": 152, + "rank": 55, + "sloc": 2444, + "files": 21, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "lloc": 0 + }, + "go": { + "dir": "go", + "name": "Go", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 3, + "perf3": 10334, + "star_count": 215511, + "rank": 5, + "sloc": 3451, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1792 + }, + "groovy": { + "dir": "groovy", + "name": "Groovy", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 477, + "perf2": 746, + "perf3": 324, + "star_count": 4302, + "rank": 29, + "sloc": 1598, + "files": 19, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "haskell": { + "dir": "haskell", + "name": "Haskell", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 3, + "perf2": 8, + "perf3": 4338, + "star_count": 6312, + "rank": 23, + "sloc": 2011, + "files": 18, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "haxe": { + "dir": "haxe", + "name": "Haxe", + "syntax": "C", + "type_check": "Static", + "modes": [ + "neko", + "python", + "cpp", + "js" + ], + "perf1": 5, + "perf2": 26, + "perf3": 15377, + "star_count": 580, + "rank": 46, + "sloc": 2270, + "files": 23, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1045 + }, + "hy": { + "dir": "hy", + "name": "Hy", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 17, + "perf2": 67, + "perf3": 585, + "star_count": null, + "rank": 68, + "sloc": 1215, + "files": 18, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "io": { + "dir": "io", + "name": "Io", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 357, + "perf2": 1333, + "perf3": 29, + "star_count": null, + "rank": 68, + "sloc": 1262, + "files": 18, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "java": { + "dir": "java", + "name": "Java", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 7, + "perf2": 24, + "perf3": 57275, + "star_count": 255160, + "rank": 4, + "sloc": 3061, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1537 + }, + "js": { + "dir": "js", + "name": "JavaScript", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 3, + "perf2": 22, + "perf3": 14550, + "star_count": 668062, + "rank": 1, + "sloc": 2779, + "files": 33, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "julia": { + "dir": "julia", + "name": "Julia", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 253, + "perf2": 32, + "perf3": 2975, + "star_count": 948, + "rank": 40, + "sloc": 1413, + "files": 19, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "kotlin": { + "dir": "kotlin", + "name": "Kotlin", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 19, + "perf2": 75, + "perf3": 33381, + "star_count": 20958, + "rank": 17, + "sloc": 1571, + "files": 19, + "author_name": "Javier Fernandez-Ivern", + "author_url": "https://github.com/ivern", + "lloc": 0 + }, + "livescript": { + "dir": "livescript", + "name": "LiveScript", + "syntax": "ML", + "type_check": "Dynamic", + "modes": [], + "perf1": 6, + "perf2": 26, + "perf3": 7570, + "star_count": 116, + "rank": 57, + "sloc": 2128, + "files": 19, + "author_name": "Jos van Bakel", + "author_url": "https://github.com/c0deaddict", + "lloc": 0 + }, + "logo": { + "dir": "logo", + "name": "Logo", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 19182, + "perf2": 53948, + "perf3": 0.01, + "star_count": null, + "rank": 68, + "sloc": 2139, + "files": 20, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "lua": { + "dir": "lua", + "name": "Lua", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 10, + "perf2": 44, + "perf3": 955, + "star_count": 8769, + "rank": 21, + "sloc": 1909, + "files": 21, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "make": { + "dir": "make", + "name": "GNU Make", + "syntax": "OTHER", + "type_check": "OTHER", + "modes": [], + "perf1": 5050, + "perf2": 31077, + "perf3": 1, + "star_count": 2034, + "rank": 35, + "sloc": 1821, + "files": 22, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "mal": { + "dir": "mal", + "name": "mal itself", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 277, + "perf2": 1346, + "perf3": 40, + "star_count": null, + "rank": 68, + "sloc": 890, + "files": 13, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "matlab": { + "dir": "matlab", + "name": "MATLAB", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 1709, + "perf2": 6295, + "perf3": 5, + "star_count": 2867, + "rank": 32, + "sloc": 2204, + "files": 27, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "miniMAL": { + "dir": "miniMAL", + "name": "miniMAL", + "syntax": "JSON", + "type_check": "Dynamic", + "modes": [], + "perf1": 1340, + "perf2": 5383, + "perf3": 7, + "star_count": null, + "rank": 68, + "sloc": 1691, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "nasm": { + "dir": "nasm", + "name": "NASM", + "syntax": "OTHER", + "type_check": "OTHER", + "modes": [], + "perf1": 0.9, + "perf2": 2, + "perf3": 24147, + "star_count": 1195, + "rank": 37, + "sloc": 14483, + "files": 19, + "author_name": "Ben Dudson", + "author_url": "https://github.com/bendudson", + "lloc": 0 + }, + "nim": { + "dir": "nim", + "name": "Nim", + "syntax": "Python", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 2, + "perf3": 30900, + "star_count": 529, + "rank": 48, + "sloc": 1423, + "files": 17, + "author_name": "Dennis Felsing", + "author_url": "https://github.com/def-", + "lloc": 0 + }, + "objpascal": { + "dir": "objpascal", + "name": "Object Pascal", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 4, + "perf2": 12, + "perf3": 2830, + "star_count": 1324, + "rank": 36, + "sloc": 6179, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 3971 + }, + "objc": { + "dir": "objc", + "name": "Objective C", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 6, + "perf2": 28, + "perf3": 1599, + "star_count": 48248, + "rank": 16, + "sloc": 2363, + "files": 26, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1059 + }, + "ocaml": { + "dir": "ocaml", + "name": "OCaml", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 2, + "perf3": 23267, + "star_count": 3646, + "rank": 30, + "sloc": 1269, + "files": 17, + "author_name": "Chris Houser", + "author_url": "https://github.com/chouser", + "lloc": 0 + }, + "perl": { + "dir": "perl", + "name": "Perl", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 13, + "perf2": 50, + "perf3": 790, + "star_count": 4679, + "rank": 28, + "sloc": 2265, + "files": 22, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1107 + }, + "perl6": { + "dir": "perl6", + "name": "Perl 6", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 441, + "perf2": 1182, + "perf3": 23, + "star_count": 137, + "rank": 56, + "sloc": 1238, + "files": 18, + "author_name": "Hinrik Örn Sigurðsson", + "author_url": "https://github.com/hinrik", + "lloc": 484 + }, + "php": { + "dir": "php", + "name": "PHP", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 8, + "perf2": 28, + "perf3": 1268, + "star_count": 135579, + "rank": 7, + "sloc": 1998, + "files": 21, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1074 + }, + "picolisp": { + "dir": "picolisp", + "name": "Picolisp", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 7, + "perf3": 6005, + "star_count": null, + "rank": 68, + "sloc": 1366, + "files": 20, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "lloc": 0 + }, + "plpgsql": { + "dir": "plpgsql", + "name": "PL/pgSQL", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 478, + "perf2": 3830, + "perf3": 20, + "star_count": 897, + "rank": 42, + "sloc": 3679, + "files": 21, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "plsql": { + "dir": "plsql", + "name": "PL/SQL", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 19182, + "perf2": 1921, + "perf3": 0.01, + "star_count": 199, + "rank": 53, + "sloc": 4180, + "files": 21, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "powershell": { + "dir": "powershell", + "name": "PowerShell", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 1921, + "perf2": 7832, + "perf3": 5, + "star_count": 5795, + "rank": 25, + "sloc": 1147, + "files": 12, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "ps": { + "dir": "ps", + "name": "PostScript", + "syntax": "Stack", + "type_check": "Dynamic", + "modes": [], + "perf1": 38, + "perf2": 274, + "perf3": 198, + "star_count": null, + "rank": 68, + "sloc": 2482, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "python": { + "dir": "python", + "name": "Python", + "syntax": "Python", + "type_check": "Dynamic", + "modes": [ + "python2", + "python3" + ], + "perf1": 7, + "perf2": 29, + "perf3": 1371, + "star_count": 336045, + "rank": 3, + "sloc": 1358, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 1344 + }, + "rpython": { + "dir": "rpython", + "name": "RPython", + "syntax": "Python", + "type_check": "Static", + "modes": [], + "perf1": 0.9, + "perf2": 1, + "perf3": 69848, + "star_count": null, + "rank": 68, + "sloc": 2102, + "files": 19, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 2096 + }, + "r": { + "dir": "r", + "name": "R", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 78, + "perf2": 295, + "perf3": 117, + "star_count": 2644, + "rank": 33, + "sloc": 1625, + "files": 19, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "racket": { + "dir": "racket", + "name": "Racket", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 7, + "perf3": 4865, + "star_count": 281, + "rank": 51, + "sloc": 1193, + "files": 18, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "rexx": { + "dir": "rexx", + "name": "Rexx", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 160, + "perf2": 660, + "perf3": 61, + "star_count": null, + "rank": 68, + "sloc": 2747, + "files": 19, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "ruby": { + "dir": "ruby", + "name": "Ruby", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 8, + "perf3": 4163, + "star_count": 54043, + "rank": 15, + "sloc": 1291, + "files": 20, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "rust": { + "dir": "rust", + "name": "Rust", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0.9, + "perf2": 1, + "perf3": 16720, + "star_count": 19178, + "rank": 18, + "sloc": 2862, + "files": 18, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 714 + }, + "scala": { + "dir": "scala", + "name": "Scala", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 27, + "perf2": 66, + "perf3": 25785, + "star_count": 13634, + "rank": 19, + "sloc": 1849, + "files": 18, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "scheme": { + "dir": "scheme", + "name": "Scheme (R7RS)", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [ + "chibi", + "kawa", + "gauche", + "chicken", + "sagittarius", + "cyclone", + "foment" + ], + "perf1": 6, + "perf2": 19, + "perf3": 2231, + "star_count": 718, + "rank": 44, + "sloc": 1269, + "files": 13, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "lloc": 0 + }, + "skew": { + "dir": "skew", + "name": "Skew", + "syntax": "OTHER", + "type_check": "Static", + "modes": [], + "perf1": 6, + "perf2": 11, + "perf3": 3608, + "star_count": null, + "rank": 68, + "sloc": 1638, + "files": 19, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "swift": { + "dir": "swift", + "name": "Swift 2", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 2, + "perf2": 6, + "perf3": 5322, + "star_count": 66012, + "rank": 11, + "sloc": 2963, + "files": 14, + "author_name": "Keith Rollin", + "author_url": "https://github.com/keith-rollin", + "lloc": 0 + }, + "swift3": { + "dir": "swift3", + "name": "Swift 3", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 8, + "perf2": 27, + "perf3": 1234, + "star_count": 66012, + "rank": 12, + "sloc": 2362, + "files": 17, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "swift4": { + "dir": "swift4", + "name": "Swift 4", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 5, + "perf2": 16, + "perf3": 2065, + "star_count": 66012, + "rank": 13, + "sloc": 1767, + "files": 17, + "author_name": "陆é¥", + "author_url": "https://github.com/LispLY", + "lloc": 0 + }, + "tcl": { + "dir": "tcl", + "name": "Tcl", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 24, + "perf2": 103, + "perf3": 373, + "star_count": 171, + "rank": 54, + "sloc": 2468, + "files": 20, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "ts": { + "dir": "ts", + "name": "TypeScript", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 4, + "perf2": 14, + "perf3": 26534, + "star_count": 93555, + "rank": 8, + "sloc": 2836, + "files": 20, + "author_name": "Masahiro Wakame", + "author_url": "https://github.com/vvakame", + "lloc": 0 + }, + "vhdl": { + "dir": "vhdl", + "name": "VHDL", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 3, + "perf2": 9, + "perf3": 3342, + "star_count": 217, + "rank": 52, + "sloc": 4258, + "files": 19, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 0 + }, + "vimscript": { + "dir": "vimscript", + "name": "Vimscript", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 219, + "perf2": 1055, + "perf3": 43, + "star_count": 10096, + "rank": 20, + "sloc": 2147, + "files": 22, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 12 + }, + "vb": { + "dir": "vb", + "name": "Visual Basic.NET", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 14, + "perf2": 14, + "perf3": 10121, + "star_count": 578, + "rank": 47, + "sloc": 3839, + "files": 19, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 394 + }, + "wasm": { + "dir": "wasm", + "name": "WebAssembly", + "syntax": "Lisp", + "type_check": "Static", + "modes": [ + "wace_libc", + "node", + "warpy" + ], + "perf1": 2, + "perf2": 10, + "perf3": 3742, + "star_count": 365, + "rank": 49, + "sloc": 5270, + "files": 26, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "lloc": 0 + }, + "yorick": { + "dir": "yorick", + "name": "Yorick", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 67, + "perf2": 288, + "perf3": 147, + "star_count": null, + "rank": 68, + "sloc": 2398, + "files": 19, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "lloc": 210 + } +} \ No newline at end of file diff --git a/docs/graph/base_data.yaml b/docs/graph/base_data.yaml new file mode 100644 index 0000000000..161e47feab --- /dev/null +++ b/docs/graph/base_data.yaml @@ -0,0 +1,79 @@ +headers: + - [dir , name , syntax , type_check , modes] + +languages: + - [ada , Ada , Algol , Static , []] + - [awk , GNU Awk , C , Dynamic , []] + - [bash , Bash 4 , OTHER , Dynamic , []] + - [basic , BASIC , OTHER , Dynamic , [cbm, qbasic]] + - [c , C , C , Static , []] + - [cpp , C++ , C , Static , []] + - [cs , C# , C , Static , []] + - [chuck , ChucK , C , Static , []] + - [clojure , Clojure , Lisp , Dynamic , [clj, cljs]] + - [coffee , CoffeeScript , OTHER , Dynamic , []] + - [common-lisp , Common Lisp , Lisp , Dynamic , []] + - [crystal , Crystal , OTHER , Static , []] + - [d , D , C , Static , []] + - [dart , Dart , C , Static , []] + - [elixir , Elixir , OTHER , Dynamic , []] + - [elm , Elm , ML , Static , []] + - [elisp , Emacs Lisp , Lisp , Dynamic , []] + - [erlang , Erlang , OTHER , Dynamic , []] + - [es6 , ES6 , C , Dynamic , []] + - [fsharp , F# , ML , Static , []] + - [factor , Factor , Stack , Dynamic , []] + - [fantom , Fantom , C , Static , []] + - [forth , Forth , Stack , OTHER , []] + - [guile , GNU Guile , Lisp , Dynamic , []] + - [gnu-smalltalk , GNU Smalltalk , OTHER , Dynamic , []] + - [go , Go , C , Static , []] + - [groovy , Groovy , C , Dynamic , []] + - [haskell , Haskell , ML , Static , []] + - [haxe , Haxe , C , Static , [neko,python,cpp,js]] + - [hy , Hy , Lisp , Dynamic , []] + - [io , Io , OTHER , Dynamic , []] + - [java , Java , C , Static , []] + - [js , JavaScript , C , Dynamic , []] + - [julia , Julia , Algol , Dynamic , []] + - [kotlin , Kotlin , C , Static , []] + - [livescript , LiveScript , ML , Dynamic , []] + - [logo , Logo , OTHER , Dynamic , []] + - [lua , Lua , Algol , Dynamic , []] + - [make , GNU Make , OTHER , OTHER , []] + - [mal , mal itself , Lisp , Dynamic , []] + - [matlab , MATLAB , Algol , Dynamic , []] + - [miniMAL , miniMAL , JSON , Dynamic , []] + - [nasm , NASM , OTHER , OTHER , []] + - [nim , Nim , Python , Static , []] + - [objpascal , Object Pascal , Algol , Static , []] + - [objc , Objective C , C , Static , []] + - [ocaml , OCaml , ML , Static , []] + - [perl , Perl , C , Dynamic , []] + - [perl6 , Perl 6 , C , Dynamic , []] + - [php , PHP , C , Dynamic , []] + - [picolisp , Picolisp , Lisp , Dynamic , []] + - [plpgsql , PL/pgSQL , Algol , Static , []] + - [plsql , PL/SQL , Algol , Static , []] + - [powershell , PowerShell , OTHER , Dynamic , []] + - [ps , PostScript , Stack , Dynamic , []] + - [python , Python , Python , Dynamic , [python2,python3]] + - [rpython , RPython , Python , Static , []] + - [r , R , C , Dynamic , []] + - [racket , Racket , Lisp , Dynamic , []] + - [rexx , Rexx , OTHER , Dynamic , []] + - [ruby , Ruby , OTHER , Dynamic , []] + - [rust , Rust , C , Static , []] + - [scala , Scala , C , Static , []] + - [scheme , Scheme (R7RS) , Lisp , Dynamic , [chibi,kawa,gauche,chicken,sagittarius,cyclone,foment]] + - [skew , Skew , OTHER , Static , []] + - [swift , Swift 2 , C , Static , []] + - [swift3 , Swift 3 , C , Static , []] + - [swift4 , Swift 4 , C , Static , []] + - [tcl , Tcl , OTHER , Dynamic , []] + - [ts , TypeScript , C , Static , []] + - [vhdl , VHDL , Algol , Static , []] + - [vimscript , Vimscript , Algol , Dynamic , []] + - [vb , Visual Basic.NET , Algol , Static , []] + - [wasm , WebAssembly , Lisp , Static , [wace_libc,node,warpy]] + - [yorick , Yorick , C , Dynamic , []] diff --git a/docs/graph/collect_data.js b/docs/graph/collect_data.js new file mode 100755 index 0000000000..efca8a07f6 --- /dev/null +++ b/docs/graph/collect_data.js @@ -0,0 +1,222 @@ +#!/usr/bin/env python + +const { promisify } = require('util') +const readFile = promisify(require('fs').readFile) +const writeFile = promisify(require('fs').writeFile) +const readdir = promisify(require('fs').readdir) +const path = require('path') +const yaml = require('js-yaml') +const request = require('request-promise-native') +const exec = promisify(require('child_process').exec) + +const VERBOSE = process.env['VERBOSE'] || false +const BASE_PATH = process.env['BASE_PATH'] || 'base_data.yaml' +const README_PATH = process.env['README_PATH'] || '../../README.md' +// GitHut Pushes +//const GITHUT_URL = 'https://raw.githubusercontent.com/madnight/githut/gh-pages/gh-push-event_eb2696.json' +// GitHut Stars +const GITHUT_URL = process.env['GITHUT_URL'] || 'https://raw.githubusercontent.com/madnight/githut/gh-pages/gh-star-event_e61175.json' +const MAL_PATH = process.env['MAL_PATH'] || '../../' + + +const githutToNames = { + 'Awk': ['GNU Awk'], + 'Shell': ['Bash 4'], + 'JavaScript': ['JavaScript', 'ES6'], + 'Makefile': ['GNU Make'], + 'Matlab': ['MATLAB'], + 'Assembly': ['NASM'], + 'Pascal': ['Object Pascal'], + 'Objective-C': ['Objective C'], + 'PLpgSQL': ['PL/pgSQL'], + 'PLSQL': ['PL/SQL'], + 'Scheme': ['Scheme (R7RS)'], + 'Smalltalk': ['GNU Smalltalk'], + 'Swift': ['Swift 2', 'Swift 3', 'Swift 4'], + 'Vim script': ['Vimscript'], + 'Visual Basic': ['Visual Basic.NET'], +} + +function vlog(...args) { + if (VERBOSE) { + console.log(...args) + } +} + +function die(code, ...args) { + console.error(...args) + process.exit(code) +} + +async function main() { + const logsPath = path.resolve(process.argv[2]) + const outPath = path.resolve(process.argv[3]) + + vlog(`Loading base data yaml from '${BASE_PATH}`) + const baseYaml = yaml.safeLoad(await readFile(BASE_PATH, 'utf8')) + vlog(`Loading README text from '${README_PATH}`) + const readmeLines = (await readFile(README_PATH, 'utf8')).split(/\n/) + vlog(`Downloading GitHut HTML from '${GITHUT_URL}`) + const githutText = (await request(GITHUT_URL)) + vlog(`Loading log data from '${logsPath}'`) + const logFiles = (await readdir(logsPath)) + .map(x => parseInt(x)) + .sort((a, b) => a - b) + let logData = [] + for (const f of logFiles) { + if (!(/^[0-9]+$/.exec(f))) { continue } + const path = logsPath + "/" + f + logData.push([await readFile(path, 'utf8'), path]) + } + + let dirs = [] + let names = [] + let dataList = [] + let dataByDir = {} + let dataByName = {} + + vlog(`Processing base data`) + for (let d of baseYaml['languages']) { + let data = {'dir': d[0], + 'name': d[1], + 'syntax': d[2], + 'type_check': d[3], + 'modes': d[4], + 'perf1': null, + 'perf2': null, + 'perf3': 0, + 'star_count': null, + 'rank': null, + 'sloc': 0, + 'files': 0} + dirs.push(d[0]) + names.push(d[1]) + dataList.push(data) + dataByDir[d[0]] = data + dataByName[d[1]] = data + } + + vlog(`Processing README implementations table`) + const readme_re = /^\| \[([^\[]*)\].* \| \[([^|]*)\]\(([^|]*)\) *\| *$/ + for (let row of readmeLines.filter(l => /^\| [\[]/.exec(l))) { + t = readme_re.exec(row) + if (t) { + if (t[1] in dataByName) { + let data = dataByName[t[1]] + data.author_name = t[2] + data.author_url = t[3] + } else { + die(1, `README language '${t[1]}' not found in base data`) + } + } else { + die(1, `No match for README table row: ${row}`) + } + } + + vlog(`Processing GitHut data`) + const gdata = githutText.split(/\n/) + .map(JSON.parse) + .filter(d => d.year === "2018" && d.quarter === '4') + .map(d => (d.count = parseInt(d.count), d)) + .sort((a,b) => (a.count > b.count) ? -1 : a.count < b.count ? 1 : 0) + let curRank = 1 + for (let gitem of gdata) { + const names = githutToNames[gitem.name] || [gitem.name] + for (let name of names) { + if (name in dataByName) { + dataByName[name].star_count = gitem.count + dataByName[name].rank = curRank + vlog(` ${dataByName[name].dir} stars: ${gitem.count}, rank: ${curRank}`) + curRank += 1 + } else { + vlog(` ignoring GitHut language ${name}`) + } + } + } + + vlog(`Processing log file data`) + const perf_run_re = /Running:.*\.\.\/tests\/(perf[0-9])\.mal/ + const perf_num_re = /Elapsed time: ([0-9.]+) msecs|iters over 10 seconds: ([0-9]+)/ + for (let [log, file] of logData) { + const dir_match = (/export IMPL=(\S+)/i).exec(log) + if (!dir_match) { die(1, `no IMPL found in ${file}`) } + const dir = dir_match[1] + const data = dataByDir[dir] +// if (data.perf1 !== null) { +// vlog(` ${dir} already has perf data, ignoring ${file}`) +// continue +// } + const perfs = {} + const logLines = log.split(/\n/) + for (let i = 0; i < logLines.length; i++) { + const match_run = perf_run_re.exec(logLines[i]) + if (match_run) { + // Find the result line + let match_num = null + do { + i += 1 + match_num = perf_num_re.exec(logLines[i]) + if (match_num) { + num = parseFloat(match_num[1] || match_num[2], 10) + perfs[match_run[1]] = num + } + } while ((!match_num) && i < logLines.length) + } + } + if ((perfs.perf3 > data.perf3) || !data.perf3) { + data.perf1 = perfs.perf1 + data.perf2 = perfs.perf2 + data.perf3 = perfs.perf3 + vlog(` ${dir}: ${perfs.perf1}, ${perfs.perf2}, ${perfs.perf3}`) + } else { + vlog(` ${dir}: ${perfs.perf1}, ${perfs.perf2}, ${perfs.perf3} (perf3 is worse, ignoring ${file})`) + } + } + + vlog(`Gathering LOC stats`) + const stat_re = /SLOC=([0-9]+).*LLOC=([0-9]+).*in ([0-9]+) files/ + process.chdir(MAL_PATH) + for (let data of dataList) { + vlog(` gathering stats information for ${data.dir}`) + const { stdout, stderr } = await exec(`make "stats^${data.dir}"`) + const match = stat_re.exec(stdout.split(/\n/)[1]) + data.sloc = parseInt(match[1], 10) + data.lloc = parseInt(match[2], 10) + data.files = parseInt(match[3], 10) + } + + vlog(`Filling in missing attributes`) + // leave a gap between actual ranked implementations and those + // with no rankings + maxRank = curRank + 10 + maxPerf1 = dataList.reduce((a, d) => d.perf1 > a ? d.perf1 : a, 0) + maxPerf2 = dataList.reduce((a, d) => d.perf2 > a ? d.perf1 : a, 0) + for (let d of dataList) { + if (d.rank === null) { + vlog(` setting rank to ${maxRank} for ${d.dir}`) + d.rank = maxRank + } + if (d.perf1 === null) { + vlog(` setting perf1 to ${maxPerf1} for ${d.dir}`) + d.perf1 = maxPerf1 + } + if (d.perf2 === null) { + vlog(` setting perf2 to ${maxPerf2} for ${d.dir}`) + d.perf2 = maxPerf2 + } + } + + vlog(`Adjusting perf numbers to avoid 0`) + for (let d of dataList) { + if (d.perf1 === 0) { d.perf1 = 0.9 } + if (d.perf2 === 0) { d.perf2 = 0.9 } + if (d.perf3 === 0) { d.perf3 = 0.01 } + } + + vlog(`Writing full lanaguage data to ${outPath}`) + await writeFile(outPath, JSON.stringify(dataByDir, null, 2)) + + process.exit(0) +} + +main() diff --git a/docs/graph/graph_languages.js b/docs/graph/graph_languages.js new file mode 100644 index 0000000000..3dd3ff67ca --- /dev/null +++ b/docs/graph/graph_languages.js @@ -0,0 +1,214 @@ +const malColors = [ + "#1f77b4","#bf7f0e","#4cb00c","#b62728","#9467bd","#bc664b","#b377c2","#0fbf5f","#bcbd22","#17beef", + "#1f6784","#8f7f0e","#4c800c","#862728","#54678d","#8c564b","#8377c2","#0f8f5f","#8c8d22","#178eef", + "#1f97d4","#ff7f0e","#4cf00c","#f62728","#c467fd","#fc764b","#f377c2","#0fff5f","#fcfd22","#17feef", +] + +const axisSet = new Set(['perf1', 'perf2', 'perf3', 'rank', 'sloc', 'files']) +const colorSet = new Set(['type_check', 'syntax', 'author_name']) +const perfSet = new Set(['perf1', 'perf2', 'perf3']) +const invertSet = new Set(['rank', 'perf1', 'perf2']) +const perfLogSet = new Set(['perf1', 'perf2', 'sloc', 'files']) + +let cfg = { + ckey: 'syntax', + xkey: 'rank', + ykey: 'perf3', + skey: 'sloc', + + xlog: false, + ylog: true, +} + +let allData +let graphData = [] +let chart + +// +// Util functions +// + +function malExtent(data, key) { + let extent = d3.extent(Object.values(data), d => d[key]) + // pad the bottom rank so it's not on the opposite axis line + if (key === 'rank') { + extent[0] = 0.99 // Setting this to 1 breaks log scale render + extent[extent.length-1] += 1 + } + // Replace 0's with 0.01 to prevent divide by zero errors + if (extent[0] === 0) { extent[0] = 0.0001 } + if (extent[extent.length-1] === 0) { extent[extent.length-1] = 0.0001 } + // For rank, perf1 and perf2 reverse the Axis range + if (invertSet.has(key)) { + extent.reverse() + } + return extent +} + +function malScale(log) { + return log ? d3.scale.log() : d3.scale.linear() +} + +function malTickValues(key, log) { + if (log && perfSet.has(key)) { + return [1, 10, 100, 1000, 10000, 100000] + } else { + return null + } +} + +function malCircleSize(key, min, max, val) { + let size = (val || 0.01) - (min - 0.01) + if (invertSet.has(key)) { + size = (max + 0.01) - size + } +// if (perfLogSet.has(key)) { +// size = Math.log(size) +// } +// console.log(key, max, val, size) + return size +} + + +// +// UI / Axis Data / query parameters +// + +// Parser query string and update cfg map with valid config options +(function parseQuery(q) { + const pairs = (q[0] === '?' ? q.substr(1) : q).split('&') + for (const [p1, p2] of pairs.map(p => p.split('='))) { + let k = decodeURIComponent(p1).toLowerCase() + let v = p2 ? decodeURIComponent(p2) : true + if (v in {"true":1,"1":1,"yes":1}) { v = true } + if (v in {"false":1,"0":1,"no":1}) { v = false } + if (k in cfg && (axisSet.has(v) || colorSet.has(v))) { + cfg[k] = v + } + if ((new Set(['xlog', 'ylog'])).has(k) && typeof v === 'boolean') { + cfg[k] = v + } + } +})(location.search) + +// Set the checked elements based on the the cfg +for (const key of Object.keys(cfg)) { + for (const node of document.getElementsByName(key)) { + let val = node.value + if (val in {"true":1,"1":1,"yes":1}) { val = true } + if (val in {"false":1,"0":1,"no":1}) { val = false } + if (val === cfg[key]) { + node.checked = true + } else { + node.checked = false + } + } +} + +// Add onchange to all selector radio buttons/check boxes +for (let input of document.getElementsByClassName('selects')) { + input.addEventListener('change', function(evt) { + if (new Set(['xlog', 'ylog']).has(evt.target.name)) { + cfg[evt.target.name] = evt.target.checked + } else { + cfg[evt.target.name] = evt.target.value + } + const query = Object.entries(cfg).map(([k,v]) => k + "=" + v).join('&') + history.pushState(null, '', '?' + query) + updateGraphData() + }) +} + + +// +// Graph rendering / updating +// + +function updateGraphData() { + let xMax = 0 + let yMax = 0 + let sMin = null + let sMax = null + const colorSet = new Set(Object.values(allData).map(d => d[cfg.ckey])) + const colorList = Array.from(colorSet.values()) + // empty the graphData without recreating it + while (graphData.length > 0) { graphData.pop() } + graphData.push(...colorList.map(t => ({key: t, values: []}))) + for (var dir of Object.keys(allData)) { + const impl = allData[dir] + if (impl[cfg.xkey] > xMax) { xMax = impl[cfg.xkey] } + if (impl[cfg.ykey] > yMax) { yMax = impl[cfg.ykey] } + if (sMin === null) { sMin = impl[cfg.skey] } + if (impl[cfg.skey] < sMin) { sMin = impl[cfg.skey] } + if (impl[cfg.skey] > sMax) { sMax = impl[cfg.skey] } + } + for (var dir of Object.keys(allData)) { + const impl = allData[dir] + // Invert size for inverted data + graphData[colorList.indexOf(impl[cfg.ckey])].values.push({ + x: impl[cfg.xkey] || 0, + y: impl[cfg.ykey] || 0, + size: malCircleSize(cfg.skey, sMin, sMax, impl[cfg.skey]), + shape: 'circle', + label: impl.name, + impl: impl, + }) + } + + // Update the axes domain, scale and tick values + chart.xDomain(malExtent(allData, cfg.xkey)) + chart.yDomain(malExtent(allData, cfg.ykey)) + chart.xScale(malScale(cfg.xlog)) + chart.yScale(malScale(cfg.ylog)) + chart.xAxis.tickValues(malTickValues(cfg.xkey, cfg.xlog)) + chart.yAxis.tickValues(malTickValues(cfg.ykey, cfg.ylog)) + + // Update the graph + d3.select('#mal svg') + .data([graphData]) + .transition().duration(350).ease('linear') + .call(chart) + + chart.update() + + nv.utils.windowResize(chart.update) +} + +nv.addGraph(function() { + chart = nv.models.scatterChart() + .showDistX(true) + .showDistY(true) + .showLabels(true) + .duration(300) + .color(malColors) + chart.dispatch.on('renderEnd', function() { + console.log('render complete') + }) + chart.dispatch.on('stateChange', function(e) { + nv.log('New State:', JSON.stringify(e)) + }) + chart.tooltip.contentGenerator(function(obj) { + const i = obj.point.impl + return '

' + i.name + '

' + + '

' + + 'Syntax Style: ' + i.syntax + '
' + + 'Type Discipline: ' + i.type_check + '
' + + 'Github Stars: ' + (i.star_count || 'unknown') + '
' + + 'GitHut Relative Rank: ' + i.rank + '
' + + '
' + + 'Perf 1: ' + i.perf1 + ' ms
' + + 'Perf 2: ' + i.perf2 + ' ms
' + + 'Perf 3: ' + i.perf3 + ' iters / 10 sec
' + + 'SLOC: ' + i.sloc + ' lines
' + + //'Author: ' + + //i.author_name + '
' + + 'Author: ' + i.author_name + '
' + + '

' + }) + d3.json("all_data.json", function (error, data) { + allData = data + updateGraphData() + }) + return chart +}) + diff --git a/docs/graph/index.html b/docs/graph/index.html new file mode 100644 index 0000000000..5a5af98a37 --- /dev/null +++ b/docs/graph/index.html @@ -0,0 +1,99 @@ + + + + + + + + + + + +
+

Mal Implementation Stats

+
+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + +
Color data: + Syntax Style + Type Discipline + Author +   
X-Axis data: + Perf 1 + Perf 2 + Perf 3 + Popularity + SLOC size + File count +  Logarithmic
Y-Axis data: + Perf 1 + Perf 2 + Perf 3 + Popularity + SLOC size + File count +  Logarithmic
Circle size: + Perf 1 + Perf 2 + Perf 3 + Popularity + SLOC size + File count +   
+
+ +
+ +
+ + + + + diff --git a/docs/graph/package.json b/docs/graph/package.json new file mode 100644 index 0000000000..eb72dbe413 --- /dev/null +++ b/docs/graph/package.json @@ -0,0 +1,10 @@ +{ + "name": "mal_graph", + "version": "0.0.1", + "description": "Graph Mal Languages", + "dependencies": { + "js-yaml": "3.12.2", + "request": "2.88.0", + "request-promise-native": "1.0.7" + } +} From e1bc7804ad77442a259a151f9dea58d574e78c3a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Wed, 20 Mar 2019 22:46:47 -0500 Subject: [PATCH 0501/1998] Popup caveats/notes. Dynamically generate controls. --- docs/graph/collect_data.js | 4 +- docs/graph/graph_languages.js | 94 +++++++++----- docs/graph/index.html | 236 ++++++++++++++++++++++------------ 3 files changed, 218 insertions(+), 116 deletions(-) diff --git a/docs/graph/collect_data.js b/docs/graph/collect_data.js index efca8a07f6..acc6f8632f 100755 --- a/docs/graph/collect_data.js +++ b/docs/graph/collect_data.js @@ -189,8 +189,8 @@ async function main() { // leave a gap between actual ranked implementations and those // with no rankings maxRank = curRank + 10 - maxPerf1 = dataList.reduce((a, d) => d.perf1 > a ? d.perf1 : a, 0) - maxPerf2 = dataList.reduce((a, d) => d.perf2 > a ? d.perf1 : a, 0) + maxPerf1 = dataList.reduce((a, d) => d.perf1 > a ? d.perf1 : a, 0) + maxPerf2 = dataList.reduce((a, d) => d.perf2 > a ? d.perf1 : a, 0) for (let d of dataList) { if (d.rank === null) { vlog(` setting rank to ${maxRank} for ${d.dir}`) diff --git a/docs/graph/graph_languages.js b/docs/graph/graph_languages.js index 3dd3ff67ca..3b806e76ba 100644 --- a/docs/graph/graph_languages.js +++ b/docs/graph/graph_languages.js @@ -1,11 +1,25 @@ const malColors = [ - "#1f77b4","#bf7f0e","#4cb00c","#b62728","#9467bd","#bc664b","#b377c2","#0fbf5f","#bcbd22","#17beef", - "#1f6784","#8f7f0e","#4c800c","#862728","#54678d","#8c564b","#8377c2","#0f8f5f","#8c8d22","#178eef", - "#1f97d4","#ff7f0e","#4cf00c","#f62728","#c467fd","#fc764b","#f377c2","#0fff5f","#fcfd22","#17feef", + "#1f77b4","#bf7f0e","#4cb00c","#b62728","#9467bd","#bc664b","#b377c2","#0fbf6f","#bcbd22","#17beef", + "#1f6784","#8f7f0e","#4c800c","#862728","#54678d","#8c564b","#8377c2","#0f8f6f","#8c8d22","#178eef", + "#1f97d4","#ff7f0e","#4cf00c","#f62728","#c467fd","#fc764b","#f377c2","#0fff6f","#fcfd22","#17feef", ] -const axisSet = new Set(['perf1', 'perf2', 'perf3', 'rank', 'sloc', 'files']) -const colorSet = new Set(['type_check', 'syntax', 'author_name']) +const axisMap = { + 'perf1': 'Perf 1', + 'perf2': 'Perf 2', + 'perf3': 'Perf 3', + 'rank': 'Popularity', + 'sloc': 'SLOC size', + 'files': 'File count', +} +const colorMap = { + 'syntax': 'Syntax Style', + 'type_check': 'Type Discipline', + 'author_name': 'Author', +} +const axisKeySet = new Set(Object.keys(axisMap)) +const colorKeySet = new Set(['type_check', 'syntax', 'author_name']) + const perfSet = new Set(['perf1', 'perf2', 'perf3']) const invertSet = new Set(['rank', 'perf1', 'perf2']) const perfLogSet = new Set(['perf1', 'perf2', 'sloc', 'files']) @@ -82,7 +96,7 @@ function malCircleSize(key, min, max, val) { let v = p2 ? decodeURIComponent(p2) : true if (v in {"true":1,"1":1,"yes":1}) { v = true } if (v in {"false":1,"0":1,"no":1}) { v = false } - if (k in cfg && (axisSet.has(v) || colorSet.has(v))) { + if (k in cfg && (axisKeySet.has(v) || colorKeySet.has(v))) { cfg[k] = v } if ((new Set(['xlog', 'ylog'])).has(k) && typeof v === 'boolean') { @@ -91,35 +105,42 @@ function malCircleSize(key, min, max, val) { } })(location.search) -// Set the checked elements based on the the cfg -for (const key of Object.keys(cfg)) { - for (const node of document.getElementsByName(key)) { - let val = node.value - if (val in {"true":1,"1":1,"yes":1}) { val = true } - if (val in {"false":1,"0":1,"no":1}) { val = false } - if (val === cfg[key]) { - node.checked = true - } else { - node.checked = false - } +// Generate the control buttons and set the checked elements based on +// the cfg +function ctlChange(evt) { + if (new Set(['xlog', 'ylog']).has(evt.target.name)) { + cfg[evt.target.name] = evt.target.checked + } else { + cfg[evt.target.name] = evt.target.value } + const query = Object.entries(cfg).map(([k,v]) => k + "=" + v).join('&') + history.pushState(null, '', '?' + query) + updateGraphData() } - -// Add onchange to all selector radio buttons/check boxes -for (let input of document.getElementsByClassName('selects')) { - input.addEventListener('change', function(evt) { - if (new Set(['xlog', 'ylog']).has(evt.target.name)) { - cfg[evt.target.name] = evt.target.checked - } else { - cfg[evt.target.name] = evt.target.value +for (let key of ['ckey', 'xkey', 'ykey', 'skey']) { + const parent = document.getElementById(key + '-controls') + const ctlMap = ({ + 'ckey': colorMap, + 'xkey': Object.assign({}, axisMap, {'xlog': 'Logarithmic'}), + 'ykey': Object.assign({}, axisMap, {'ylog': 'Logarithmic'}), + 'skey': axisMap, + })[key] + for (let [val, name] of Object.entries(ctlMap)) { + const log = (new Set(['xlog', 'ylog']).has(val)) ? val : false + const ctl = document.createElement('input') + ctl.class = 'selects' + ctl.type = log ? 'checkbox' : 'radio' + ctl.name = log ? log : key + ctl.value = log ? true : val + if ((log && cfg[val] === true) || cfg[key] === val) { + ctl.checked = true } - const query = Object.entries(cfg).map(([k,v]) => k + "=" + v).join('&') - history.pushState(null, '', '?' + query) - updateGraphData() - }) + ctl.addEventListener('change', ctlChange) + parent.appendChild(ctl) + parent.appendChild(document.createTextNode(name)) + } } - // // Graph rendering / updating // @@ -134,7 +155,7 @@ function updateGraphData() { // empty the graphData without recreating it while (graphData.length > 0) { graphData.pop() } graphData.push(...colorList.map(t => ({key: t, values: []}))) - for (var dir of Object.keys(allData)) { + for (let dir of Object.keys(allData)) { const impl = allData[dir] if (impl[cfg.xkey] > xMax) { xMax = impl[cfg.xkey] } if (impl[cfg.ykey] > yMax) { yMax = impl[cfg.ykey] } @@ -142,7 +163,7 @@ function updateGraphData() { if (impl[cfg.skey] < sMin) { sMin = impl[cfg.skey] } if (impl[cfg.skey] > sMax) { sMax = impl[cfg.skey] } } - for (var dir of Object.keys(allData)) { + for (let dir of Object.keys(allData)) { const impl = allData[dir] // Invert size for inverted data graphData[colorList.indexOf(impl[cfg.ckey])].values.push({ @@ -162,6 +183,8 @@ function updateGraphData() { chart.yScale(malScale(cfg.ylog)) chart.xAxis.tickValues(malTickValues(cfg.xkey, cfg.xlog)) chart.yAxis.tickValues(malTickValues(cfg.ykey, cfg.ylog)) + chart.xAxis.axisLabel(axisMap[cfg.xkey]) + chart.yAxis.axisLabel(axisMap[cfg.ykey]) // Update the graph d3.select('#mal svg') @@ -182,7 +205,7 @@ nv.addGraph(function() { .duration(300) .color(malColors) chart.dispatch.on('renderEnd', function() { - console.log('render complete') + //console.log('render complete') }) chart.dispatch.on('stateChange', function(e) { nv.log('New State:', JSON.stringify(e)) @@ -203,10 +226,15 @@ nv.addGraph(function() { //'Author: ' + //i.author_name + '
' + 'Author: ' + i.author_name + '
' + + '    ' + i.author_url.replace(/https?:\/\//, '') + '
' + '

' }) d3.json("all_data.json", function (error, data) { allData = data + // NOTE: TODO: major hack to workaround bug with switching + // to/from logarithmic mode. Seems to require at least one + // value to be less than 1 for it to work + allData.rpython.perf2 = 0.9 updateGraphData() }) return chart diff --git a/docs/graph/index.html b/docs/graph/index.html index 5a5af98a37..e1a1fe9e05 100644 --- a/docs/graph/index.html +++ b/docs/graph/index.html @@ -1,98 +1,172 @@ - - - - + + + + - +
-

Mal Implementation Stats

+

Mal Implementation Stats

-
- - - - - - - - - - - - - - - - - - - - - - - - - -
Color data: - Syntax Style - Type Discipline - Author -   
X-Axis data: - Perf 1 - Perf 2 - Perf 3 - Popularity - SLOC size - File count -  Logarithmic
Y-Axis data: - Perf 1 - Perf 2 - Perf 3 - Popularity - SLOC size - File count -  Logarithmic
Circle size: - Perf 1 - Perf 2 - Perf 3 - Popularity - SLOC size - File count -   
+
+ + + + + + + + + + + + + + + + + + +
+
+ + +
+

Important Caveats:

+

The data on this graph is very specific to Mal. + Do not use this data to directly compare programming + languages.

+
    +
  • Bad takeaway: "Language X is faster than + language Y"
    • +
  • Good takeway: "The mal impl in + language X is faster than the one + in language Y for the 'perf 3' microbenchmark"
    • +
+

Here are some reasons (non-exhaustive) why this data + should be taken with a grain of salt:

+
    +
  • The focus of the make-a-lisp process is on learning + (either Lisp or the target language). The resulting + implementations have a common structure that is + intended for understandability and consistency + between implementations. They are not structured or + intended to have optimal runtime performance or code + concision.
    • +
  • While the overall structure of each mal + implementation is similar, the implementation details + are up to the author.
    • +
  • Mal implementations are created by different + authors and the authors have varying levels of + experience with the target language and they often + created a mal implementation with the goal of learning + the target language.
    • +
  • There are hundreds of tests that each implementation + must pass before being accepted into the tree. + However, the mal language has no formal + specification so authors make choices + about whether and how to handle edge cases that are + not covered by the tests. For example, mal + implementations have different levels of runtime error + checking.
    • +
  • The performance benchmarks are very narrow in + focus and these numbers should not be extrapolated + casually. For example, the 'perf 3' microbenchmark + repeats a macro and data structure manipulation test + repeatedly for 10 seconds and counts the number of + iterations through the test. Languages with runtime + optimization (e.g. JIT) tend to do particularly well + at this benchmark (RPython, JVM-based, etc).
    • +
+

Other Notes:

+
    +
  • Syntax style and type discipline are best effort + and based on Wikipedia information and personal + experience. There are also other aspects to type + discipline (strong, gradual, duck, etc) that are not + currently included.
    • +
  • The language popularity measure is based on the + number of stars that the implementation language + received on GitHub for the most recent quarter. The + information was gathered by the GitHut + 2.0 project and then translated into a ordinal + ranking of implementations relative to each other. + Not all languages have data so a gap of 10 ticks + is introduced between the ranked languages and the + languages with no data.
    • +
+
+
+ 		Color data:
X-Axis data:
Y-Axis data:
Circle size:
- +
+ + From b0e8fd0703438451cf54b45d21f8383566b35898 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Thu, 21 Mar 2019 00:14:56 -0500 Subject: [PATCH 0502/1998] Move web files into docs/. Build docs/web/mal.js To update the docs/web/mal.js script run `make -C js web/mal.js` from the top-level (js/web is a symlink to docs/web). --- mal.html => docs/index.html | 22 +- {js => docs}/web/ansi.css | 0 {js => docs}/web/base.css | 0 {js => docs}/web/bg-body.png | Bin {js => docs}/web/bg-rule.png | Bin {js => docs}/web/console.css | 0 {js => docs}/web/fonts/exo-black-webfont.eot | Bin {js => docs}/web/fonts/exo-black-webfont.svg | 0 {js => docs}/web/fonts/exo-black-webfont.ttf | Bin {js => docs}/web/fonts/exo-black-webfont.woff | Bin {js => docs}/web/fonts/exo-bold-webfont.eot | Bin {js => docs}/web/fonts/exo-bold-webfont.svg | 0 {js => docs}/web/fonts/exo-bold-webfont.ttf | Bin {js => docs}/web/fonts/exo-bold-webfont.woff | Bin .../web/fonts/exo-regular-webfont.eot | Bin .../web/fonts/exo-regular-webfont.svg | 0 .../web/fonts/exo-regular-webfont.ttf | Bin .../web/fonts/exo-regular-webfont.woff | Bin {js => docs}/web/github-icon.png | Bin {js => docs}/web/himera.css | 0 {js => docs}/web/jqconsole.min.js | 0 {js => docs}/web/layout.css | 0 docs/web/mal.js | 976 ++++++++++++++++++ {js => docs}/web/skeleton.css | 0 js/web | 1 + 25 files changed, 988 insertions(+), 11 deletions(-) rename mal.html => docs/index.html (93%) rename {js => docs}/web/ansi.css (100%) rename {js => docs}/web/base.css (100%) rename {js => docs}/web/bg-body.png (100%) rename {js => docs}/web/bg-rule.png (100%) rename {js => docs}/web/console.css (100%) rename {js => docs}/web/fonts/exo-black-webfont.eot (100%) rename {js => docs}/web/fonts/exo-black-webfont.svg (100%) rename {js => docs}/web/fonts/exo-black-webfont.ttf (100%) rename {js => docs}/web/fonts/exo-black-webfont.woff (100%) rename {js => docs}/web/fonts/exo-bold-webfont.eot (100%) rename {js => docs}/web/fonts/exo-bold-webfont.svg (100%) rename {js => docs}/web/fonts/exo-bold-webfont.ttf (100%) rename {js => docs}/web/fonts/exo-bold-webfont.woff (100%) rename {js => docs}/web/fonts/exo-regular-webfont.eot (100%) rename {js => docs}/web/fonts/exo-regular-webfont.svg (100%) rename {js => docs}/web/fonts/exo-regular-webfont.ttf (100%) rename {js => docs}/web/fonts/exo-regular-webfont.woff (100%) rename {js => docs}/web/github-icon.png (100%) rename {js => docs}/web/himera.css (100%) rename {js => docs}/web/jqconsole.min.js (100%) rename {js => docs}/web/layout.css (100%) create mode 100644 docs/web/mal.js rename {js => docs}/web/skeleton.css (100%) create mode 120000 js/web diff --git a/mal.html b/docs/index.html similarity index 93% rename from mal.html rename to docs/index.html index 2601d07680..c3f9809962 100644 --- a/mal.html +++ b/docs/index.html @@ -1,6 +1,6 @@
@@ -214,14 +214,14 @@

JavaScript Interop

- - + +