diff --git a/.github/stable-prefix-files.txt b/.github/stable-prefix-files.txt new file mode 100644 index 0000000..7ff2ac4 --- /dev/null +++ b/.github/stable-prefix-files.txt @@ -0,0 +1,381 @@ +abscond/42.rkt +abscond/compiler/compile-stdin.rkt +abscond/compiler/compile.rkt +abscond/correct.rkt +abscond/executor/exec.rkt +abscond/executor/run-stdin.rkt +abscond/executor/run.rkt +abscond/interpreter/interp-stdin.rkt +abscond/interpreter/interp.rkt +abscond/main.rkt +abscond/syntax/ast.rkt +abscond/syntax/parse.rkt +abscond/test/define-tests.rkt +abscond/test/run-compile-tests.rkt +abscond/test/run-interp-tests.rkt +abscond/test/run-parse-tests.rkt +blackmail/add1-add1-40.rkt +blackmail/compiler/compile-ops.rkt +blackmail/compiler/compile-stdin.rkt +blackmail/compiler/compile.rkt +blackmail/correct.rkt +blackmail/executor/exec.rkt +blackmail/executor/run-stdin.rkt +blackmail/executor/run.rkt +blackmail/interpreter/interp-prim.rkt +blackmail/interpreter/interp-stdin.rkt +blackmail/interpreter/interp.rkt +blackmail/main.rkt +blackmail/syntax/ast.rkt +blackmail/syntax/parse.rkt +blackmail/syntax/random.rkt +blackmail/test/define-tests.rkt +blackmail/test/run-compile-tests.rkt +blackmail/test/run-interp-tests.rkt +blackmail/test/run-parse-tests.rkt +con/compiler/compile-ops.rkt +con/compiler/compile-stdin.rkt +con/compiler/compile.rkt +con/correct.rkt +con/example.rkt +con/executor/exec.rkt +con/executor/run-stdin.rkt +con/executor/run.rkt +con/interpreter/interp-prim.rkt +con/interpreter/interp-stdin.rkt +con/interpreter/interp.rkt +con/main.rkt +con/syntax/ast.rkt +con/syntax/parse.rkt +con/syntax/random.rkt +con/test/define-tests.rkt +con/test/run-compile-tests.rkt +con/test/run-interp-tests.rkt +con/test/run-parse-tests.rkt +dodger/compiler/compile-ops.rkt +dodger/compiler/compile-stdin.rkt +dodger/compiler/compile.rkt +dodger/correct.rkt +dodger/executor/decode.rkt +dodger/executor/exec.rkt +dodger/executor/run-stdin.rkt +dodger/executor/run.rkt +dodger/interpreter/interp-prim.rkt +dodger/interpreter/interp-stdin.rkt +dodger/interpreter/interp.rkt +dodger/main.rkt +dodger/runtime/types.rkt +dodger/syntax/ast.rkt +dodger/syntax/parse.rkt +dodger/syntax/random.rkt +dodger/test/define-tests.rkt +dodger/test/run-compile-tests.rkt +dodger/test/run-interp-tests.rkt +dodger/test/run-parse-tests.rkt +dupe/compiler/compile-ops.rkt +dupe/compiler/compile-stdin.rkt +dupe/compiler/compile.rkt +dupe/correct.rkt +dupe/example.rkt +dupe/executor/decode.rkt +dupe/executor/exec.rkt +dupe/executor/run-stdin.rkt +dupe/executor/run.rkt +dupe/interpreter/interp-prim.rkt +dupe/interpreter/interp-stdin.rkt +dupe/interpreter/interp.rkt +dupe/main.rkt +dupe/runtime/types.rkt +dupe/syntax/ast.rkt +dupe/syntax/parse.rkt +dupe/syntax/random.rkt +dupe/test/define-tests.rkt +dupe/test/run-compile-tests.rkt +dupe/test/run-interp-tests.rkt +dupe/test/run-parse-tests.rkt +evildoer/compiler/compile-ops.rkt +evildoer/compiler/compile-stdin.rkt +evildoer/compiler/compile.rkt +evildoer/correct.rkt +evildoer/executor/decode.rkt +evildoer/executor/exec.rkt +evildoer/executor/run-stdin.rkt +evildoer/executor/run.rkt +evildoer/interpreter/interp-io.rkt +evildoer/interpreter/interp-prim.rkt +evildoer/interpreter/interp-stdin.rkt +evildoer/interpreter/interp.rkt +evildoer/main.rkt +evildoer/runtime/types.rkt +evildoer/syntax/ast.rkt +evildoer/syntax/parse.rkt +evildoer/syntax/random.rkt +evildoer/test/define-tests.rkt +evildoer/test/run-compile-tests.rkt +evildoer/test/run-interp-tests.rkt +evildoer/test/run-parse-tests.rkt +extort/compiler/assert.rkt +extort/compiler/compile-ops.rkt +extort/compiler/compile-stdin.rkt +extort/compiler/compile.rkt +extort/correct.rkt +extort/executor/decode.rkt +extort/executor/exec.rkt +extort/executor/run-stdin.rkt +extort/executor/run.rkt +extort/interpreter/interp-io.rkt +extort/interpreter/interp-prim.rkt +extort/interpreter/interp-stdin.rkt +extort/interpreter/interp.rkt +extort/main.rkt +extort/runtime/types.rkt +extort/syntax/ast.rkt +extort/syntax/parse.rkt +extort/syntax/random.rkt +extort/test/define-tests.rkt +extort/test/run-compile-tests.rkt +extort/test/run-interp-tests.rkt +extort/test/run-parse-tests.rkt +fraud/compiler/assert.rkt +fraud/compiler/compile-ops.rkt +fraud/compiler/compile-stdin.rkt +fraud/compiler/compile.rkt +fraud/correct.rkt +fraud/executor/decode.rkt +fraud/executor/exec.rkt +fraud/executor/run-stdin.rkt +fraud/executor/run.rkt +fraud/interpreter/env.rkt +fraud/interpreter/interp-io.rkt +fraud/interpreter/interp-prim.rkt +fraud/interpreter/interp-stdin.rkt +fraud/interpreter/interp.rkt +fraud/main.rkt +fraud/runtime/types.rkt +fraud/syntax/ast.rkt +fraud/syntax/parse.rkt +fraud/syntax/random.rkt +fraud/syntax/translate.rkt +fraud/test/define-tests.rkt +fraud/test/run-compile-tests.rkt +fraud/test/run-interp-tests.rkt +fraud/test/run-parse-tests.rkt +fraud/test/translate.rkt +hoax/compiler/assert.rkt +hoax/compiler/compile-ops.rkt +hoax/compiler/compile-stdin.rkt +hoax/compiler/compile.rkt +hoax/correct.rkt +hoax/executor/decode.rkt +hoax/executor/exec.rkt +hoax/executor/run-stdin.rkt +hoax/executor/run.rkt +hoax/interpreter/env.rkt +hoax/interpreter/heap-bits.rkt +hoax/interpreter/heap.rkt +hoax/interpreter/interp-heap-bits.rkt +hoax/interpreter/interp-heap.rkt +hoax/interpreter/interp-io.rkt +hoax/interpreter/interp-prim.rkt +hoax/interpreter/interp-prims-heap-bits.rkt +hoax/interpreter/interp-prims-heap.rkt +hoax/interpreter/interp-stdin.rkt +hoax/interpreter/interp.rkt +hoax/interpreter/unload-bits.rkt +hoax/interpreter/unload.rkt +hoax/main.rkt +hoax/runtime/types.rkt +hoax/syntax/ast.rkt +hoax/syntax/parse.rkt +hoax/test/define-tests.rkt +hoax/test/run-compile-tests.rkt +hoax/test/run-interp-heap-bits-tests.rkt +hoax/test/run-interp-heap-tests.rkt +hoax/test/run-interp-tests.rkt +hoax/test/run-parse-tests.rkt +hustle/compiler/assert.rkt +hustle/compiler/compile-ops.rkt +hustle/compiler/compile-stdin.rkt +hustle/compiler/compile.rkt +hustle/correct.rkt +hustle/executor/decode.rkt +hustle/executor/exec.rkt +hustle/executor/run-stdin.rkt +hustle/executor/run.rkt +hustle/interpreter/env.rkt +hustle/interpreter/heap-bits.rkt +hustle/interpreter/heap.rkt +hustle/interpreter/interp-heap-bits.rkt +hustle/interpreter/interp-heap.rkt +hustle/interpreter/interp-io.rkt +hustle/interpreter/interp-prim.rkt +hustle/interpreter/interp-prims-heap-bits.rkt +hustle/interpreter/interp-prims-heap.rkt +hustle/interpreter/interp-stdin.rkt +hustle/interpreter/interp.rkt +hustle/interpreter/unload-bits.rkt +hustle/interpreter/unload.rkt +hustle/main.rkt +hustle/runtime/types.rkt +hustle/syntax/ast.rkt +hustle/syntax/parse.rkt +hustle/syntax/random.rkt +hustle/test/define-tests.rkt +hustle/test/run-compile-tests.rkt +hustle/test/run-interp-heap-bits-tests.rkt +hustle/test/run-interp-heap-tests.rkt +hustle/test/run-interp-tests.rkt +hustle/test/run-parse-tests.rkt +info.rkt +iniquity/compiler/assert.rkt +iniquity/compiler/compile-ops.rkt +iniquity/compiler/compile-stdin.rkt +iniquity/compiler/compile.rkt +iniquity/correct.rkt +iniquity/example/len.rkt +iniquity/executor/decode.rkt +iniquity/executor/exec.rkt +iniquity/executor/run-stdin.rkt +iniquity/executor/run.rkt +iniquity/gc-racket.rkt +iniquity/interpreter/env.rkt +iniquity/interpreter/interp-io.rkt +iniquity/interpreter/interp-prim.rkt +iniquity/interpreter/interp-stdin.rkt +iniquity/interpreter/interp.rkt +iniquity/main.rkt +iniquity/runtime/types.rkt +iniquity/syntax/ast.rkt +iniquity/syntax/parse.rkt +iniquity/syntax/read-all.rkt +iniquity/test/define-tests.rkt +iniquity/test/run-compile-tests.rkt +iniquity/test/run-interp-tests.rkt +iniquity/test/run-parse-tests.rkt +jig/compiler/assert.rkt +jig/compiler/compile-ops.rkt +jig/compiler/compile-stdin.rkt +jig/compiler/compile.rkt +jig/correct.rkt +jig/example.rkt +jig/executor/decode.rkt +jig/executor/exec.rkt +jig/executor/run-stdin.rkt +jig/executor/run.rkt +jig/interpreter/env.rkt +jig/interpreter/interp-io.rkt +jig/interpreter/interp-prim.rkt +jig/interpreter/interp-stdin.rkt +jig/interpreter/interp.rkt +jig/main.rkt +jig/runtime/types.rkt +jig/syntax/ast.rkt +jig/syntax/parse.rkt +jig/syntax/read-all.rkt +jig/test/define-tests.rkt +jig/test/run-compile-tests.rkt +jig/test/run-interp-tests.rkt +jig/test/run-parse-tests.rkt +knock/compiler/assert.rkt +knock/compiler/compile-ops.rkt +knock/compiler/compile-stdin.rkt +knock/compiler/compile.rkt +knock/correct.rkt +knock/executor/decode.rkt +knock/executor/exec.rkt +knock/executor/run-stdin.rkt +knock/executor/run.rkt +knock/interpreter/env.rkt +knock/interpreter/interp-io.rkt +knock/interpreter/interp-prim.rkt +knock/interpreter/interp-stdin.rkt +knock/interpreter/interp.rkt +knock/main.rkt +knock/runtime/types.rkt +knock/syntax/ast.rkt +knock/syntax/parse.rkt +knock/syntax/read-all.rkt +knock/test/define-tests.rkt +knock/test/run-compile-tests.rkt +knock/test/run-interp-tests.rkt +knock/test/run-parse-tests.rkt +loot/build-list-cons-rec.rkt +loot/compiler/assert.rkt +loot/compiler/compile-ops.rkt +loot/compiler/compile-stdin.rkt +loot/compiler/compile.rkt +loot/correct.rkt +loot/example.rkt +loot/executor/decode.rkt +loot/executor/exec.rkt +loot/executor/run-stdin.rkt +loot/executor/run.rkt +loot/interpreter/env.rkt +loot/interpreter/interp-defun.rkt +loot/interpreter/interp-io.rkt +loot/interpreter/interp-prim.rkt +loot/interpreter/interp-stdin.rkt +loot/interpreter/interp.rkt +loot/main.rkt +loot/regexp-defun.rkt +loot/regexp.rkt +loot/runtime/types.rkt +loot/syntax/ast.rkt +loot/syntax/fv.rkt +loot/syntax/lambdas.rkt +loot/syntax/parse.rkt +loot/syntax/read-all.rkt +loot/test/define-tests.rkt +loot/test/run-compile-tests.rkt +loot/test/run-interp-tests.rkt +loot/test/run-parse-tests.rkt +loot/tri.rkt +mountebank/compiler/assert.rkt +mountebank/compiler/compile-datum.rkt +mountebank/compiler/compile-literals.rkt +mountebank/compiler/compile-ops.rkt +mountebank/compiler/compile-stdin.rkt +mountebank/compiler/compile.rkt +mountebank/executor/decode.rkt +mountebank/executor/exec.rkt +mountebank/executor/run.rkt +mountebank/interpreter/env.rkt +mountebank/interpreter/interp-io.rkt +mountebank/interpreter/interp-prim.rkt +mountebank/interpreter/interp-stdin.rkt +mountebank/interpreter/interp.rkt +mountebank/main.rkt +mountebank/runtime/types.rkt +mountebank/syntax/ast.rkt +mountebank/syntax/fv.rkt +mountebank/syntax/lambdas.rkt +mountebank/syntax/literals.rkt +mountebank/syntax/parse.rkt +mountebank/syntax/read-all.rkt +mountebank/test/define-tests.rkt +mountebank/test/run-compile-tests.rkt +mountebank/test/run-interp-tests.rkt +mountebank/test/run-parse-tests.rkt +mug/compiler/assert.rkt +mug/compiler/compile-literals.rkt +mug/compiler/compile-ops.rkt +mug/compiler/compile-stdin.rkt +mug/compiler/compile.rkt +mug/executor/decode.rkt +mug/executor/exec.rkt +mug/executor/run-stdin.rkt +mug/executor/run.rkt +mug/interpreter/env.rkt +mug/interpreter/interp-io.rkt +mug/interpreter/interp-prim.rkt +mug/interpreter/interp-stdin.rkt +mug/interpreter/interp.rkt +mug/main.rkt +mug/runtime/types.rkt +mug/syntax/ast.rkt +mug/syntax/fv.rkt +mug/syntax/lambdas.rkt +mug/syntax/literals.rkt +mug/syntax/parse.rkt +mug/syntax/read-all.rkt +mug/test/define-tests.rkt diff --git a/.github/workflows/macos.yml b/.github/workflows/macos.yml index 558a602..85a3cfc 100644 --- a/.github/workflows/macos.yml +++ b/.github/workflows/macos.yml @@ -19,16 +19,21 @@ jobs: steps: - name: Checkout - uses: actions/checkout@v4 + uses: actions/checkout@main - name: Install Racket - uses: Bogdanp/setup-racket@v1.14 + uses: Bogdanp/setup-racket@v1.15 with: architecture: 'x64' distribution: 'full' variant: ${{ matrix.racket-variant }} version: ${{ matrix.racket-version }} + - name: Install LLVM + uses: ZhongRuoyu/setup-llvm@v0 + with: + llvm-version: 22 + - name: Version info run: | uname -a @@ -36,15 +41,11 @@ jobs: clang --version gcc --version - - name: Cache Racket packages - uses: actions/cache@v4 - with: - path: | - ~/.racket - ~/.cache/racket - ~/.local/share/racket - ~/Library/Caches/Racket - key: racket-${{ matrix.racket-variant }}-${{ matrix.racket-version }}-${{ matrix.os }} + # Temporary: install the next branch of a86 while this is in development + # Once merged in main, remove this and let it grab main branch by default + - name: Install a86 next branch + run: | + raco pkg install --auto 'https://github.com/cmsc430/a86.git?#next' - name: Install langs package run: | diff --git a/.github/workflows/ubuntu.yml b/.github/workflows/ubuntu.yml index eed0128..1deec54 100644 --- a/.github/workflows/ubuntu.yml +++ b/.github/workflows/ubuntu.yml @@ -3,12 +3,12 @@ on: [push, workflow_dispatch] concurrency: group: ubuntu-ci-${{ github.ref }} - cancel-in-progress: true + cancel-in-progress: false jobs: build-and-test: strategy: - fail-fast: true + fail-fast: false matrix: os: [ubuntu-22.04, ubuntu-24.04] racket-variant: ['CS'] @@ -22,36 +22,38 @@ jobs: uses: actions/checkout@main - name: Install Racket - uses: Bogdanp/setup-racket@v1.14 + uses: Bogdanp/setup-racket@v1.15 with: architecture: 'x64' distribution: 'full' variant: ${{ matrix.racket-variant }} version: ${{ matrix.racket-version }} - - name: Install clang + - name: Install LLVM + uses: ZhongRuoyu/setup-llvm@v0 + with: + llvm-version: 22 + + - name: Install libssl run: | - sudo apt install -y clang libssl-dev + sudo apt install -y libssl-dev - name: Version info run: | clang --version gcc --version - - name: Cache Racket packages - uses: actions/cache@v4 - with: - path: | - ~/.racket - ~/.cache/racket - ~/.local/share/racket - ~/Library/Caches/Racket - key: racket-${{ matrix.racket-variant }}-${{ matrix.racket-version }}-${{ matrix.os }} + - name: Install a86 branch + run: | + git clone --branch "${{ github.ref_name }}" --single-branch https://github.com/cmsc430/a86.git ../a86 + raco pkg install --auto --no-docs ../a86/ - name: Install langs package run: | - raco pkg install --auto ../langs/ + raco pkg install --auto --no-docs ../langs/ - name: Run tests + id: langs-tests + continue-on-error: true run: | xvfb-run raco test -p langs diff --git a/abscond/Makefile b/abscond/Makefile index 5205a2f..2d442f8 100644 --- a/abscond/Makefile +++ b/abscond/Makefile @@ -6,30 +6,33 @@ else LANGS_AS ?= clang -c endif -objs = \ - main.o \ - print.o +RACKET ?= racket -default: runtime.o +RUNTIME_DIR := runtime +RUNTIME := $(RUNTIME_DIR)/runtime.o -runtime.o: $(objs) - ld -r $(objs) -o runtime.o +# Example source extension for this language. +SRC_EXT := rkt -%.run: %.o runtime.o - $(LANGS_CC) runtime.o $< -o $@ +default: + @echo "example: make foo.run" -.c.o: - $(LANGS_CC) -fPIC -c -g -o $@ $< +# Build the runtime bundles if needed. +$(RUNTIME): + $(MAKE) -C $(RUNTIME_DIR) -.s.o: +# Compile source program to assembly. +%.s: %.$(SRC_EXT) + cat $< | $(RACKET) -t compiler/compile-stdin.rkt -m > $@ + +# Assemble to object. +%.o: %.s $(LANGS_AS) -o $@ $< -%.s: %.rkt - cat $< | racket -t compile-stdin.rkt -m > $@ +# Link standalone executable. +%.run: %.o $(RUNTIME) + $(LANGS_CC) -o $@ $^ clean: @$(RM) *.o *.s *.run ||: - @echo "$(shell basename $(shell pwd)): cleaned!" - -%.test: %.run %.rkt - @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" + @$(MAKE) -C $(RUNTIME_DIR) clean diff --git a/abscond/compile.rkt b/abscond/compile.rkt deleted file mode 100644 index a216676..0000000 --- a/abscond/compile.rkt +++ /dev/null @@ -1,19 +0,0 @@ -#lang racket -(provide compile - compile-e) - -(require "ast.rkt") -(require a86/ast a86/registers) - -;; Expr -> Asm -(define (compile e) - (prog (Global 'entry) - (Label 'entry) - (compile-e e) - (Ret))) - -;; Expr -> Asm -(define (compile-e e) - (match e - [(Lit i) (seq (Mov rax i))])) - diff --git a/abscond/compile-stdin.rkt b/abscond/compiler/compile-stdin.rkt similarity index 88% rename from abscond/compile-stdin.rkt rename to abscond/compiler/compile-stdin.rkt index 532ee0e..a11acf3 100644 --- a/abscond/compile-stdin.rkt +++ b/abscond/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/abscond/compiler/compile.rkt b/abscond/compiler/compile.rkt new file mode 100644 index 0000000..ee7eddd --- /dev/null +++ b/abscond/compiler/compile.rkt @@ -0,0 +1,14 @@ +#lang racket +(provide compile) + +(require "../syntax/ast.rkt") +(require a86/ast a86/registers) + +;; Expr -> Asm +(define (compile e) + (prog (Global 'entry) + (Label 'entry) + (match e + [(Lit i) (Mov rax i)]) + (Ret))) + diff --git a/abscond/correct.rkt b/abscond/correct.rkt index bbbacf9..69f6400 100644 --- a/abscond/correct.rkt +++ b/abscond/correct.rkt @@ -1,11 +1,12 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp.rkt") -(require "exec.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(require a86/interp) ;; Expr -> Void (define (check-compiler e) (check-equal? (interp e) - (exec e))) + (asm-interp (compile e)))) diff --git a/abscond/exec.rkt b/abscond/exec.rkt deleted file mode 100644 index 408672f..0000000 --- a/abscond/exec.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(provide exec) - -;; Expr -> Integer -(define (exec e) - (run (compile e))) - diff --git a/abscond/executor/exec-stdin.rkt b/abscond/executor/exec-stdin.rkt new file mode 100644 index 0000000..8f50771 --- /dev/null +++ b/abscond/executor/exec-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require a86/interp) + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (asm-interp (compile (parse (read))))) + diff --git a/blackmail/interp-stdin.rkt b/abscond/interpreter/interp-stdin.rkt similarity index 87% rename from blackmail/interp-stdin.rkt rename to abscond/interpreter/interp-stdin.rkt index ce4885f..e620f5c 100644 --- a/blackmail/interp-stdin.rkt +++ b/abscond/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/abscond/interp.rkt b/abscond/interpreter/interp.rkt similarity index 76% rename from abscond/interp.rkt rename to abscond/interpreter/interp.rkt index 0cfe6c4..b3441d6 100644 --- a/abscond/interp.rkt +++ b/abscond/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp) -(require "ast.rkt") +(require "../syntax/ast.rkt") ;; Expr -> Integer (define (interp e) diff --git a/abscond/main.rkt b/abscond/main.rkt index 9a97f8b..a334722 100644 --- a/abscond/main.rkt +++ b/abscond/main.rkt @@ -1,14 +1,10 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "compile.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "compiler/compile.rkt")) diff --git a/abscond/print.c b/abscond/print.c deleted file mode 100644 index cf19daf..0000000 --- a/abscond/print.c +++ /dev/null @@ -1,7 +0,0 @@ -#include -#include - -void print_result(int64_t x) -{ - printf("%" PRId64, x); -} diff --git a/abscond/print.h b/abscond/print.h deleted file mode 100644 index 08ae346..0000000 --- a/abscond/print.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef PRINT_H -#define PRINT_H - -void print_result(int64_t); - -#endif diff --git a/abscond/run.rkt b/abscond/run.rkt deleted file mode 100644 index 33c496c..0000000 --- a/abscond/run.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(provide run) - -;; Run instructions with run-time system linked in -;; Asm -> Integer -(define (run is) - (asm-interp is)) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - - diff --git a/abscond/runtime/Makefile b/abscond/runtime/Makefile new file mode 100644 index 0000000..34d7577 --- /dev/null +++ b/abscond/runtime/Makefile @@ -0,0 +1,23 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -g + +OBJS = main.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/abscond/main.c b/abscond/runtime/main.c similarity index 60% rename from abscond/main.c rename to abscond/runtime/main.c index 2e030ba..163618e 100644 --- a/abscond/main.c +++ b/abscond/runtime/main.c @@ -1,15 +1,12 @@ #include #include -#include "print.h" int64_t entry(); int main(int argc, char** argv) { - int64_t result; - - result = entry(); - print_result(result); + int64_t result = entry(); + printf("%" PRId64, result); putchar('\n'); return 0; } diff --git a/abscond/ast.rkt b/abscond/syntax/ast.rkt similarity index 100% rename from abscond/ast.rkt rename to abscond/syntax/ast.rkt diff --git a/abscond/parse.rkt b/abscond/syntax/parse.rkt similarity index 100% rename from abscond/parse.rkt rename to abscond/syntax/parse.rkt diff --git a/abscond/test/compile.rkt b/abscond/test/compile.rkt deleted file mode 100644 index cf7ce11..0000000 --- a/abscond/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - diff --git a/abscond/test/test-runner.rkt b/abscond/test/define-tests.rkt similarity index 100% rename from abscond/test/test-runner.rkt rename to abscond/test/define-tests.rkt diff --git a/abscond/test/interp.rkt b/abscond/test/interp.rkt deleted file mode 100644 index dc33c12..0000000 --- a/abscond/test/interp.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - diff --git a/abscond/test/run-compile-tests.rkt b/abscond/test/run-compile-tests.rkt new file mode 100644 index 0000000..9fc6cc6 --- /dev/null +++ b/abscond/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(require a86/interp) + +(test (λ (e) (asm-interp (compile (parse e))))) + diff --git a/abscond/test/run-interp-tests.rkt b/abscond/test/run-interp-tests.rkt new file mode 100644 index 0000000..7a4ebb9 --- /dev/null +++ b/abscond/test/run-interp-tests.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/abscond/test/parse.rkt b/abscond/test/run-parse-tests.rkt similarity index 81% rename from abscond/test/parse.rkt rename to abscond/test/run-parse-tests.rkt index 2fabd5f..cd5974f 100644 --- a/abscond/test/parse.rkt +++ b/abscond/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/blackmail/compile-ops.rkt b/blackmail/compiler/compile-ops.rkt similarity index 84% rename from blackmail/compile-ops.rkt rename to blackmail/compiler/compile-ops.rkt index dc1119b..a6e9b97 100644 --- a/blackmail/compile-ops.rkt +++ b/blackmail/compiler/compile-ops.rkt @@ -1,6 +1,6 @@ #lang racket (provide compile-op1) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require a86/ast a86/registers) ;; Op1 -> Asm diff --git a/con/compile-stdin.rkt b/blackmail/compiler/compile-stdin.rkt similarity index 88% rename from con/compile-stdin.rkt rename to blackmail/compiler/compile-stdin.rkt index 532ee0e..a11acf3 100644 --- a/con/compile-stdin.rkt +++ b/blackmail/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/blackmail/compile.rkt b/blackmail/compiler/compile.rkt similarity index 93% rename from blackmail/compile.rkt rename to blackmail/compiler/compile.rkt index 3b22b6f..274b223 100644 --- a/blackmail/compile.rkt +++ b/blackmail/compiler/compile.rkt @@ -2,7 +2,7 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") (require a86/ast a86/registers) diff --git a/blackmail/correct.rkt b/blackmail/correct.rkt index bbbacf9..69f6400 100644 --- a/blackmail/correct.rkt +++ b/blackmail/correct.rkt @@ -1,11 +1,12 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp.rkt") -(require "exec.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(require a86/interp) ;; Expr -> Void (define (check-compiler e) (check-equal? (interp e) - (exec e))) + (asm-interp (compile e)))) diff --git a/blackmail/exec.rkt b/blackmail/exec.rkt deleted file mode 100644 index 408672f..0000000 --- a/blackmail/exec.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(provide exec) - -;; Expr -> Integer -(define (exec e) - (run (compile e))) - diff --git a/blackmail/executor/exec-stdin.rkt b/blackmail/executor/exec-stdin.rkt new file mode 100644 index 0000000..8f50771 --- /dev/null +++ b/blackmail/executor/exec-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require a86/interp) + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (asm-interp (compile (parse (read))))) + diff --git a/blackmail/interp-prim.rkt b/blackmail/interpreter/interp-prim.rkt similarity index 100% rename from blackmail/interp-prim.rkt rename to blackmail/interpreter/interp-prim.rkt diff --git a/con/interp-stdin.rkt b/blackmail/interpreter/interp-stdin.rkt similarity index 87% rename from con/interp-stdin.rkt rename to blackmail/interpreter/interp-stdin.rkt index ce4885f..e620f5c 100644 --- a/con/interp-stdin.rkt +++ b/blackmail/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/blackmail/interp.rkt b/blackmail/interpreter/interp.rkt similarity index 85% rename from blackmail/interp.rkt rename to blackmail/interpreter/interp.rkt index 044f5b0..04cec38 100644 --- a/blackmail/interp.rkt +++ b/blackmail/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; Expr -> Integer diff --git a/blackmail/main.rkt b/blackmail/main.rkt index 9a97f8b..a334722 100644 --- a/blackmail/main.rkt +++ b/blackmail/main.rkt @@ -1,14 +1,10 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "compile.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "compiler/compile.rkt")) diff --git a/blackmail/print.c b/blackmail/print.c deleted file mode 100644 index cf19daf..0000000 --- a/blackmail/print.c +++ /dev/null @@ -1,7 +0,0 @@ -#include -#include - -void print_result(int64_t x) -{ - printf("%" PRId64, x); -} diff --git a/blackmail/print.h b/blackmail/print.h deleted file mode 100644 index 08ae346..0000000 --- a/blackmail/print.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef PRINT_H -#define PRINT_H - -void print_result(int64_t); - -#endif diff --git a/blackmail/run.rkt b/blackmail/run.rkt deleted file mode 100644 index 33c496c..0000000 --- a/blackmail/run.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(provide run) - -;; Run instructions with run-time system linked in -;; Asm -> Integer -(define (run is) - (asm-interp is)) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - - diff --git a/blackmail/runtime/Makefile b/blackmail/runtime/Makefile new file mode 100644 index 0000000..34d7577 --- /dev/null +++ b/blackmail/runtime/Makefile @@ -0,0 +1,23 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -g + +OBJS = main.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/blackmail/main.c b/blackmail/runtime/main.c similarity index 60% rename from blackmail/main.c rename to blackmail/runtime/main.c index 2e030ba..163618e 100644 --- a/blackmail/main.c +++ b/blackmail/runtime/main.c @@ -1,15 +1,12 @@ #include #include -#include "print.h" int64_t entry(); int main(int argc, char** argv) { - int64_t result; - - result = entry(); - print_result(result); + int64_t result = entry(); + printf("%" PRId64, result); putchar('\n'); return 0; } diff --git a/blackmail/semantics.rkt b/blackmail/semantics.rkt deleted file mode 100644 index 7864b96..0000000 --- a/blackmail/semantics.rkt +++ /dev/null @@ -1,30 +0,0 @@ -#lang racket -(provide B-concrete B 𝑩) -(require redex/reduction-semantics) - -(define-language B-concrete - (e ::= integer (add1 e) (sub1 e))) - -(define-language B - (e ::= (Int i) (Prim1 p1 e)) - (i ::= integer) - (p1 ::= 'add1 'sub1)) - -(define-judgment-form B - #:mode (𝑩 I O) - #:contract (𝑩 e i) - [---------- - (𝑩 (Int i) i)] - - [(𝑩 e_0 i_0) (where i_1 ,(+ (term i_0) 1)) - ----------- - (𝑩 (Prim1 'add1 e_0) i_1)] - - [(𝑩 e_0 i_0) (where i_1 ,(- (term i_0) 1)) - ----------- - (𝑩 (Prim1 'sub1 e_0) i_1)]) - -(module+ test - (test-judgment-holds (𝑩 (Int 7) 7)) - (test-judgment-holds (𝑩 (Prim1 'add1 (Int 8)) 9)) - (test-judgment-holds (𝑩 (Prim1 'sub1 (Int 8)) 7))) diff --git a/blackmail/ast.rkt b/blackmail/syntax/ast.rkt similarity index 100% rename from blackmail/ast.rkt rename to blackmail/syntax/ast.rkt diff --git a/blackmail/parse.rkt b/blackmail/syntax/parse.rkt similarity index 100% rename from blackmail/parse.rkt rename to blackmail/syntax/parse.rkt diff --git a/blackmail/random.rkt b/blackmail/syntax/random.rkt similarity index 100% rename from blackmail/random.rkt rename to blackmail/syntax/random.rkt diff --git a/blackmail/test/compile.rkt b/blackmail/test/compile.rkt deleted file mode 100644 index cf7ce11..0000000 --- a/blackmail/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - diff --git a/blackmail/test/test-runner.rkt b/blackmail/test/define-tests.rkt similarity index 100% rename from blackmail/test/test-runner.rkt rename to blackmail/test/define-tests.rkt diff --git a/blackmail/test/interp.rkt b/blackmail/test/interp.rkt deleted file mode 100644 index dc33c12..0000000 --- a/blackmail/test/interp.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - diff --git a/blackmail/test/run-compile-tests.rkt b/blackmail/test/run-compile-tests.rkt new file mode 100644 index 0000000..9fc6cc6 --- /dev/null +++ b/blackmail/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(require a86/interp) + +(test (λ (e) (asm-interp (compile (parse e))))) + diff --git a/blackmail/test/run-interp-tests.rkt b/blackmail/test/run-interp-tests.rkt new file mode 100644 index 0000000..7a4ebb9 --- /dev/null +++ b/blackmail/test/run-interp-tests.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/blackmail/test/parse.rkt b/blackmail/test/run-parse-tests.rkt similarity index 79% rename from blackmail/test/parse.rkt rename to blackmail/test/run-parse-tests.rkt index 59ac5ec..c67a08d 100644 --- a/blackmail/test/parse.rkt +++ b/blackmail/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/con/compile-ops.rkt b/con/compiler/compile-ops.rkt similarity index 84% rename from con/compile-ops.rkt rename to con/compiler/compile-ops.rkt index dc1119b..a6e9b97 100644 --- a/con/compile-ops.rkt +++ b/con/compiler/compile-ops.rkt @@ -1,6 +1,6 @@ #lang racket (provide compile-op1) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require a86/ast a86/registers) ;; Op1 -> Asm diff --git a/blackmail/compile-stdin.rkt b/con/compiler/compile-stdin.rkt similarity index 88% rename from blackmail/compile-stdin.rkt rename to con/compiler/compile-stdin.rkt index 532ee0e..a11acf3 100644 --- a/blackmail/compile-stdin.rkt +++ b/con/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/con/compile.rkt b/con/compiler/compile.rkt similarity index 96% rename from con/compile.rkt rename to con/compiler/compile.rkt index 4ec5fbc..725bff8 100644 --- a/con/compile.rkt +++ b/con/compiler/compile.rkt @@ -2,7 +2,7 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") (require a86/ast a86/registers) diff --git a/con/correct.rkt b/con/correct.rkt index bbbacf9..69f6400 100644 --- a/con/correct.rkt +++ b/con/correct.rkt @@ -1,11 +1,12 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp.rkt") -(require "exec.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(require a86/interp) ;; Expr -> Void (define (check-compiler e) (check-equal? (interp e) - (exec e))) + (asm-interp (compile e)))) diff --git a/con/exec.rkt b/con/exec.rkt deleted file mode 100644 index 408672f..0000000 --- a/con/exec.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(provide exec) - -;; Expr -> Integer -(define (exec e) - (run (compile e))) - diff --git a/con/executor/exec-stdin.rkt b/con/executor/exec-stdin.rkt new file mode 100644 index 0000000..8f50771 --- /dev/null +++ b/con/executor/exec-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require a86/interp) + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + (asm-interp (compile (parse (read))))) + diff --git a/con/interp-prim.rkt b/con/interpreter/interp-prim.rkt similarity index 100% rename from con/interp-prim.rkt rename to con/interpreter/interp-prim.rkt diff --git a/dodger/interp-stdin.rkt b/con/interpreter/interp-stdin.rkt similarity index 87% rename from dodger/interp-stdin.rkt rename to con/interpreter/interp-stdin.rkt index ce4885f..e620f5c 100644 --- a/dodger/interp-stdin.rkt +++ b/con/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/con/interp.rkt b/con/interpreter/interp.rkt similarity index 90% rename from con/interp.rkt rename to con/interpreter/interp.rkt index f87824e..b0a83ae 100644 --- a/con/interp.rkt +++ b/con/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; Expr -> Integer diff --git a/con/main.rkt b/con/main.rkt index 9a97f8b..a334722 100644 --- a/con/main.rkt +++ b/con/main.rkt @@ -1,14 +1,10 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "compile.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "compiler/compile.rkt")) diff --git a/con/print.c b/con/print.c deleted file mode 100644 index cf19daf..0000000 --- a/con/print.c +++ /dev/null @@ -1,7 +0,0 @@ -#include -#include - -void print_result(int64_t x) -{ - printf("%" PRId64, x); -} diff --git a/con/print.h b/con/print.h deleted file mode 100644 index 08ae346..0000000 --- a/con/print.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef PRINT_H -#define PRINT_H - -void print_result(int64_t); - -#endif diff --git a/con/run.rkt b/con/run.rkt deleted file mode 100644 index 33c496c..0000000 --- a/con/run.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(provide run) - -;; Run instructions with run-time system linked in -;; Asm -> Integer -(define (run is) - (asm-interp is)) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - - diff --git a/con/runtime/Makefile b/con/runtime/Makefile new file mode 100644 index 0000000..34d7577 --- /dev/null +++ b/con/runtime/Makefile @@ -0,0 +1,23 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -g + +OBJS = main.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/con/main.c b/con/runtime/main.c similarity index 60% rename from con/main.c rename to con/runtime/main.c index 2e030ba..163618e 100644 --- a/con/main.c +++ b/con/runtime/main.c @@ -1,15 +1,12 @@ #include #include -#include "print.h" int64_t entry(); int main(int argc, char** argv) { - int64_t result; - - result = entry(); - print_result(result); + int64_t result = entry(); + printf("%" PRId64, result); putchar('\n'); return 0; } diff --git a/con/semantics.rkt b/con/semantics.rkt deleted file mode 100644 index 8b3762f..0000000 --- a/con/semantics.rkt +++ /dev/null @@ -1,37 +0,0 @@ -#lang racket -(provide C-concrete C 𝑪) -(require redex/reduction-semantics - (only-in "../blackmail/semantics.rkt" B B-concrete 𝑩)) - -(define-extended-language C-concrete B-concrete - (e ::= .... (if (zero? e) e e))) - -(define-extended-language C B - (e ::= .... (IfZero e e e))) - -(define-extended-judgment-form C 𝑩 - #:mode (𝑪 I O) - #:contract (𝑪 e i) - [(𝑪 e_0 i_0) (side-condition ,(= (term i_0) 0)) (𝑪 e_1 i_1) - -------- - (𝑪 (IfZero e_0 e_1 e_2) i_1)] - - [(𝑪 e_0 i_0) (side-condition ,(!= (term i_0) 0)) (𝑪 e_2 i_2) - -------- - (𝑪 (IfZero e_0 e_1 e_2) i_2)]) - -(define (!= n1 n2) - (not (= n1 n2))) - -(module+ test - (test-judgment-holds (𝑪 (Int 7) 7)) - (test-judgment-holds (𝑪 (Prim1 'add1 (Int 8)) 9)) - (test-judgment-holds (𝑪 (Prim1 'sub1 (Int 8)) 7)) - (test-judgment-holds (𝑪 (IfZero (Prim1 'sub1 (Int 1)) - (Int 3) - (Int 4)) - 3)) - (test-judgment-holds (𝑪 (IfZero (Prim1 'add1 (Int 1)) - (Int 3) - (Int 4)) - 4))) diff --git a/con/ast.rkt b/con/syntax/ast.rkt similarity index 100% rename from con/ast.rkt rename to con/syntax/ast.rkt diff --git a/con/parse.rkt b/con/syntax/parse.rkt similarity index 100% rename from con/parse.rkt rename to con/syntax/parse.rkt diff --git a/con/random.rkt b/con/syntax/random.rkt similarity index 100% rename from con/random.rkt rename to con/syntax/random.rkt diff --git a/con/test/compile.rkt b/con/test/compile.rkt deleted file mode 100644 index cf7ce11..0000000 --- a/con/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - diff --git a/con/test/test-runner.rkt b/con/test/define-tests.rkt similarity index 100% rename from con/test/test-runner.rkt rename to con/test/define-tests.rkt diff --git a/con/test/interp.rkt b/con/test/interp.rkt deleted file mode 100644 index dc33c12..0000000 --- a/con/test/interp.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - diff --git a/con/test/run-compile-tests.rkt b/con/test/run-compile-tests.rkt new file mode 100644 index 0000000..9fc6cc6 --- /dev/null +++ b/con/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(require a86/interp) + +(test (λ (e) (asm-interp (compile (parse e))))) + diff --git a/con/test/run-interp-tests.rkt b/con/test/run-interp-tests.rkt new file mode 100644 index 0000000..7a4ebb9 --- /dev/null +++ b/con/test/run-interp-tests.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/con/test/parse.rkt b/con/test/run-parse-tests.rkt similarity index 84% rename from con/test/parse.rkt rename to con/test/run-parse-tests.rkt index b25786d..f3984a5 100644 --- a/con/test/parse.rkt +++ b/con/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/con/types.rkt b/con/types.rkt deleted file mode 100644 index cb09c66..0000000 --- a/con/types.rkt +++ /dev/null @@ -1,17 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Value = -;; | Integer - -;; type Bits = Integer - -(define int-shift 0) - -;; Bits -> Value -(define (bits->value b) b) - -;; Value -> Bits -(define (value->bits v) - (match v - [(? integer?) (arithmetic-shift v int-shift)])) diff --git a/dodger/Makefile b/dodger/Makefile index 398e3cf..5205a2f 100644 --- a/dodger/Makefile +++ b/dodger/Makefile @@ -8,8 +8,7 @@ endif objs = \ main.o \ - print.o \ - values.o + print.o default: runtime.o diff --git a/dodger/compile-ops.rkt b/dodger/compiler/compile-ops.rkt similarity index 92% rename from dodger/compile-ops.rkt rename to dodger/compiler/compile-ops.rkt index 5f3eb1e..8c23c01 100644 --- a/dodger/compile-ops.rkt +++ b/dodger/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op1) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Op1 -> Asm diff --git a/dodger/compile-stdin.rkt b/dodger/compiler/compile-stdin.rkt similarity index 88% rename from dodger/compile-stdin.rkt rename to dodger/compiler/compile-stdin.rkt index 532ee0e..a11acf3 100644 --- a/dodger/compile-stdin.rkt +++ b/dodger/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/dupe/compile.rkt b/dodger/compiler/compile.rkt similarity index 93% rename from dupe/compile.rkt rename to dodger/compiler/compile.rkt index 593445a..2095e20 100644 --- a/dupe/compile.rkt +++ b/dodger/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Expr -> Asm diff --git a/dodger/correct.rkt b/dodger/correct.rkt index ae6e1ae..2129ca0 100644 --- a/dodger/correct.rkt +++ b/dodger/correct.rkt @@ -1,13 +1,14 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp.rkt") -(require "exec.rkt") +(require "interpreter/interp.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; Expr -> Void (define (check-compiler e) (let ((r (with-handlers ([exn:fail? identity]) (interp e)))) (unless (exn? r) - (check-equal? r (exec e))))) + (check-equal? r (run (compile e)))))) diff --git a/dodger/exec.rkt b/dodger/exec.rkt deleted file mode 100644 index 114a56e..0000000 --- a/dodger/exec.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(provide exec) -;; Expr -> Value -(define (exec e) - (run (compile e))) - diff --git a/dodger/executor/decode.rkt b/dodger/executor/decode.rkt new file mode 100644 index 0000000..efaeb49 --- /dev/null +++ b/dodger/executor/decode.rkt @@ -0,0 +1,20 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [else (error "invalid bits")])) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/dodger/executor/exec.rkt b/dodger/executor/exec.rkt new file mode 100644 index 0000000..8b8c3be --- /dev/null +++ b/dodger/executor/exec.rkt @@ -0,0 +1,44 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") + +(struct exec-state (program) #:transparent) + +(define (exec/state prog) + (exec-state + (asm-load prog))) + +(define (exec-call st) + (match-define (exec-state program) st) + (asm-call program 'entry)) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/blackmail/run-stdin.rkt b/dodger/executor/run-stdin.rkt similarity index 74% rename from blackmail/run-stdin.rkt rename to dodger/executor/run-stdin.rkt index 16cf99e..ac60d60 100644 --- a/blackmail/run-stdin.rkt +++ b/dodger/executor/run-stdin.rkt @@ -1,12 +1,13 @@ #lang racket (provide main) -(require "parse.rkt") -(require "compile.rkt") +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") (require "run.rkt") ;; -> Void ;; Compile contents of stdin and use asm-interp to run (define (main) (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) diff --git a/dodger/executor/run.rkt b/dodger/executor/run.rkt new file mode 100644 index 0000000..5b4c9cd --- /dev/null +++ b/dodger/executor/run.rkt @@ -0,0 +1,11 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run) +(define (run asm) + (call-with-exec + asm + (λ (r) + (bits->value r)))) + diff --git a/dodger/interp-bits.rkt b/dodger/interp-bits.rkt deleted file mode 100644 index 6f65d55..0000000 --- a/dodger/interp-bits.rkt +++ /dev/null @@ -1,41 +0,0 @@ -#lang racket -(provide interp interp-bits) -(require "ast.rkt" "types.rkt") - -;; type Value = -;; | Integer -;; | Boolean -;; | Character - -;; type Bits = Integer - -;; Expr -> Value -(define (interp e) - (bits->value (interp-bits e))) - -;; Expr -> Bits -(define (interp-bits e) - (match e - [(Lit d) (value->bits d)] - [(Prim1 'add1 e0) - (+ (interp-bits e0) (value->bits 1))] - [(Prim1 'sub1 e0) - (- (interp-bits e0) (value->bits 1))] - [(Prim1 'zero? e) - (value->bits (zero? (interp-bits e)))] - [(Prim1 'char? e0) - (value->bits (char-bits? (interp-bits e0)))] - [(Prim1 'char->integer e0) - (arithmetic-shift - (arithmetic-shift (interp-bits e0) (- char-shift)) - int-shift)] - [(Prim1 'integer->char e0) - (bitwise-ior - (arithmetic-shift - (arithmetic-shift (interp-bits e0) (- int-shift)) - char-shift) - type-char)] - [(If e1 e2 e3) - (if (= (interp-bits e1) (value->bits #f)) - (interp-bits e3) - (interp-bits e2))])) diff --git a/dodger/interp-prim.rkt b/dodger/interpreter/interp-prim.rkt similarity index 100% rename from dodger/interp-prim.rkt rename to dodger/interpreter/interp-prim.rkt diff --git a/abscond/interp-stdin.rkt b/dodger/interpreter/interp-stdin.rkt similarity index 87% rename from abscond/interp-stdin.rkt rename to dodger/interpreter/interp-stdin.rkt index ce4885f..e620f5c 100644 --- a/abscond/interp-stdin.rkt +++ b/dodger/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/dodger/interp.rkt b/dodger/interpreter/interp.rkt similarity index 91% rename from dodger/interp.rkt rename to dodger/interpreter/interp.rkt index e8a0bff..9838b09 100644 --- a/dodger/interp.rkt +++ b/dodger/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; type Value = diff --git a/dodger/main.rkt b/dodger/main.rkt index 67ea8be..d6a5d90 100644 --- a/dodger/main.rkt +++ b/dodger/main.rkt @@ -1,16 +1,16 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/dodger/run.rkt b/dodger/run.rkt deleted file mode 100644 index 982b94d..0000000 --- a/dodger/run.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(provide run) - -;; Run instructions with run-time system linked in - -;; Asm -> Value -(define (run is) - (bits->value (asm-interp is))) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - - diff --git a/dodger/runtime/Makefile b/dodger/runtime/Makefile new file mode 100644 index 0000000..cf0e413 --- /dev/null +++ b/dodger/runtime/Makefile @@ -0,0 +1,26 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/dupe/main.c b/dodger/runtime/main.c similarity index 81% rename from dupe/main.c rename to dodger/runtime/main.c index c6f67be..27e672f 100644 --- a/dupe/main.c +++ b/dodger/runtime/main.c @@ -6,9 +6,7 @@ val_t entry(); int main(int argc, char** argv) { - val_t result; - - result = entry(); + val_t result = entry(); print_result(result); putchar('\n'); return 0; diff --git a/dodger/print.c b/dodger/runtime/print.c similarity index 100% rename from dodger/print.c rename to dodger/runtime/print.c diff --git a/dodger/print.h b/dodger/runtime/print.h similarity index 100% rename from dodger/print.h rename to dodger/runtime/print.h diff --git a/dodger/types.h b/dodger/runtime/types.h similarity index 100% rename from dodger/types.h rename to dodger/runtime/types.h diff --git a/dodger/types.rkt b/dodger/runtime/types.rkt similarity index 65% rename from dodger/types.rkt rename to dodger/runtime/types.rkt index 0bd20c6..c372831 100644 --- a/dodger/types.rkt +++ b/dodger/runtime/types.rkt @@ -7,16 +7,6 @@ (define type-char #b01) (define mask-char #b11) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [else (error "invalid bits")])) - ;; Value -> Integer (define (value->bits v) diff --git a/dodger/values.c b/dodger/runtime/values.c similarity index 100% rename from dodger/values.c rename to dodger/runtime/values.c diff --git a/dodger/values.h b/dodger/runtime/values.h similarity index 100% rename from dodger/values.h rename to dodger/runtime/values.h diff --git a/dodger/ast.rkt b/dodger/syntax/ast.rkt similarity index 100% rename from dodger/ast.rkt rename to dodger/syntax/ast.rkt diff --git a/dodger/parse.rkt b/dodger/syntax/parse.rkt similarity index 100% rename from dodger/parse.rkt rename to dodger/syntax/parse.rkt diff --git a/dodger/random.rkt b/dodger/syntax/random.rkt similarity index 100% rename from dodger/random.rkt rename to dodger/syntax/random.rkt diff --git a/dodger/test/all.rkt b/dodger/test/all.rkt deleted file mode 100644 index b7c04c1..0000000 --- a/dodger/test/all.rkt +++ /dev/null @@ -1,57 +0,0 @@ -#lang racket -(require "../compile.rkt" - "../interp.rkt" - "../parse.rkt" - "../types.rkt" - (prefix-in bit: "../interp-bits.rkt") - a86/interp - rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ)) - -(test-runner (λ (e) (bit:interp (parse e)))) -(test-runner (λ (e) (interp (parse e)))) -(test-runner (λ (e) (bits->value (asm-interp (compile (parse e)))))) - - diff --git a/dodger/test/compile.rkt b/dodger/test/compile.rkt deleted file mode 100644 index cf7ce11..0000000 --- a/dodger/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - diff --git a/dodger/test/test-runner.rkt b/dodger/test/define-tests.rkt similarity index 100% rename from dodger/test/test-runner.rkt rename to dodger/test/define-tests.rkt diff --git a/dodger/test/interp.rkt b/dodger/test/interp.rkt deleted file mode 100644 index dc33c12..0000000 --- a/dodger/test/interp.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - diff --git a/dodger/test/run-compile-tests.rkt b/dodger/test/run-compile-tests.rkt new file mode 100644 index 0000000..1360550 --- /dev/null +++ b/dodger/test/run-compile-tests.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ (e) (run (compile (parse e))))) + diff --git a/dodger/test/run-interp-tests.rkt b/dodger/test/run-interp-tests.rkt new file mode 100644 index 0000000..7a4ebb9 --- /dev/null +++ b/dodger/test/run-interp-tests.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/dodger/test/parse.rkt b/dodger/test/run-parse-tests.rkt similarity index 90% rename from dodger/test/parse.rkt rename to dodger/test/run-parse-tests.rkt index b3913b8..fd707c8 100644 --- a/dodger/test/parse.rkt +++ b/dodger/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/dupe/Makefile b/dupe/Makefile index 398e3cf..5205a2f 100644 --- a/dupe/Makefile +++ b/dupe/Makefile @@ -8,8 +8,7 @@ endif objs = \ main.o \ - print.o \ - values.o + print.o default: runtime.o diff --git a/dupe/compile-stdin.rkt b/dupe/compile-stdin.rkt deleted file mode 100644 index 532ee0e..0000000 --- a/dupe/compile-stdin.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) - diff --git a/dupe/compile-ops.rkt b/dupe/compiler/compile-ops.rkt similarity index 84% rename from dupe/compile-ops.rkt rename to dupe/compiler/compile-ops.rkt index 9d17339..e92d21b 100644 --- a/dupe/compile-ops.rkt +++ b/dupe/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op1) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Op1 -> Asm diff --git a/dupe/compiler/compile-stdin.rkt b/dupe/compiler/compile-stdin.rkt new file mode 100644 index 0000000..a11acf3 --- /dev/null +++ b/dupe/compiler/compile-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "compile.rkt") +(require a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (asm-display (compile (parse (read))))) + diff --git a/dodger/compile.rkt b/dupe/compiler/compile.rkt similarity index 93% rename from dodger/compile.rkt rename to dupe/compiler/compile.rkt index 593445a..2095e20 100644 --- a/dodger/compile.rkt +++ b/dupe/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Expr -> Asm diff --git a/dupe/correct.rkt b/dupe/correct.rkt index ae6e1ae..16ae264 100644 --- a/dupe/correct.rkt +++ b/dupe/correct.rkt @@ -1,8 +1,8 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp.rkt") -(require "exec.rkt") +(require "interpreter/interp.rkt") +(require "executor/exec.rkt") ;; Expr -> Void (define (check-compiler e) diff --git a/dupe/exec.rkt b/dupe/exec.rkt deleted file mode 100644 index 114a56e..0000000 --- a/dupe/exec.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(provide exec) -;; Expr -> Value -(define (exec e) - (run (compile e))) - diff --git a/dupe/executor/decode.rkt b/dupe/executor/decode.rkt new file mode 100644 index 0000000..465ef49 --- /dev/null +++ b/dupe/executor/decode.rkt @@ -0,0 +1,18 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [else (error "invalid bits")])) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/dupe/executor/exec-stdin.rkt b/dupe/executor/exec-stdin.rkt new file mode 100644 index 0000000..9669e7a --- /dev/null +++ b/dupe/executor/exec-stdin.rkt @@ -0,0 +1,11 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "exec.rkt") + +;; -> Value +;; Parse, compile, and execute contents of stdin +(define (main) + (read-line) ; ignore #lang racket line + (exec (parse (read)))) + diff --git a/dupe/executor/exec.rkt b/dupe/executor/exec.rkt new file mode 100644 index 0000000..71f3c17 --- /dev/null +++ b/dupe/executor/exec.rkt @@ -0,0 +1,9 @@ +#lang racket +(provide exec) +(require a86/interp) +(require "../compiler/compile.rkt") +(require "decode.rkt") + +;; Expr -> Value +(define (exec e) + (bits->value (asm-interp (compile e)))) diff --git a/dupe/interp-bits-wrap.rkt b/dupe/interp-bits-wrap.rkt deleted file mode 100644 index 6c71a47..0000000 --- a/dupe/interp-bits-wrap.rkt +++ /dev/null @@ -1,42 +0,0 @@ -#lang racket -(provide interp-wrap interp-bits-wrap) -(require "ast.rkt" "types.rkt") - -;; type Value = -;; | Integer -;; | Boolean - -(define word-size 64) - -(define shift 1) - -;; type Bits = Integer - -;; Expr -> Bits -(define (interp-bits-wrap e) - (match e - [(Lit i) (value->bits i)] - [(Prim1 'add1 e0) - (wrap (add1 (interp-bits-wrap e0)))] - [(Prim1 'sub1 e0) - (wrap (sub1 (interp-bits-wrap e0)))] - [(Prim1 'zero? e) - (value->bits (zero? (interp-bits-wrap e)))] - [(If e1 e2 e3) - (if (= (interp-bits-wrap e1) (value->bits #f)) - (interp-bits-wrap e3) - (interp-bits-wrap e2))])) - -(define (interp-wrap e) - (bits->value (interp-bits-wrap e))) - -(define (wrap n) - (if (>= (integer-length n) (- word-size shift)) - (- (truncate n)) - n)) - -(define (truncate n) - (bitwise-bit-field n - (max 0 (- (integer-length n) - (- word-size shift))) - (- word-size shift))) diff --git a/dupe/interp-bits.rkt b/dupe/interp-bits.rkt deleted file mode 100644 index 9d47563..0000000 --- a/dupe/interp-bits.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide interp interp-bits) -(require "ast.rkt" "types.rkt" "interp-prim-bits.rkt") - -;; Expr -> Value -(define (interp e) - (bits->value (interp-bits e))) - -;; Expr -> Bits -(define (interp-bits e) - (match e - [(Lit d) (value->bits d)] - [(Prim1 p e) - (interp-prim1-bits p (interp-bits e))] - [(If e1 e2 e3) - (if (= (interp-bits e1) (value->bits #f)) - (interp-bits e3) - (interp-bits e2))])) diff --git a/dupe/interp-prim-bits.rkt b/dupe/interp-prim-bits.rkt deleted file mode 100644 index 330dcec..0000000 --- a/dupe/interp-prim-bits.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require "types.rkt") -(provide interp-prim1-bits) - -;; Op Bits -> Bits -(define (interp-prim1-bits op b) - (match op - ['add1 (+ b (value->bits 1))] - ['sub1 (- b (value->bits 1))] - ['zero? (if (zero? b) (value->bits #t) (value->bits #f))])) diff --git a/dupe/interp-stdin.rkt b/dupe/interp-stdin.rkt deleted file mode 100644 index ce4885f..0000000 --- a/dupe/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (println (interp (parse (read))))) - diff --git a/dupe/interp-prim.rkt b/dupe/interpreter/interp-prim.rkt similarity index 100% rename from dupe/interp-prim.rkt rename to dupe/interpreter/interp-prim.rkt diff --git a/dupe/interpreter/interp-stdin.rkt b/dupe/interpreter/interp-stdin.rkt new file mode 100644 index 0000000..e620f5c --- /dev/null +++ b/dupe/interpreter/interp-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "interp.rkt") + +;; -> Void +;; Parse and interpret contents of stdin, +;; print result on stdout +(define (main) + (read-line) ; ignore #lang racket line + (println (interp (parse (read))))) + diff --git a/dupe/interp.rkt b/dupe/interpreter/interp.rkt similarity index 90% rename from dupe/interp.rkt rename to dupe/interpreter/interp.rkt index ade0993..27bec6b 100644 --- a/dupe/interp.rkt +++ b/dupe/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; type Value = diff --git a/dupe/main.rkt b/dupe/main.rkt index 67ea8be..dc085fd 100644 --- a/dupe/main.rkt +++ b/dupe/main.rkt @@ -1,16 +1,14 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/dupe/run-stdin.rkt b/dupe/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/dupe/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/dupe/run.rkt b/dupe/run.rkt deleted file mode 100644 index 982b94d..0000000 --- a/dupe/run.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(provide run) - -;; Run instructions with run-time system linked in - -;; Asm -> Value -(define (run is) - (bits->value (asm-interp is))) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - - diff --git a/dupe/runtime/Makefile b/dupe/runtime/Makefile new file mode 100644 index 0000000..32de08f --- /dev/null +++ b/dupe/runtime/Makefile @@ -0,0 +1,25 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -g + +OBJS = main.o \ + print.o \ + values.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/dodger/main.c b/dupe/runtime/main.c similarity index 67% rename from dodger/main.c rename to dupe/runtime/main.c index a51b53f..27e672f 100644 --- a/dodger/main.c +++ b/dupe/runtime/main.c @@ -1,3 +1,4 @@ +#include #include "values.h" #include "print.h" @@ -5,9 +6,8 @@ val_t entry(); int main(int argc, char** argv) { - val_t result; - - result = entry(); + val_t result = entry(); print_result(result); + putchar('\n'); return 0; } diff --git a/dupe/print.c b/dupe/runtime/print.c similarity index 100% rename from dupe/print.c rename to dupe/runtime/print.c diff --git a/dupe/print.h b/dupe/runtime/print.h similarity index 100% rename from dupe/print.h rename to dupe/runtime/print.h diff --git a/dupe/types.h b/dupe/runtime/types.h similarity index 100% rename from dupe/types.h rename to dupe/runtime/types.h diff --git a/dupe/types.rkt b/dupe/runtime/types.rkt similarity index 59% rename from dupe/types.rkt rename to dupe/runtime/types.rkt index 865b0c7..d2450a3 100644 --- a/dupe/types.rkt +++ b/dupe/runtime/types.rkt @@ -4,14 +4,6 @@ (define mask-int #b1) (define type-int #b0) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [else (error "invalid bits")])) - ;; Value -> Integer (define (value->bits v) diff --git a/dupe/values.c b/dupe/runtime/values.c similarity index 100% rename from dupe/values.c rename to dupe/runtime/values.c diff --git a/dupe/values.h b/dupe/runtime/values.h similarity index 100% rename from dupe/values.h rename to dupe/runtime/values.h diff --git a/dupe/semantics.rkt b/dupe/semantics.rkt deleted file mode 100644 index ce29a45..0000000 --- a/dupe/semantics.rkt +++ /dev/null @@ -1,74 +0,0 @@ -#lang racket -(provide D-concrete D 𝑫 𝑫-𝒑𝒓𝒊𝒎 is-true is-false) -(require redex/reduction-semantics - (only-in "../con/semantics.rkt" C C-concrete)) - -(define-extended-language D-concrete C-concrete - (e ::= .... boolean (if e e e) (zero? e))) - -(define-extended-language D C - ; new defn to get rid of IfZero - (e ::= (Int i) (Bool b) (Prim1 p1 e) (If e e e)) - (p1 ::= .... 'zero?) - (v ::= i b) - (b ::= #t #f)) - -(define-judgment-form D - #:mode (𝑫 I O) - #:contract (𝑫 e v) - [-------- - (𝑫 (Int i) i)] - - [-------- - (𝑫 (Bool b) b)] - - [(𝑫 e_0 v_0) (where v_1 (𝑫-𝒑𝒓𝒊𝒎 p1 v_0)) - ----------- - (𝑫 (Prim1 p1 e_0) v_1)] - - [(𝑫 e_0 v_0) (is-true v_0) (𝑫 e_1 v_1) - -------- - (𝑫 (If e_0 e_1 e_2) v_1)] - - [(𝑫 e_0 v_0) (is-false v_0) (𝑫 e_2 v_2) - -------- - (𝑫 (If e_0 e_1 e_2) v_2)]) - -(define-metafunction D - 𝑫-𝒑𝒓𝒊𝒎 : p1 v -> v or ⊥ - [(𝑫-𝒑𝒓𝒊𝒎 'add1 i) ,(+ (term i) (term 1))] - [(𝑫-𝒑𝒓𝒊𝒎 'sub1 i) ,(- (term i) (term 1))] - [(𝑫-𝒑𝒓𝒊𝒎 'zero? 0) #t] - [(𝑫-𝒑𝒓𝒊𝒎 'zero? i) #f] - [(𝑫-𝒑𝒓𝒊𝒎 _ _) ⊥]) - -(module+ test - (test-judgment-holds (𝑫 (Int 7) 7)) - (test-judgment-holds (𝑫 (Bool #f) #f)) - (test-judgment-holds (𝑫 (Bool #t) #t)) - (test-judgment-holds (𝑫 (Prim1 'add1 (Int 8)) 9)) - (test-judgment-holds (𝑫 (Prim1 'sub1 (Int 8)) 7)) - - (test-judgment-holds (𝑫 (If (Bool #f) (Int 3) (Int 4)) 4)) - (test-judgment-holds (𝑫 (If (Bool #t) (Int 3) (Int 4)) 3)) - (test-judgment-holds (𝑫 (Prim1 'zero? (Int 0)) #t)) - (test-judgment-holds (𝑫 (Prim1 'zero? (Int 1)) #f)) - (test-judgment-holds (𝑫 (If (Prim1 'zero? (Int 0)) (Int 3) (Int 4)) 3)) - (test-judgment-holds (𝑫 (If (Prim1 'zero? (Int 1)) (Int 3) (Int 4)) 4))) - -(define-judgment-form D - #:mode (is-true I) - #:contract (is-true v) - [----------- - (is-true #t)] - [---------- - (is-true i)]) - -(define-judgment-form D - #:mode (is-false I) - #:contract (is-false v) - [----------- - (is-false #f)]) - -(define (!= n m) - (not (= n m))) diff --git a/dupe/ast.rkt b/dupe/syntax/ast.rkt similarity index 100% rename from dupe/ast.rkt rename to dupe/syntax/ast.rkt diff --git a/dupe/parse.rkt b/dupe/syntax/parse.rkt similarity index 100% rename from dupe/parse.rkt rename to dupe/syntax/parse.rkt diff --git a/dupe/random.rkt b/dupe/syntax/random.rkt similarity index 100% rename from dupe/random.rkt rename to dupe/syntax/random.rkt diff --git a/dupe/test/all.rkt b/dupe/test/all.rkt deleted file mode 100644 index e836ef6..0000000 --- a/dupe/test/all.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang racket -(require "../compile.rkt" - "../interp.rkt" - "../parse.rkt" - "../types.rkt" - (prefix-in bit: "../interp-bits.rkt") - a86/interp - rackunit) - -(define (test-runner run) - - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t)) - -(test-runner (λ (e) (interp (parse e)))) -(test-runner (λ (e) (bit:interp (parse e)))) -(test-runner (λ (e) (bits->value (asm-interp (compile (parse e)))))) diff --git a/dupe/test/compile.rkt b/dupe/test/compile.rkt deleted file mode 100644 index cf7ce11..0000000 --- a/dupe/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - diff --git a/dupe/test/test-runner.rkt b/dupe/test/define-tests.rkt similarity index 100% rename from dupe/test/test-runner.rkt rename to dupe/test/define-tests.rkt diff --git a/dupe/test/interp.rkt b/dupe/test/interp.rkt deleted file mode 100644 index dc33c12..0000000 --- a/dupe/test/interp.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - diff --git a/dupe/test/run-compile-tests.rkt b/dupe/test/run-compile-tests.rkt new file mode 100644 index 0000000..a13ebef --- /dev/null +++ b/dupe/test/run-compile-tests.rkt @@ -0,0 +1,6 @@ +#lang racket +(require "../syntax/parse.rkt") +(require "../executor/exec.rkt") +(require "define-tests.rkt") +(test (λ (e) (exec (parse e)))) + diff --git a/dupe/test/run-interp-tests.rkt b/dupe/test/run-interp-tests.rkt new file mode 100644 index 0000000..7a4ebb9 --- /dev/null +++ b/dupe/test/run-interp-tests.rkt @@ -0,0 +1,7 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + diff --git a/dupe/test/parse.rkt b/dupe/test/run-parse-tests.rkt similarity index 87% rename from dupe/test/parse.rkt rename to dupe/test/run-parse-tests.rkt index 8fd1122..2ca5075 100644 --- a/dupe/test/parse.rkt +++ b/dupe/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/evildoer/Makefile b/evildoer/Makefile index d88e2b9..2d442f8 100644 --- a/evildoer/Makefile +++ b/evildoer/Makefile @@ -6,32 +6,33 @@ else LANGS_AS ?= clang -c endif -objs = \ - main.o \ - print.o \ - values.o \ - io.o +RACKET ?= racket -default: runtime.o +RUNTIME_DIR := runtime +RUNTIME := $(RUNTIME_DIR)/runtime.o -runtime.o: $(objs) - ld -r $(objs) -o runtime.o +# Example source extension for this language. +SRC_EXT := rkt -%.run: %.o runtime.o - $(LANGS_CC) runtime.o $< -o $@ +default: + @echo "example: make foo.run" -.c.o: - $(LANGS_CC) -fPIC -c -g -o $@ $< +# Build the runtime bundles if needed. +$(RUNTIME): + $(MAKE) -C $(RUNTIME_DIR) -.s.o: +# Compile source program to assembly. +%.s: %.$(SRC_EXT) + cat $< | $(RACKET) -t compiler/compile-stdin.rkt -m > $@ + +# Assemble to object. +%.o: %.s $(LANGS_AS) -o $@ $< -%.s: %.rkt - cat $< | racket -t compile-stdin.rkt -m > $@ +# Link standalone executable. +%.run: %.o $(RUNTIME) + $(LANGS_CC) -o $@ $^ clean: @$(RM) *.o *.s *.run ||: - @echo "$(shell basename $(shell pwd)): cleaned!" - -%.test: %.run %.rkt - @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" + @$(MAKE) -C $(RUNTIME_DIR) clean diff --git a/evildoer/build-runtime.rkt b/evildoer/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/evildoer/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/evildoer/compile-stdin.rkt b/evildoer/compile-stdin.rkt deleted file mode 100644 index 532ee0e..0000000 --- a/evildoer/compile-stdin.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) - diff --git a/evildoer/compile-ops.rkt b/evildoer/compiler/compile-ops.rkt similarity index 94% rename from evildoer/compile-ops.rkt rename to evildoer/compiler/compile-ops.rkt index 216179c..4f6d7e2 100644 --- a/evildoer/compile-ops.rkt +++ b/evildoer/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Op0 -> Asm diff --git a/evildoer/compiler/compile-stdin.rkt b/evildoer/compiler/compile-stdin.rkt new file mode 100644 index 0000000..a11acf3 --- /dev/null +++ b/evildoer/compiler/compile-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "compile.rkt") +(require a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (asm-display (compile (parse (read))))) + diff --git a/evildoer/compile.rkt b/evildoer/compiler/compile.rkt similarity index 94% rename from evildoer/compile.rkt rename to evildoer/compiler/compile.rkt index 241d45e..03a3d5c 100644 --- a/evildoer/compile.rkt +++ b/evildoer/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Expr -> Asm diff --git a/evildoer/correct.rkt b/evildoer/correct.rkt index 0c4896d..cf21df8 100644 --- a/evildoer/correct.rkt +++ b/evildoer/correct.rkt @@ -1,8 +1,9 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/exec.rkt") +(require "compiler/compile.rkt") ;; Expr String -> Void (define (check-compiler e i) (let ((r (with-handlers ([exn:fail? identity]) diff --git a/evildoer/exec-io.rkt b/evildoer/exec-io.rkt deleted file mode 100644 index 9578890..0000000 --- a/evildoer/exec-io.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile e) in) - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/evildoer/exec.rkt b/evildoer/exec.rkt deleted file mode 100644 index ff8b714..0000000 --- a/evildoer/exec.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Expr -> Value -(define (exec e) - (run (compile e))) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (run/io (compile e) in)) - diff --git a/evildoer/executor/decode.rkt b/evildoer/executor/decode.rkt new file mode 100644 index 0000000..89f3464 --- /dev/null +++ b/evildoer/executor/decode.rkt @@ -0,0 +1,22 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [else (error "invalid bits")])) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/evildoer/executor/exec-stdin.rkt b/evildoer/executor/exec-stdin.rkt new file mode 100644 index 0000000..9669e7a --- /dev/null +++ b/evildoer/executor/exec-stdin.rkt @@ -0,0 +1,11 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "exec.rkt") + +;; -> Value +;; Parse, compile, and execute contents of stdin +(define (main) + (read-line) ; ignore #lang racket line + (exec (parse (read)))) + diff --git a/evildoer/executor/exec.rkt b/evildoer/executor/exec.rkt new file mode 100644 index 0000000..ae90943 --- /dev/null +++ b/evildoer/executor/exec.rkt @@ -0,0 +1,17 @@ +#lang racket +(provide exec exec/io) +(require "../compiler/compile.rkt") +(require "decode.rkt") +(require "host.rkt") + +;; Expr -> Value +(define (exec e) + (bits->value (asm-interp/host (compile e)))) + +;; Asm String -> (cons Value String) +(define (exec/io e in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (exec e) + (get-output-string (current-output-port))))) + diff --git a/evildoer/executor/host.rkt b/evildoer/executor/host.rkt new file mode 100644 index 0000000..26a64e8 --- /dev/null +++ b/evildoer/executor/host.rkt @@ -0,0 +1,22 @@ +#lang racket +(require a86/interp) +(require ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(provide (all-defined-out)) + +(define (prim-read-byte) + (value->bits (read-byte))) +(define (prim-peek-byte) + (value->bits (peek-byte))) +(define (prim-write-byte bs) + (value->bits (write-byte (bits->value bs)))) + +(define (asm-interp/host asm) + (parameterize + ([current-externs + (list (extern 'read_byte prim-read-byte (_fun -> _int64)) + (extern 'peek_byte prim-peek-byte (_fun -> _int64)) + (extern 'write_byte prim-write-byte (_fun _int64 -> _int64)))]) + (asm-interp asm))) + diff --git a/evildoer/interp-stdin.rkt b/evildoer/interp-stdin.rkt deleted file mode 100644 index ce4885f..0000000 --- a/evildoer/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (println (interp (parse (read))))) - diff --git a/mountebank/interp-io.rkt b/evildoer/interpreter/interp-io.rkt similarity index 79% rename from mountebank/interp-io.rkt rename to evildoer/interpreter/interp-io.rkt index 93f7d3c..ccc2dfe 100644 --- a/mountebank/interp-io.rkt +++ b/evildoer/interpreter/interp-io.rkt @@ -2,9 +2,9 @@ (provide interp/io) (require "interp.rkt") -;; (Expr String -> String +;; String Expr -> (Cons Value String) ;; Interpret e with given string as input, -;; collect output as string (including printed result) +;; return value and collected output as string (define (interp/io e in) (parameterize ((current-output-port (open-output-string)) (current-input-port (open-input-string in))) diff --git a/evildoer/interp-prim.rkt b/evildoer/interpreter/interp-prim.rkt similarity index 100% rename from evildoer/interp-prim.rkt rename to evildoer/interpreter/interp-prim.rkt diff --git a/evildoer/interpreter/interp-stdin.rkt b/evildoer/interpreter/interp-stdin.rkt new file mode 100644 index 0000000..e620f5c --- /dev/null +++ b/evildoer/interpreter/interp-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "interp.rkt") + +;; -> Void +;; Parse and interpret contents of stdin, +;; print result on stdout +(define (main) + (read-line) ; ignore #lang racket line + (println (interp (parse (read))))) + diff --git a/evildoer/interp.rkt b/evildoer/interpreter/interp.rkt similarity index 93% rename from evildoer/interp.rkt rename to evildoer/interpreter/interp.rkt index 4c6e520..59edb74 100644 --- a/evildoer/interp.rkt +++ b/evildoer/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; type Value = diff --git a/evildoer/main.rkt b/evildoer/main.rkt index 50cf56e..ae83f33 100644 --- a/evildoer/main.rkt +++ b/evildoer/main.rkt @@ -1,18 +1,16 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/evildoer/run-stdin.rkt b/evildoer/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/evildoer/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/evildoer/run.rkt b/evildoer/run.rkt deleted file mode 100644 index 34a053d..0000000 --- a/evildoer/run.rkt +++ /dev/null @@ -1,22 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Value -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) -;; Asm String -> (cons Value String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/evildoer/runtime/Makefile b/evildoer/runtime/Makefile new file mode 100644 index 0000000..9b47733 --- /dev/null +++ b/evildoer/runtime/Makefile @@ -0,0 +1,27 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/evildoer/gcd.c b/evildoer/runtime/gcd.c similarity index 100% rename from evildoer/gcd.c rename to evildoer/runtime/gcd.c diff --git a/hoax/io.c b/evildoer/runtime/io.c similarity index 74% rename from hoax/io.c rename to evildoer/runtime/io.c index 8a417c9..139dccb 100644 --- a/hoax/io.c +++ b/evildoer/runtime/io.c @@ -6,20 +6,20 @@ val_t read_byte(void) { - char c = getc(in); + char c = getc(stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + char c = getc(stdin); + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + putc((char) val_unwrap_int(c), stdout); return val_wrap_void(); } diff --git a/evildoer/runtime/main.c b/evildoer/runtime/main.c new file mode 100644 index 0000000..d75fd8d --- /dev/null +++ b/evildoer/runtime/main.c @@ -0,0 +1,15 @@ +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +int main(int argc, char** argv) +{ + val_t result = entry(); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + return 0; +} diff --git a/evildoer/print.c b/evildoer/runtime/print.c similarity index 100% rename from evildoer/print.c rename to evildoer/runtime/print.c diff --git a/evildoer/print.h b/evildoer/runtime/print.h similarity index 100% rename from evildoer/print.h rename to evildoer/runtime/print.h diff --git a/evildoer/runtime.h b/evildoer/runtime/runtime.h similarity index 73% rename from evildoer/runtime.h rename to evildoer/runtime/runtime.h index 4d4ebf1..8f6d8ca 100644 --- a/evildoer/runtime.h +++ b/evildoer/runtime/runtime.h @@ -4,6 +4,5 @@ #include "values.h" val_t entry(); -extern FILE* in; -extern FILE* out; + #endif /* RUNTIME_H */ diff --git a/evildoer/types.h b/evildoer/runtime/types.h similarity index 100% rename from evildoer/types.h rename to evildoer/runtime/types.h diff --git a/extort/types.rkt b/evildoer/runtime/types.rkt similarity index 62% rename from extort/types.rkt rename to evildoer/runtime/types.rkt index 827e0f1..7a5f023 100644 --- a/extort/types.rkt +++ b/evildoer/runtime/types.rkt @@ -7,18 +7,6 @@ (define type-char #b01) (define mask-char #b11) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [else (error "invalid bits")])) - ;; Value -> Integer (define (value->bits v) diff --git a/evildoer/values.c b/evildoer/runtime/values.c similarity index 100% rename from evildoer/values.c rename to evildoer/runtime/values.c diff --git a/evildoer/values.h b/evildoer/runtime/values.h similarity index 100% rename from evildoer/values.h rename to evildoer/runtime/values.h diff --git a/evildoer/ast.rkt b/evildoer/syntax/ast.rkt similarity index 100% rename from evildoer/ast.rkt rename to evildoer/syntax/ast.rkt diff --git a/evildoer/parse.rkt b/evildoer/syntax/parse.rkt similarity index 100% rename from evildoer/parse.rkt rename to evildoer/syntax/parse.rkt diff --git a/evildoer/random.rkt b/evildoer/syntax/random.rkt similarity index 100% rename from evildoer/random.rkt rename to evildoer/syntax/random.rkt diff --git a/evildoer/test/all.rkt b/evildoer/test/all.rkt deleted file mode 100644 index 4b456a1..0000000 --- a/evildoer/test/all.rkt +++ /dev/null @@ -1,90 +0,0 @@ -#lang racket -(require "../compile.rkt" - "../interp.rkt" - "../interp-io.rkt" - "../parse.rkt" - "../types.rkt" - "../build-runtime.rkt" - a86/interp - rackunit) - -;; link with runtime for IO operations -(current-objs - (list (path->string runtime-path))) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Evildoer examples - (check-equal? (run '(void)) (void)) - (check-equal? (run '(begin 1 2)) 2) - (check-equal? (run '(eof-object? (void))) #f)) - -(test-runner (λ (e) (interp (parse e)))) -(test-runner (λ (e) (bits->value (asm-interp (compile (parse e)))))) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) - - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 ""))) - -(test-runner-io (λ (e s) (interp/io (parse e) s))) -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - [(cons r o) - (cons (bits->value r) o)]))) - -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit "../../test-programs/get-progs.rkt") -(for-each test-prog (get-progs "evildoer")) diff --git a/evildoer/test/compile.rkt b/evildoer/test/compile.rkt deleted file mode 100644 index 38cb738..0000000 --- a/evildoer/test/compile.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - -(test/io (λ (i e) (exec/io (parse e) i))) - diff --git a/evildoer/test/test-runner.rkt b/evildoer/test/define-tests.rkt similarity index 100% rename from evildoer/test/test-runner.rkt rename to evildoer/test/define-tests.rkt diff --git a/evildoer/test/interp.rkt b/evildoer/test/interp.rkt deleted file mode 100644 index 74d4a05..0000000 --- a/evildoer/test/interp.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - -(test/io (λ (in e) (interp/io (parse e) in))) - diff --git a/evildoer/test/run-compile-tests.rkt b/evildoer/test/run-compile-tests.rkt new file mode 100644 index 0000000..2a0cabf --- /dev/null +++ b/evildoer/test/run-compile-tests.rkt @@ -0,0 +1,9 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/exec.rkt") +(require "define-tests.rkt") +(test (λ (e) (exec (parse e)))) + +(test/io (λ (i e) (exec/io (parse e) i))) + diff --git a/evildoer/test/run-interp-tests.rkt b/evildoer/test/run-interp-tests.rkt new file mode 100644 index 0000000..4fdfde2 --- /dev/null +++ b/evildoer/test/run-interp-tests.rkt @@ -0,0 +1,10 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + +(test/io (λ (in e) (interp/io (parse e) in))) + diff --git a/evildoer/test/parse.rkt b/evildoer/test/run-parse-tests.rkt similarity index 92% rename from evildoer/test/parse.rkt rename to evildoer/test/run-parse-tests.rkt index cefbeba..2aec3f6 100644 --- a/evildoer/test/parse.rkt +++ b/evildoer/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/extort/Makefile b/extort/Makefile index 6fe052b..5205a2f 100644 --- a/extort/Makefile +++ b/extort/Makefile @@ -5,11 +5,10 @@ else LANGS_CC ?= clang LANGS_AS ?= clang -c endif + objs = \ main.o \ - print.o \ - values.o \ - io.o + print.o default: runtime.o diff --git a/extort/build-runtime.rkt b/extort/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/extort/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/extort/compile-stdin.rkt b/extort/compile-stdin.rkt deleted file mode 100644 index 532ee0e..0000000 --- a/extort/compile-stdin.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read))))) - diff --git a/extort/assert.rkt b/extort/compiler/assert.rkt similarity index 96% rename from extort/assert.rkt rename to extort/compiler/assert.rkt index 9d88901..a22f93d 100644 --- a/extort/assert.rkt +++ b/extort/compiler/assert.rkt @@ -1,7 +1,7 @@ #lang racket (provide assert-integer assert-char assert-byte assert-codepoint) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") ;; Register -> Asm (define (assert-integer r) diff --git a/extort/compile-ops.rkt b/extort/compiler/compile-ops.rkt similarity index 95% rename from extort/compile-ops.rkt rename to extort/compiler/compile-ops.rkt index 8cc5ea8..ac14266 100644 --- a/extort/compile-ops.rkt +++ b/extort/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) diff --git a/extort/compiler/compile-stdin.rkt b/extort/compiler/compile-stdin.rkt new file mode 100644 index 0000000..a11acf3 --- /dev/null +++ b/extort/compiler/compile-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "compile.rkt") +(require a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (asm-display (compile (parse (read))))) + diff --git a/extort/compile.rkt b/extort/compiler/compile.rkt similarity index 95% rename from extort/compile.rkt rename to extort/compiler/compile.rkt index 4ecdd07..b9cf54c 100644 --- a/extort/compile.rkt +++ b/extort/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Expr -> Asm diff --git a/extort/correct.rkt b/extort/correct.rkt index 8a8a601..5909846 100644 --- a/extort/correct.rkt +++ b/extort/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; Expr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/extort/exec-io.rkt b/extort/exec-io.rkt deleted file mode 100644 index d385fc4..0000000 --- a/extort/exec-io.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile e) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/extort/exec.rkt b/extort/exec.rkt deleted file mode 100644 index 4ad3df2..0000000 --- a/extort/exec.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Expr -> Answer -(define (exec e) - (run (compile e))) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (run/io (compile e) in)) - diff --git a/extort/executor/decode.rkt b/extort/executor/decode.rkt new file mode 100644 index 0000000..89f3464 --- /dev/null +++ b/extort/executor/decode.rkt @@ -0,0 +1,22 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [else (error "invalid bits")])) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/extort/executor/exec.rkt b/extort/executor/exec.rkt new file mode 100644 index 0000000..f6fccb2 --- /dev/null +++ b/extort/executor/exec.rkt @@ -0,0 +1,54 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") + +(struct exec-state (program) #:transparent) + +(define (exec/state prog) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)))) + +(define (exec-call st) + (match-define (exec-state program) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/abscond/run-stdin.rkt b/extort/executor/run-stdin.rkt similarity index 74% rename from abscond/run-stdin.rkt rename to extort/executor/run-stdin.rkt index 16cf99e..ac60d60 100644 --- a/abscond/run-stdin.rkt +++ b/extort/executor/run-stdin.rkt @@ -1,12 +1,13 @@ #lang racket (provide main) -(require "parse.rkt") -(require "compile.rkt") +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") (require "run.rkt") ;; -> Void ;; Compile contents of stdin and use asm-interp to run (define (main) (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) diff --git a/extort/executor/run.rkt b/extort/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/extort/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/extort/interp-cps.rkt b/extort/interp-cps.rkt deleted file mode 100644 index 5043ad0..0000000 --- a/extort/interp-cps.rkt +++ /dev/null @@ -1,26 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; Expr (Value -> Answer) -> Answer -(define (interp/cps e k) - (match e - [(? integer? i) (k i)] - [(? boolean? b) (k b)] - [`(add1 ,e0) - (interp/cps e0 (assert integer? add1))] - [`(sub1 ,e0) - (interp/cps e0 (assert integer? sub1))] - [`(zero? ,e0) - (interp/cps e0 (assert integer? zero?))] - [`(if ,e0 ,e1 ,e2) - (interp/cps e0 (λ (v) - (if v - (interp/cps e1 k) - (interp/cps e2 k))))])) - -;; (Value -> Boolean) (Value -> Answer) -> (Value -> Answer) -(define (assert pred k) - (λ (v) - (if (pred v) - (k v) - 'error))) diff --git a/extort/interp-stdin.rkt b/extort/interp-stdin.rkt deleted file mode 100644 index ce4885f..0000000 --- a/extort/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "interp.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (println (interp (parse (read))))) - diff --git a/extort/interp-io.rkt b/extort/interpreter/interp-io.rkt similarity index 100% rename from extort/interp-io.rkt rename to extort/interpreter/interp-io.rkt diff --git a/extort/interp-prim.rkt b/extort/interpreter/interp-prim.rkt similarity index 100% rename from extort/interp-prim.rkt rename to extort/interpreter/interp-prim.rkt diff --git a/extort/interpreter/interp-stdin.rkt b/extort/interpreter/interp-stdin.rkt new file mode 100644 index 0000000..e620f5c --- /dev/null +++ b/extort/interpreter/interp-stdin.rkt @@ -0,0 +1,12 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "interp.rkt") + +;; -> Void +;; Parse and interpret contents of stdin, +;; print result on stdout +(define (main) + (read-line) ; ignore #lang racket line + (println (interp (parse (read))))) + diff --git a/extort/interp.rkt b/extort/interpreter/interp.rkt similarity index 95% rename from extort/interp.rkt rename to extort/interpreter/interp.rkt index a3e3925..04d0efc 100644 --- a/extort/interp.rkt +++ b/extort/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; type Value = diff --git a/extort/main.c b/extort/main.c deleted file mode 100644 index 5f17cbd..0000000 --- a/extort/main.c +++ /dev/null @@ -1,36 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - - val_t result; - - result = entry(); - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - return 0; -} diff --git a/extort/main.rkt b/extort/main.rkt index 50cf56e..f9851a3 100644 --- a/extort/main.rkt +++ b/extort/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/extort/run-stdin.rkt b/extort/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/extort/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/extort/run.rkt b/extort/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/extort/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/extort/runtime.h b/extort/runtime.h deleted file mode 100644 index 0a066ad..0000000 --- a/extort/runtime.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); -#endif /* RUNTIME_H */ diff --git a/extort/runtime/Makefile b/extort/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/extort/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/extort/runtime/error.c b/extort/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/extort/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/evildoer/io.c b/extort/runtime/io.c similarity index 74% rename from evildoer/io.c rename to extort/runtime/io.c index 8a417c9..139dccb 100644 --- a/evildoer/io.c +++ b/extort/runtime/io.c @@ -6,20 +6,20 @@ val_t read_byte(void) { - char c = getc(in); + char c = getc(stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + char c = getc(stdin); + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + putc((char) val_unwrap_int(c), stdout); return val_wrap_void(); } diff --git a/evildoer/main.c b/extort/runtime/main.c similarity index 70% rename from evildoer/main.c rename to extort/runtime/main.c index b79bfa7..4d814bd 100644 --- a/evildoer/main.c +++ b/extort/runtime/main.c @@ -3,17 +3,10 @@ #include "print.h" #include "runtime.h" -FILE* in; -FILE* out; - int main(int argc, char** argv) { - in = stdin; - out = stdout; + val_t result = entry(); - val_t result; - - result = entry(); print_result(result); if (val_typeof(result) != T_VOID) putchar('\n'); diff --git a/extort/print.c b/extort/runtime/print.c similarity index 100% rename from extort/print.c rename to extort/runtime/print.c diff --git a/extort/print.h b/extort/runtime/print.h similarity index 100% rename from extort/print.h rename to extort/runtime/print.h diff --git a/extort/runtime/runtime.h b/extort/runtime/runtime.h new file mode 100644 index 0000000..fb6a288 --- /dev/null +++ b/extort/runtime/runtime.h @@ -0,0 +1,14 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +val_t entry(); + +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/extort/types.h b/extort/runtime/types.h similarity index 100% rename from extort/types.h rename to extort/runtime/types.h diff --git a/evildoer/types.rkt b/extort/runtime/types.rkt similarity index 62% rename from evildoer/types.rkt rename to extort/runtime/types.rkt index 827e0f1..7a5f023 100644 --- a/evildoer/types.rkt +++ b/extort/runtime/types.rkt @@ -7,18 +7,6 @@ (define type-char #b01) (define mask-char #b11) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [else (error "invalid bits")])) - ;; Value -> Integer (define (value->bits v) diff --git a/extort/values.c b/extort/runtime/values.c similarity index 100% rename from extort/values.c rename to extort/runtime/values.c diff --git a/extort/values.h b/extort/runtime/values.h similarity index 100% rename from extort/values.h rename to extort/runtime/values.h diff --git a/extort/semantics.rkt b/extort/semantics.rkt deleted file mode 100644 index 056e868..0000000 --- a/extort/semantics.rkt +++ /dev/null @@ -1,75 +0,0 @@ -#lang racket -(provide E-concrete E 𝑬) -(require redex/reduction-semantics - (only-in "../dupe/semantics.rkt" D-concrete D 𝑫)) - -(define-extended-language E-concrete D-concrete - (e ::= ....) - (a ::= v err)) - -(define-extended-language E D - (e ::= ....) - (a ::= v err)) - -(define-extended-judgment-form E 𝑫 - #:mode (𝑬 I O) - #:contract (𝑬 e a) - [(𝑬 e b) - -------- - (𝑬 (Prim1 'add1 e) err)] - - [(𝑬 e b) - ----------- - (𝑬 (Prim1 'sub1 e) err)] - - [(𝑬 e b) - ----------- - (𝑬 (Prim1 'zero? e) err)] - - [(𝑬 e err) - ----------- - (𝑬 (Prim1 'zero? e) err)] - - [(𝑬 e err) - ----------- - (𝑬 (Prim1 'add1 e) err)] - - [(𝑬 e err) - ----------- - (𝑬 (Prim1 'sub1 e) err)] - - [(𝑬 e err) - ----------- - (𝑬 (If e e_0 e_1) err)]) - - -(module+ test - (test-judgment-holds (𝑬 (Int 7) 7)) - (test-judgment-holds (𝑬 (Bool #f) #f)) - (test-judgment-holds (𝑬 (Bool #t) #t)) - (test-judgment-holds (𝑬 (Prim1 'add1 (Int 8)) 9)) - (test-judgment-holds (𝑬 (Prim1 'sub1 (Int 8)) 7)) - - (test-judgment-holds (𝑬 (If (Bool #f) (Int 3) (Int 4)) 4)) - (test-judgment-holds (𝑬 (If (Bool #t) (Int 3) (Int 4)) 3)) - (test-judgment-holds (𝑬 (Prim1 'zero? (Int 0)) #t)) - (test-judgment-holds (𝑬 (Prim1 'zero? (Int 1)) #f)) - (test-judgment-holds (𝑬 (If (Prim1 'zero? (Int 0)) (Int 3) (Int 4)) 3)) - (test-judgment-holds (𝑬 (If (Prim1 'zero? (Int 1)) (Int 3) (Int 4)) 4)) - - - (test-judgment-holds (𝑬 (Prim1 'add1 (Bool #t)) err)) - (test-judgment-holds (𝑬 (Prim1 'add1 (Bool #f)) err)) - (test-judgment-holds (𝑬 (Prim1 'sub1 (Bool #t)) err)) - (test-judgment-holds (𝑬 (Prim1 'sub1 (Bool #f)) err)) - (test-judgment-holds (𝑬 (Prim1 'zero? (Bool #t)) err)) - (test-judgment-holds (𝑬 (Prim1 'zero? (Bool #f)) err)) - - (test-judgment-holds (𝑬 (Prim1 'add1 (If (Bool #t) (Bool #t) (Bool #t))) err)) - (test-judgment-holds (𝑬 (Prim1 'sub1 (If (Bool #t) (Bool #t) (Bool #t))) err)) - (test-judgment-holds (𝑬 (Prim1 'zero? (If (Bool #t) (Bool #t) (Bool #t))) err)) - - (test-judgment-holds (𝑬 (Prim1 'add1 (Prim1 'zero? (Bool #f))) err)) - (test-judgment-holds (𝑬 (Prim1 'sub1 (Prim1 'zero? (Bool #f))) err)) - (test-judgment-holds (𝑬 (Prim1 'zero? (Prim1 'zero? (Bool #f))) err)) - (test-judgment-holds (𝑬 (If (Prim1 'zero? (Bool #f)) (Int 1) (Int 2)) err))) diff --git a/extort/ast.rkt b/extort/syntax/ast.rkt similarity index 100% rename from extort/ast.rkt rename to extort/syntax/ast.rkt diff --git a/extort/parse.rkt b/extort/syntax/parse.rkt similarity index 100% rename from extort/parse.rkt rename to extort/syntax/parse.rkt diff --git a/extort/random.rkt b/extort/syntax/random.rkt similarity index 100% rename from extort/random.rkt rename to extort/syntax/random.rkt diff --git a/extort/test/all.rkt b/extort/test/all.rkt deleted file mode 100644 index 9bc3e3a..0000000 --- a/extort/test/all.rkt +++ /dev/null @@ -1,111 +0,0 @@ -#lang racket -(require "../compile.rkt" - "../interp.rkt" - "../interp-io.rkt" - "../parse.rkt" - "../types.rkt" - "../build-runtime.rkt" - a86/interp - rackunit) - -;; link with runtime for IO operations -;(unless (file-exists? "../runtime.o") -; (system "make -C .. runtime.o")) -(current-objs - (list (path->string runtime-path))) - -(define (test-runner run) - - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Evildoer examples - (check-equal? (run '(void)) (void)) - (check-equal? (run '(begin 1 2)) 2) - (check-equal? (run '(eof-object? (void))) #f) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - (check-equal? (run '(begin (integer->char 97) - (integer->char 98))) - #\b)) - -(test-runner (λ (e) (interp (parse e)))) -(test-runner (λ (e) (match (asm-interp (compile (parse e))) - ['err 'err] - [bs (bits->value bs)]))) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run 7 "") (cons 7 "")) - (check-equal? (run '(write-byte 97) "") (cons (void) "a")) - (check-equal? (run '(read-byte) "a") (cons 97 "")) - (check-equal? (run '(begin (write-byte 97) (read-byte)) "b") - (cons 98 "a")) - (check-equal? (run '(read-byte) "") (cons eof "")) - (check-equal? (run '(eof-object? (read-byte)) "") (cons #t "")) - (check-equal? (run '(eof-object? (read-byte)) "a") (cons #f "")) - (check-equal? (run '(begin (write-byte 97) (write-byte 98)) "") - (cons (void) "ab")) - - (check-equal? (run '(peek-byte) "ab") (cons 97 "")) - (check-equal? (run '(begin (peek-byte) (read-byte)) "ab") (cons 97 "")) - ;; Extort examples - (check-equal? (run '(write-byte #t) "") (cons 'err ""))) - -(test-runner-io (λ (e s) (interp/io (parse e) s))) -(test-runner-io (λ (e s) - (match (asm-interp/io (compile (parse e)) s) - [(cons 'err o) (cons 'err o)] - [(cons r o) - (cons (bits->value r) o)]))) - -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit "../../test-programs/get-progs.rkt") -(for-each test-prog (get-progs "extort")) diff --git a/extort/test/compile.rkt b/extort/test/compile.rkt deleted file mode 100644 index 38cb738..0000000 --- a/extort/test/compile.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") - -(test (λ (e) (exec (parse e)))) - -(test/io (λ (i e) (exec/io (parse e) i))) - diff --git a/extort/test/test-runner.rkt b/extort/test/define-tests.rkt similarity index 100% rename from extort/test/test-runner.rkt rename to extort/test/define-tests.rkt diff --git a/extort/test/interp.rkt b/extort/test/interp.rkt deleted file mode 100644 index 74d4a05..0000000 --- a/extort/test/interp.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") - -(test (λ (e) (interp (parse e)))) - -(test/io (λ (in e) (interp/io (parse e) in))) - diff --git a/extort/test/run-compile-tests.rkt b/extort/test/run-compile-tests.rkt new file mode 100644 index 0000000..95e541e --- /dev/null +++ b/extort/test/run-compile-tests.rkt @@ -0,0 +1,9 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ (e) (run (compile (parse e))))) + +(test/io (λ (i e) (run/io (compile (parse e)) i))) + diff --git a/extort/test/run-interp-tests.rkt b/extort/test/run-interp-tests.rkt new file mode 100644 index 0000000..4fdfde2 --- /dev/null +++ b/extort/test/run-interp-tests.rkt @@ -0,0 +1,10 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") + +(test (λ (e) (interp (parse e)))) + +(test/io (λ (in e) (interp/io (parse e) in))) + diff --git a/extort/test/parse.rkt b/extort/test/run-parse-tests.rkt similarity index 92% rename from extort/test/parse.rkt rename to extort/test/run-parse-tests.rkt index cefbeba..2aec3f6 100644 --- a/extort/test/parse.rkt +++ b/extort/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/fraud/Makefile b/fraud/Makefile index d88e2b9..5205a2f 100644 --- a/fraud/Makefile +++ b/fraud/Makefile @@ -8,9 +8,7 @@ endif objs = \ main.o \ - print.o \ - values.o \ - io.o + print.o default: runtime.o diff --git a/fraud/build-runtime.rkt b/fraud/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/fraud/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/fraud/assert.rkt b/fraud/compiler/assert.rkt similarity index 96% rename from fraud/assert.rkt rename to fraud/compiler/assert.rkt index 9d88901..a22f93d 100644 --- a/fraud/assert.rkt +++ b/fraud/compiler/assert.rkt @@ -1,7 +1,7 @@ #lang racket (provide assert-integer assert-char assert-byte assert-codepoint) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") ;; Register -> Asm (define (assert-integer r) diff --git a/fraud/compile-ops.rkt b/fraud/compiler/compile-ops.rkt similarity index 97% rename from fraud/compile-ops.rkt rename to fraud/compiler/compile-ops.rkt index dae38c3..f46c570 100644 --- a/fraud/compile-ops.rkt +++ b/fraud/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 pad-stack) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) diff --git a/fraud/compile-stdin.rkt b/fraud/compiler/compile-stdin.rkt similarity index 88% rename from fraud/compile-stdin.rkt rename to fraud/compiler/compile-stdin.rkt index b8e500c..dce355a 100644 --- a/fraud/compile-stdin.rkt +++ b/fraud/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/fraud/compile.rkt b/fraud/compiler/compile.rkt similarity index 97% rename from fraud/compile.rkt rename to fraud/compiler/compile.rkt index 40e2a15..c382f58 100644 --- a/fraud/compile.rkt +++ b/fraud/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; ClosedExpr -> Asm (define (compile e) diff --git a/fraud/correct.rkt b/fraud/correct.rkt index d286ba1..1a7846d 100644 --- a/fraud/correct.rkt +++ b/fraud/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/fraud/correctness.rkt b/fraud/correctness.rkt deleted file mode 100644 index 2f05ab7..0000000 --- a/fraud/correctness.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "interp.rkt" "compile.rkt" "types.rkt" a86 rackunit) - -(define (check-compiler e) - (check-eqv? (match (asm-interp (compile e)) - ['err 'err] - [b (bits->value b)]) - (interp e) - e)) diff --git a/fraud/exec-io.rkt b/fraud/exec-io.rkt deleted file mode 100644 index d385fc4..0000000 --- a/fraud/exec-io.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile e) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/fraud/exec.rkt b/fraud/exec.rkt deleted file mode 100644 index 4ad3df2..0000000 --- a/fraud/exec.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Expr -> Answer -(define (exec e) - (run (compile e))) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (run/io (compile e) in)) - diff --git a/fraud/executor/decode.rkt b/fraud/executor/decode.rkt new file mode 100644 index 0000000..89f3464 --- /dev/null +++ b/fraud/executor/decode.rkt @@ -0,0 +1,22 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [else (error "invalid bits")])) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/fraud/executor/exec.rkt b/fraud/executor/exec.rkt new file mode 100644 index 0000000..f6fccb2 --- /dev/null +++ b/fraud/executor/exec.rkt @@ -0,0 +1,54 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") + +(struct exec-state (program) #:transparent) + +(define (exec/state prog) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)))) + +(define (exec-call st) + (match-define (exec-state program) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/con/run-stdin.rkt b/fraud/executor/run-stdin.rkt similarity index 74% rename from con/run-stdin.rkt rename to fraud/executor/run-stdin.rkt index 16cf99e..ac60d60 100644 --- a/con/run-stdin.rkt +++ b/fraud/executor/run-stdin.rkt @@ -1,12 +1,13 @@ #lang racket (provide main) -(require "parse.rkt") -(require "compile.rkt") +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") (require "run.rkt") ;; -> Void ;; Compile contents of stdin and use asm-interp to run (define (main) (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) diff --git a/fraud/executor/run.rkt b/fraud/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/fraud/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/fraud/interp-lexical.rkt b/fraud/interp-lexical.rkt deleted file mode 100644 index 0d12198..0000000 --- a/fraud/interp-lexical.rkt +++ /dev/null @@ -1,42 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "ast.rkt" "translate.rkt" "interp-prim.rkt") - -;; type VEnv = (Listof Value) - -;; Expr -> Answer -(define (interp e) - (interp-env (translate e) '())) - -;; IExpr VEnv -> Answer -(define (interp-env e r) - (match e - [(Lit d) d] - [(Eof) eof] - [(Var a) (list-ref r a)] - [(Prim0 p) (interp-prim0 p)] - [(Prim1 p e) - (match (interp-env e r) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v1 (match (interp-env e2 r) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(If p e1 e2) - (match (interp-env p r) - ['err 'err] - [v - (if v - (interp-env e1 r) - (interp-env e2 r))])] - [(Begin e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v (interp-env e2 r)])] - [(Let '_ e1 e2) - (match (interp-env e1 r) - ['err 'err] - [v (interp-env e2 (cons v r))])])) diff --git a/fraud/env.rkt b/fraud/interpreter/env.rkt similarity index 100% rename from fraud/env.rkt rename to fraud/interpreter/env.rkt diff --git a/fraud/interp-io.rkt b/fraud/interpreter/interp-io.rkt similarity index 100% rename from fraud/interp-io.rkt rename to fraud/interpreter/interp-io.rkt diff --git a/fraud/interp-prim.rkt b/fraud/interpreter/interp-prim.rkt similarity index 100% rename from fraud/interp-prim.rkt rename to fraud/interpreter/interp-prim.rkt diff --git a/fraud/interp-stdin.rkt b/fraud/interpreter/interp-stdin.rkt similarity index 87% rename from fraud/interp-stdin.rkt rename to fraud/interpreter/interp-stdin.rkt index 0a8c3e6..35ce332 100644 --- a/fraud/interp-stdin.rkt +++ b/fraud/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/fraud/interp.rkt b/fraud/interpreter/interp.rkt similarity index 97% rename from fraud/interp.rkt rename to fraud/interpreter/interp.rkt index 959c1a0..0f2e86d 100644 --- a/fraud/interp.rkt +++ b/fraud/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/fraud/main.c b/fraud/main.c deleted file mode 100644 index 5f17cbd..0000000 --- a/fraud/main.c +++ /dev/null @@ -1,36 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - - val_t result; - - result = entry(); - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - return 0; -} diff --git a/fraud/main.rkt b/fraud/main.rkt index 50cf56e..f9851a3 100644 --- a/fraud/main.rkt +++ b/fraud/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/fraud/run-stdin.rkt b/fraud/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/fraud/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/fraud/run.rkt b/fraud/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/fraud/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/fraud/runtime.h b/fraud/runtime.h deleted file mode 100644 index 0a066ad..0000000 --- a/fraud/runtime.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); -#endif /* RUNTIME_H */ diff --git a/fraud/runtime/Makefile b/fraud/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/fraud/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/fraud/runtime/error.c b/fraud/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/fraud/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/fraud/io.c b/fraud/runtime/io.c similarity index 74% rename from fraud/io.c rename to fraud/runtime/io.c index 8a417c9..139dccb 100644 --- a/fraud/io.c +++ b/fraud/runtime/io.c @@ -6,20 +6,20 @@ val_t read_byte(void) { - char c = getc(in); + char c = getc(stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + char c = getc(stdin); + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + putc((char) val_unwrap_int(c), stdout); return val_wrap_void(); } diff --git a/fraud/runtime/main.c b/fraud/runtime/main.c new file mode 100644 index 0000000..bac0f02 --- /dev/null +++ b/fraud/runtime/main.c @@ -0,0 +1,16 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +int main(int argc, char** argv) +{ + val_t result = entry(); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + return 0; +} diff --git a/fraud/print.c b/fraud/runtime/print.c similarity index 100% rename from fraud/print.c rename to fraud/runtime/print.c diff --git a/fraud/print.h b/fraud/runtime/print.h similarity index 100% rename from fraud/print.h rename to fraud/runtime/print.h diff --git a/fraud/runtime/runtime.h b/fraud/runtime/runtime.h new file mode 100644 index 0000000..fb6a288 --- /dev/null +++ b/fraud/runtime/runtime.h @@ -0,0 +1,14 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +val_t entry(); + +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/fraud/types.h b/fraud/runtime/types.h similarity index 100% rename from fraud/types.h rename to fraud/runtime/types.h diff --git a/fraud/types.rkt b/fraud/runtime/types.rkt similarity index 62% rename from fraud/types.rkt rename to fraud/runtime/types.rkt index 827e0f1..7a5f023 100644 --- a/fraud/types.rkt +++ b/fraud/runtime/types.rkt @@ -7,18 +7,6 @@ (define type-char #b01) (define mask-char #b11) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [else (error "invalid bits")])) - ;; Value -> Integer (define (value->bits v) diff --git a/fraud/values.c b/fraud/runtime/values.c similarity index 100% rename from fraud/values.c rename to fraud/runtime/values.c diff --git a/fraud/values.h b/fraud/runtime/values.h similarity index 100% rename from fraud/values.h rename to fraud/runtime/values.h diff --git a/fraud/semantics.rkt b/fraud/semantics.rkt deleted file mode 100644 index 47abe97..0000000 --- a/fraud/semantics.rkt +++ /dev/null @@ -1,297 +0,0 @@ -#lang racket -(provide F F-concrete F-pre 𝑭 𝑭-𝒆𝒏𝒗 lookup ext) -(require redex/reduction-semantics - "../extort/semantics.rkt") - -; for use in presentations (informally noting x can't be let, etc.) -(define-extended-language F-pre E-concrete - (e ::= .... x (let ((x e)) e) (p e)) - (p ::= add1 sub1 zero?) - (x ::= variable)) - -;; the real grammar language -(define-extended-language F-concrete F-pre - (x ::= variable-not-otherwise-mentioned) - (r ::= ((x v) ...))) - -(define-extended-language F E - (x ::= variable) - (r ::= ((x v) ...)) - (e ::= .... (Var x) (Let x e e))) - -(module+ test - (test-equal (redex-match? F-concrete e (term x)) #t) - (test-equal (redex-match? F-concrete e (term let)) #f) - (test-equal (redex-match? F-concrete e (term (let ((x 1)) x))) #t) - (test-equal (redex-match? F-concrete e (term (let ((let 1)) 3))) #f)) - -(module+ test - (test-equal (redex-match? F-pre e (term x)) #t) - (test-equal (redex-match? F-pre e (term let)) #t) - (test-equal (redex-match? F-pre e (term (let ((x 1)) x))) #t) - (test-equal (redex-match? F-pre e (term (let ((let 1)) 3))) #t)) - -(module+ test - (test-equal (redex-match? F e (term (Var x))) #t) - (test-equal (redex-match? F e (term (Var let))) #t) - (test-equal (redex-match? F e (term (Let x (Int 1) (Var x)))) #t) - (test-equal (redex-match? F e (term (Let let (Int 1) (Int 3)))) #t)) - -(define-judgment-form F - #:contract (𝑭 e a) - #:mode (𝑭 I O) - [(𝑭-𝒆𝒏𝒗 e () a) - ---------- "mt-env" - (𝑭 e a)]) - -(define-judgment-form F - #:contract (𝑭-𝒆𝒏𝒗 e r a) - #:mode (𝑭-𝒆𝒏𝒗 I I O) - - ;; Value - [----------- "int-lit" - (𝑭-𝒆𝒏𝒗 (Int i) r i)] - [----------- "bool-lit" - (𝑭-𝒆𝒏𝒗 (Bool b) r b)] - - ;; If - [(𝑭-𝒆𝒏𝒗 e_0 r v_0) (side-condition (is-true v_0)) (𝑭-𝒆𝒏𝒗 e_1 r a) - -------- "if-true" - (𝑭-𝒆𝒏𝒗 (If e_0 e_1 e_2) r a)] - - [(𝑭-𝒆𝒏𝒗 e_0 r v_0) (side-condition (is-false v_0)) (𝑭-𝒆𝒏𝒗 e_2 r a) - -------- "if-false" - (𝑭-𝒆𝒏𝒗 (If e_0 e_1 e_2) r a)] - - [(𝑭-𝒆𝒏𝒗 e_0 r err) - -------- "if-err" - (𝑭-𝒆𝒏𝒗 (If e_0 e_1 e_2) r err)] - - ;; Let and variable - [(where a (lookup r x)) - ----------- "var" - (𝑭-𝒆𝒏𝒗 (Var x) r a)] - - [(𝑭-𝒆𝒏𝒗 e_0 r v_0) (𝑭-𝒆𝒏𝒗 e_1 (ext r x v_0) a) - ----- "let" - (𝑭-𝒆𝒏𝒗 (Let x e_0 e_1) r a)] - - [(𝑭-𝒆𝒏𝒗 e_0 r err) - ----------- "let-err" - (𝑭-𝒆𝒏𝒗 (Let x e_0 e_1) r err)] - - ;; Primitive application - [(𝑭-𝒆𝒏𝒗 e_0 r a_0) - ----------- "prim" - (𝑭-𝒆𝒏𝒗 (Prim1 p1 e_0) r (𝑭-𝒑𝒓𝒊𝒎 p1 a_0))]) - -(module+ test - (test-judgment-holds (𝑭 (Int 7) 7)) - (test-judgment-holds (𝑭 (Prim1 'add1 (Int 7)) 8)) - - (test-judgment-holds (𝑭 (Prim1 'add1 (Bool #f)) err)) - - (test-judgment-holds (𝑭 (Let x (Int 7) (Int 8)) 8)) - (test-judgment-holds (𝑭 (Let x (Int 7) (Var x)) 7)) - (test-judgment-holds (𝑭 (Let x (Int 7) (Prim1 'add1 (Var x))) 8)) - (test-judgment-holds (𝑭 (Prim1 'sub1 (Let x (Int 7) (Prim1 'add1 (Var x)))) 7)) - (test-judgment-holds (𝑭 (Prim1 'sub1 (Let x (Int 7) - (Let y (Var x) - (Prim1 'add1 (Var x))))) - 7)) - (test-judgment-holds (𝑭 (Prim1 'sub1 (Let x (Int 7) - (Let x (Int 8) - (Prim1 'add1 (Var x))))) - 8))) - -;; replace any free variables with 0 -(define-metafunction F - F-close-with-zero : e (x ...) -> e - [(F-close-with-zero (Var x) (x_0 ... x x_1 ...)) (Var x)] - [(F-close-with-zero (Var x) any) (Int 0)] - [(F-close-with-zero (Int i) any) (Int i)] - [(F-close-with-zero (Bool b) any) (Bool b)] - [(F-close-with-zero (If e_1 e_2 e_3) any_r) - (If (F-close-with-zero e_1 any_r) - (F-close-with-zero e_2 any_r) - (F-close-with-zero e_3 any_r))] - [(F-close-with-zero (Prim1 p1 e_1) any_r) - (Prim1 p1 (close-with-zero e_1 any_r))] - #;[(F-close-with-zero (Prim2 p2 e_1 e_2) any_r) - (Prim2 p2 - (close-with-zero e_1 any_r) - (close-with-zero e_2 any_r))] - [(F-close-with-zero (Let x e_1 e_2) (x_0 ...)) - (Let x (close-with-zero e_1 (x_0 ...)) - (close-with-zero e_2 (x x_0 ...)))]) - - -(module+ test - (require rackunit) - ;; Check that the semantics is total function on closed expressions - (redex-check F e - (redex-let F ([e_0 (term (F-close-with-zero e ()))]) - (check-true (redex-match? F (a_0) (judgment-holds (𝑭 e_0 a) a)) (format "~a" (term e)))) - #:print? #f)) - - - -;;;;;;; - - -(provide G G-concrete 𝑮 𝑮-𝒆𝒏𝒗 𝑭-𝒑𝒓𝒊𝒎) - -(define-extended-language G-concrete F-concrete - (e ::= x i b (if e e e) (let ((x e)) e) (p1 e) (p2 e e)) - (p2 ::= + - < =) - (p1 ::= add1 sub1 zero?) - (p ::= p1 p2)) - -(define-extended-language G F - (e ::= .... (Prim2 p2 e e)) - (p2 ::= '+ '- '< '=) - (p ::= p1 p2)) - -(define-judgment-form G - #:contract (𝑮 e a) - #:mode (𝑮 I O) - [(𝑮-𝒆𝒏𝒗 e () a) - ---------- - (𝑮 e a)]) - -(define-judgment-form G - #:contract (𝑮-𝒆𝒏𝒗 e r a) - #:mode (𝑮-𝒆𝒏𝒗 I I O) - - ;; Value - [----------- "int-lit" - (𝑮-𝒆𝒏𝒗 (Int i) r i)] - [----------- "bool-lit" - (𝑮-𝒆𝒏𝒗 (Bool b) r b)] - - ;; If - [(𝑮-𝒆𝒏𝒗 e_0 r v_0) (side-condition (is-true v_0)) (𝑮-𝒆𝒏𝒗 e_1 r a) - -------- "if-true" - (𝑮-𝒆𝒏𝒗 (If e_0 e_1 e_2) r a)] - - [(𝑮-𝒆𝒏𝒗 e_0 r v_0) (side-condition (is-false v_0)) (𝑮-𝒆𝒏𝒗 e_2 r a) - -------- "if-false" - (𝑮-𝒆𝒏𝒗 (If e_0 e_1 e_2) r a)] - - [(𝑮-𝒆𝒏𝒗 e_0 r err) - -------- "if-err" - (𝑮-𝒆𝒏𝒗 (If e_0 e_1 e_2) r err)] - - ;; Let and variable - [(where a (lookup r x)) - ----------- "var" - (𝑮-𝒆𝒏𝒗 (Var x) r a)] - - [(𝑮-𝒆𝒏𝒗 e_0 r v_0) (𝑮-𝒆𝒏𝒗 e_1 (ext r x v_0) a) - ----- "let" - (𝑮-𝒆𝒏𝒗 (Let x e_0 e_1) r a)] - - [(𝑮-𝒆𝒏𝒗 e_0 r err) - ----------- "let-err" - (𝑮-𝒆𝒏𝒗 (Let x e_0 e_1) r err)] - - ;; Primitive application - [(𝑮-𝒆𝒏𝒗 e_0 r a_0) - ----------- "prim1" - (𝑮-𝒆𝒏𝒗 (Prim1 p1 e_0) r (𝑭-𝒑𝒓𝒊𝒎 p1 a_0))] - - [(𝑮-𝒆𝒏𝒗 e_0 r a_0) - (𝑮-𝒆𝒏𝒗 e_1 r a_1) - ----------- "prim2" - (𝑮-𝒆𝒏𝒗 (Prim2 p2 e_0 e_1) r (𝑭-𝒑𝒓𝒊𝒎 p2 a_0 a_1))]) - -(define-metafunction G - 𝑭-𝒑𝒓𝒊𝒎 : p a ... -> a - [(𝑭-𝒑𝒓𝒊𝒎 p v ... err _ ...) err] - [(𝑭-𝒑𝒓𝒊𝒎 'add1 i_0) ,(+ (term i_0) (term 1))] - [(𝑭-𝒑𝒓𝒊𝒎 'sub1 i_0) ,(- (term i_0) (term 1))] - [(𝑭-𝒑𝒓𝒊𝒎 'zero? 0) #t] - [(𝑭-𝒑𝒓𝒊𝒎 'zero? i) #f] - [(𝑭-𝒑𝒓𝒊𝒎 '+ i_0 i_1) ,(+ (term i_0) (term i_1))] - [(𝑭-𝒑𝒓𝒊𝒎 '- i_0 i_1) ,(- (term i_0) (term i_1))] - [(𝑭-𝒑𝒓𝒊𝒎 '< i_0 i_1) ,(< (term i_0) (term i_1))] - [(𝑭-𝒑𝒓𝒊𝒎 '= i_0 i_1) ,(< (term i_0) (term i_1))] - [(𝑭-𝒑𝒓𝒊𝒎 _ ...) err]) - -(define-metafunction G - ext : r x v -> r - [(ext ((x_0 v_0) ...) x v) - ((x v) (x_0 v_0) ...)]) - -(define-metafunction G - lookup : r x -> a - [(lookup ((x v) (x_1 v_1) ...) x) v] - [(lookup ((x_0 v_0) (x_1 v_1) ...) x) - (lookup ((x_1 v_1) ...) x)]) - -(define-metafunction G - is-true : v -> boolean - [(is-true #f) #f] - [(is-true v) #t]) - -(define-metafunction G - is-false : v -> boolean - [(is-false #f) #t] - [(is-false v) #f]) - -(module+ test - (test-judgment-holds (𝑮 (Int 7) 7)) - (test-judgment-holds (𝑮 (Prim1 'add1 (Int 7)) 8)) - - (test-judgment-holds (𝑮 (Prim1 'add1 (Bool #f)) err)) - - (test-judgment-holds (𝑮 (Let x (Int 7) (Int 8)) 8)) - (test-judgment-holds (𝑮 (Let x (Int 7) (Var x)) 7)) - (test-judgment-holds (𝑮 (Let x (Int 7) (Prim1 'add1 (Var x))) 8)) - (test-judgment-holds (𝑮 (Prim1 'sub1 (Let x (Int 7) (Prim1 'add1 (Var x)))) 7)) - (test-judgment-holds (𝑮 (Prim1 'sub1 (Let x (Int 7) - (Let y (Var x) - (Prim1 'add1 (Var x))))) - 7)) - (test-judgment-holds (𝑮 (Prim1 'sub1 (Let x (Int 7) - (Let x (Int 8) - (Prim1 'add1 (Var x))))) - 8)) - - (test-judgment-holds (𝑮 (Prim2 '+ (Int 1) (Int 2)) 3)) - (test-judgment-holds (𝑮 (Prim2 '- (Int 1) (Int 2)) -1)) - (test-judgment-holds (𝑮 (Prim1 'add1 (Bool #f)) err)) - (test-judgment-holds (𝑮 (If (Prim1 'add1 (Bool #f)) (Int 1) (Int 2)) err)) - (test-judgment-holds (𝑮 (Prim2 '+ (Int 1) (Prim1 'add1 (Bool #f))) err)) - (test-judgment-holds (𝑮 (Prim2 '+ (Int 1) (Bool #f)) err)) - (test-judgment-holds (𝑮 (Prim2 '- (Int 1) (Bool #f)) err)) - (test-judgment-holds (𝑮 (Prim2 '- (Prim1 'add1 (Bool #f)) (Bool #f)) err))) - -;; replace any free variables with 0 -(define-metafunction G - close-with-zero : e (x ...) -> e - [(close-with-zero (Var x) (x_0 ... x x_1 ...)) (Var x)] - [(close-with-zero (Var x) any) (Int 0)] - [(close-with-zero (Int i) any) (Int i)] - [(close-with-zero (Bool b) any) (Bool b)] - [(close-with-zero (If e_1 e_2 e_3) any_r) - (If (close-with-zero e_1 any_r) - (close-with-zero e_2 any_r) - (close-with-zero e_3 any_r))] - [(close-with-zero (Prim1 p1 e_1) any_r) - (Prim1 p1 (close-with-zero e_1 any_r))] - [(close-with-zero (Prim2 p2 e_1 e_2) any_r) - (Prim2 p2 - (close-with-zero e_1 any_r) - (close-with-zero e_2 any_r))] - [(close-with-zero (Let x e_1 e_2) (x_0 ...)) - (Let x (close-with-zero e_1 (x_0 ...)) - (close-with-zero e_2 (x x_0 ...)))]) - -(module+ test - (require rackunit) - ;; Check that the semantics is total function -- for closed expressions - (redex-check G e - (redex-let G ([e_0 (term (close-with-zero e ()))]) - (check-true (redex-match? G (a_0) (judgment-holds (𝑮 e_0 a) a)))) - #:print? #f)) diff --git a/fraud/ast.rkt b/fraud/syntax/ast.rkt similarity index 100% rename from fraud/ast.rkt rename to fraud/syntax/ast.rkt diff --git a/fraud/parse.rkt b/fraud/syntax/parse.rkt similarity index 100% rename from fraud/parse.rkt rename to fraud/syntax/parse.rkt diff --git a/fraud/random.rkt b/fraud/syntax/random.rkt similarity index 100% rename from fraud/random.rkt rename to fraud/syntax/random.rkt diff --git a/fraud/translate.rkt b/fraud/syntax/translate.rkt similarity index 100% rename from fraud/translate.rkt rename to fraud/syntax/translate.rkt diff --git a/fraud/test/compile.rkt b/fraud/test/compile.rkt deleted file mode 100644 index 3d22968..0000000 --- a/fraud/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ (e) (exec (parse-closed e)))) -(test/io (λ (i e) (exec/io (parse-closed e) i))) - diff --git a/fraud/test/test-runner.rkt b/fraud/test/define-tests.rkt similarity index 100% rename from fraud/test/test-runner.rkt rename to fraud/test/define-tests.rkt diff --git a/fraud/test/interp-lexical.rkt b/fraud/test/interp-lexical.rkt deleted file mode 100644 index cc6eda1..0000000 --- a/fraud/test/interp-lexical.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(require rackunit) -(require "../interp-lexical.rkt" "../parse.rkt") -(define (run p) - (interp (parse p))) -(check-equal? (run 5) 5) -(check-equal? (run '(let ((x 0)) x)) 0) -(check-equal? (run '(let ((x 0)) (let ((y 1)) x))) 0) -(check-equal? (run '(let ((x 0)) (let ((y 1)) y))) 1) -(check-equal? (run '(let ((x 0)) (let ((y x)) y))) 0) diff --git a/fraud/test/interp.rkt b/fraud/test/interp.rkt deleted file mode 100644 index 0a2dab1..0000000 --- a/fraud/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ (e) (interp (parse-closed e)))) -(test/io (λ (in e) (interp/io (parse-closed e) in))) - diff --git a/fraud/test/run-compile-tests.rkt b/fraud/test/run-compile-tests.rkt new file mode 100644 index 0000000..9cc5971 --- /dev/null +++ b/fraud/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ (e) (run (compile (parse-closed e))))) +(test/io (λ (i e) (run/io (compile (parse-closed e)) i))) + diff --git a/fraud/test/run-interp-tests.rkt b/fraud/test/run-interp-tests.rkt new file mode 100644 index 0000000..32de7cc --- /dev/null +++ b/fraud/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ (e) (interp (parse-closed e)))) +(test/io (λ (in e) (interp/io (parse-closed e) in))) + diff --git a/fraud/test/parse.rkt b/fraud/test/run-parse-tests.rkt similarity index 95% rename from fraud/test/parse.rkt rename to fraud/test/run-parse-tests.rkt index 9573d4f..5b11a10 100644 --- a/fraud/test/parse.rkt +++ b/fraud/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/fraud/test/test-progs.rkt b/fraud/test/test-progs.rkt deleted file mode 100644 index b765151..0000000 --- a/fraud/test/test-progs.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang racket -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit "../../test-programs/get-progs.rkt") -(for-each test-prog (get-progs "fraud")) diff --git a/fraud/test/translate.rkt b/fraud/test/translate.rkt index f83844b..b29bb3f 100644 --- a/fraud/test/translate.rkt +++ b/fraud/test/translate.rkt @@ -1,7 +1,7 @@ #lang racket -(require "../translate.rkt") -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/translate.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (check-equal? (translate (parse '(let ((x 0)) x))) (Let '_ (Lit 0) (Var 0))) diff --git a/hoax/Makefile b/hoax/Makefile index a835720..d88e2b9 100644 --- a/hoax/Makefile +++ b/hoax/Makefile @@ -12,12 +12,7 @@ objs = \ values.o \ io.o -default: submit.zip - -submit.zip: - zip submit.zip -r * \ - -x \*.[os] -x \*~ -x \*zip \ - -x \*Zone.Identifier -x \*\*compiled\*\* +default: runtime.o runtime.o: $(objs) ld -r $(objs) -o runtime.o diff --git a/hoax/build-runtime.rkt b/hoax/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/hoax/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/iniquity/assert.rkt b/hoax/compiler/assert.rkt similarity index 97% rename from iniquity/assert.rkt rename to hoax/compiler/assert.rkt index cfc110a..380fc8d 100644 --- a/iniquity/assert.rkt +++ b/hoax/compiler/assert.rkt @@ -3,7 +3,7 @@ assert-box assert-cons assert-natural assert-vector assert-string) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") (define (assert-type mask type) (λ (r) diff --git a/iniquity/compile-ops.rkt b/hoax/compiler/compile-ops.rkt similarity index 97% rename from iniquity/compile-ops.rkt rename to hoax/compiler/compile-ops.rkt index 1bb76cb..1a58a86 100644 --- a/iniquity/compile-ops.rkt +++ b/hoax/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) @@ -222,8 +222,8 @@ (Mov r9 (Mem r8 (- type-vect))) (Cmp r10 r9) (Jge 'err) - (Sar r10 1) ; convert to byte offset - (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) (Mov rax (value->bits (void))))])) (define (type-pred mask type) diff --git a/hoax/compile-stdin.rkt b/hoax/compiler/compile-stdin.rkt similarity index 88% rename from hoax/compile-stdin.rkt rename to hoax/compiler/compile-stdin.rkt index b8e500c..dce355a 100644 --- a/hoax/compile-stdin.rkt +++ b/hoax/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/hoax/compile.rkt b/hoax/compiler/compile.rkt similarity index 98% rename from hoax/compile.rkt rename to hoax/compiler/compile.rkt index 6b1b86f..40e2570 100644 --- a/hoax/compile.rkt +++ b/hoax/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; ClosedExpr -> Asm (define (compile e) diff --git a/hoax/correct.rkt b/hoax/correct.rkt index d286ba1..1a7846d 100644 --- a/hoax/correct.rkt +++ b/hoax/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/hoax/exec-io.rkt b/hoax/exec-io.rkt deleted file mode 100644 index d385fc4..0000000 --- a/hoax/exec-io.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile e) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/hoax/exec.rkt b/hoax/exec.rkt deleted file mode 100644 index 4ad3df2..0000000 --- a/hoax/exec.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Expr -> Answer -(define (exec e) - (run (compile e))) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (run/io (compile e) in)) - diff --git a/knock/types.rkt b/hoax/executor/decode.rkt similarity index 50% rename from knock/types.rkt rename to hoax/executor/decode.rkt index c0c1d70..6ee214f 100644 --- a/knock/types.rkt +++ b/hoax/executor/decode.rkt @@ -1,20 +1,9 @@ #lang racket -(provide (all-defined-out)) + +(require "../runtime/types.rkt") (require ffi/unsafe) -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define int-shift (+ 1 imm-shift)) -(define mask-int #b1111) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define type-char #b01000) -(define mask-char #b11111) +(provide (all-defined-out)) ;; Integer -> Value (define (bits->value b) @@ -45,44 +34,12 @@ (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] [else (error "invalid bits")])) -;; Value -> Integer -;; v must be an immediate -(define (value->bits v) - (cond [(eq? v #t) #b00011000] - [(eq? v #f) #b00111000] - [(eq? v eof) #b01011000] - [(eq? v (void)) #b01111000] - [(eq? v '()) #b10011000] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [else (error "not an immediate value" v)])) - -(define (int-bits? v) - (= type-int (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (cons-bits? v) - (= type-cons (bitwise-and v imm-mask))) - -(define (box-bits? v) - (= type-box (bitwise-and v imm-mask))) - -(define (vect-bits? v) - (= type-vect (bitwise-and v imm-mask))) - -(define (str-bits? v) - (= type-str (bitwise-and v imm-mask))) - (define (mem-ref i) (ptr-ref (cast i _int64 _pointer) _int64)) (define (mem-ref32 i) (ptr-ref (cast i _int64 _pointer) _int32)) +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/hoax/executor/exec.rkt b/hoax/executor/exec.rkt new file mode 100644 index 0000000..cd5745e --- /dev/null +++ b/hoax/executor/exec.rkt @@ -0,0 +1,55 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (exec/state prog) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/dodger/run-stdin.rkt b/hoax/executor/run-stdin.rkt similarity index 74% rename from dodger/run-stdin.rkt rename to hoax/executor/run-stdin.rkt index 16cf99e..ac60d60 100644 --- a/dodger/run-stdin.rkt +++ b/hoax/executor/run-stdin.rkt @@ -1,12 +1,13 @@ #lang racket (provide main) -(require "parse.rkt") -(require "compile.rkt") +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") (require "run.rkt") ;; -> Void ;; Compile contents of stdin and use asm-interp to run (define (main) (read-line) ; ignore #lang racket line + (run (compile (parse (read))))) diff --git a/hoax/executor/run.rkt b/hoax/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/hoax/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/hoax/env.rkt b/hoax/interpreter/env.rkt similarity index 100% rename from hoax/env.rkt rename to hoax/interpreter/env.rkt diff --git a/hoax/heap-bits.rkt b/hoax/interpreter/heap-bits.rkt similarity index 98% rename from hoax/heap-bits.rkt rename to hoax/interpreter/heap-bits.rkt index 961044e..7d8d4c8 100644 --- a/hoax/heap-bits.rkt +++ b/hoax/interpreter/heap-bits.rkt @@ -1,5 +1,5 @@ #lang racket -(require "types.rkt") +(require "../runtime/types.rkt") (provide (struct-out heap) heap-ref heap-set! alloc-box alloc-cons alloc-vect alloc-str) diff --git a/hoax/heap.rkt b/hoax/interpreter/heap.rkt similarity index 100% rename from hoax/heap.rkt rename to hoax/interpreter/heap.rkt diff --git a/hoax/interp-heap-bits.rkt b/hoax/interpreter/interp-heap-bits.rkt similarity index 97% rename from hoax/interp-heap-bits.rkt rename to hoax/interpreter/interp-heap-bits.rkt index 60991ae..63e46d2 100644 --- a/hoax/interp-heap-bits.rkt +++ b/hoax/interpreter/interp-heap-bits.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "env.rkt") (require "heap-bits.rkt") (require "interp-prims-heap-bits.rkt") diff --git a/hoax/interp-heap.rkt b/hoax/interpreter/interp-heap.rkt similarity index 98% rename from hoax/interp-heap.rkt rename to hoax/interpreter/interp-heap.rkt index 9244824..4e3e85c 100644 --- a/hoax/interp-heap.rkt +++ b/hoax/interpreter/interp-heap.rkt @@ -3,7 +3,7 @@ (require "env.rkt") (require "unload.rkt") (require "interp-prims-heap.rkt") -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "heap.rkt") ;; type Answer* = diff --git a/hoax/interp-io.rkt b/hoax/interpreter/interp-io.rkt similarity index 100% rename from hoax/interp-io.rkt rename to hoax/interpreter/interp-io.rkt diff --git a/hoax/interp-prim.rkt b/hoax/interpreter/interp-prim.rkt similarity index 100% rename from hoax/interp-prim.rkt rename to hoax/interpreter/interp-prim.rkt diff --git a/hoax/interp-prims-heap-bits.rkt b/hoax/interpreter/interp-prims-heap-bits.rkt similarity index 99% rename from hoax/interp-prims-heap-bits.rkt rename to hoax/interpreter/interp-prims-heap-bits.rkt index c8dab81..0e27e98 100644 --- a/hoax/interp-prims-heap-bits.rkt +++ b/hoax/interpreter/interp-prims-heap-bits.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp-prim0 interp-prim1 interp-prim2 interp-prim3) (require "heap-bits.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") ;; Op0 Heap -> Answer* (define (interp-prim0 op h) diff --git a/hoax/interp-prims-heap.rkt b/hoax/interpreter/interp-prims-heap.rkt similarity index 100% rename from hoax/interp-prims-heap.rkt rename to hoax/interpreter/interp-prims-heap.rkt diff --git a/hoax/interp-stdin.rkt b/hoax/interpreter/interp-stdin.rkt similarity index 87% rename from hoax/interp-stdin.rkt rename to hoax/interpreter/interp-stdin.rkt index 0a8c3e6..35ce332 100644 --- a/hoax/interp-stdin.rkt +++ b/hoax/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/hoax/interp.rkt b/hoax/interpreter/interp.rkt similarity index 97% rename from hoax/interp.rkt rename to hoax/interpreter/interp.rkt index b99d935..3d72526 100644 --- a/hoax/interp.rkt +++ b/hoax/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/hoax/unload-bits.rkt b/hoax/interpreter/unload-bits.rkt similarity index 93% rename from hoax/unload-bits.rkt rename to hoax/interpreter/unload-bits.rkt index eb70337..a5acd3c 100644 --- a/hoax/unload-bits.rkt +++ b/hoax/interpreter/unload-bits.rkt @@ -1,7 +1,8 @@ #lang racket (provide unload unload-value) (require "heap-bits.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") +(require "../executor/decode.rkt") ;; Heap Answer* -> Answer (define (unload h a) diff --git a/hoax/unload.rkt b/hoax/interpreter/unload.rkt similarity index 100% rename from hoax/unload.rkt rename to hoax/interpreter/unload.rkt diff --git a/hoax/main.c b/hoax/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/hoax/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/hoax/main.rkt b/hoax/main.rkt index 50cf56e..f9851a3 100644 --- a/hoax/main.rkt +++ b/hoax/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/hoax/run-stdin.rkt b/hoax/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/hoax/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/hoax/run.rkt b/hoax/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/hoax/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/hoax/runtime/Makefile b/hoax/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/hoax/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/hoax/runtime/error.c b/hoax/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/hoax/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/extort/io.c b/hoax/runtime/io.c similarity index 74% rename from extort/io.c rename to hoax/runtime/io.c index 8a417c9..139dccb 100644 --- a/extort/io.c +++ b/hoax/runtime/io.c @@ -6,20 +6,20 @@ val_t read_byte(void) { - char c = getc(in); + char c = getc(stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + char c = getc(stdin); + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + putc((char) val_unwrap_int(c), stdout); return val_wrap_void(); } diff --git a/hoax/runtime/main.c b/hoax/runtime/main.c new file mode 100644 index 0000000..6fa3ab3 --- /dev/null +++ b/hoax/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/hoax/print.c b/hoax/runtime/print.c similarity index 100% rename from hoax/print.c rename to hoax/runtime/print.c diff --git a/hoax/print.h b/hoax/runtime/print.h similarity index 100% rename from hoax/print.h rename to hoax/runtime/print.h diff --git a/hoax/runtime/runtime.h b/hoax/runtime/runtime.h new file mode 100644 index 0000000..ec422c7 --- /dev/null +++ b/hoax/runtime/runtime.h @@ -0,0 +1,14 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +val_t entry(val_t *heap); + +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/hoax/types.h b/hoax/runtime/types.h similarity index 100% rename from hoax/types.h rename to hoax/runtime/types.h diff --git a/hustle/types.rkt b/hoax/runtime/types.rkt similarity index 60% rename from hustle/types.rkt rename to hoax/runtime/types.rkt index 14e9328..b9198f9 100644 --- a/hustle/types.rkt +++ b/hoax/runtime/types.rkt @@ -1,12 +1,13 @@ #lang racket (provide (all-defined-out)) -(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) (define ptr-mask #b111) (define type-box #b001) (define type-cons #b010) +(define type-vect #b011) +(define type-str #b100) (define int-shift (+ 1 imm-shift)) (define mask-int #b1111) (define char-shift (+ 2 imm-shift)) @@ -14,24 +15,6 @@ (define type-char #b01000) (define mask-char #b11111) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (mem-ref (- b type-box))))] - [(cons-bits? b) - (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) - (bits->value (mem-ref (+ 8 (- b type-cons)))))] - [else (error "invalid bits")])) - ;; Value -> Integer ;; v must be an immediate (define (value->bits v) @@ -61,6 +44,9 @@ (define (box-bits? v) (= type-box (bitwise-and v imm-mask))) -(define (mem-ref i) - (ptr-ref (cast i _int64 _pointer) _int64)) +(define (vect-bits? v) + (= type-vect (bitwise-and v imm-mask))) + +(define (str-bits? v) + (= type-str (bitwise-and v imm-mask))) diff --git a/hoax/values.c b/hoax/runtime/values.c similarity index 100% rename from hoax/values.c rename to hoax/runtime/values.c diff --git a/hoax/values.h b/hoax/runtime/values.h similarity index 100% rename from hoax/values.h rename to hoax/runtime/values.h diff --git a/hoax/ast.rkt b/hoax/syntax/ast.rkt similarity index 100% rename from hoax/ast.rkt rename to hoax/syntax/ast.rkt diff --git a/hoax/parse.rkt b/hoax/syntax/parse.rkt similarity index 100% rename from hoax/parse.rkt rename to hoax/syntax/parse.rkt diff --git a/hoax/test/compile.rkt b/hoax/test/compile.rkt deleted file mode 100644 index 3d22968..0000000 --- a/hoax/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ (e) (exec (parse-closed e)))) -(test/io (λ (i e) (exec/io (parse-closed e) i))) - diff --git a/hoax/test/test-runner.rkt b/hoax/test/define-tests.rkt similarity index 99% rename from hoax/test/test-runner.rkt rename to hoax/test/define-tests.rkt index 3b3f151..39a1402 100644 --- a/hoax/test/test-runner.rkt +++ b/hoax/test/define-tests.rkt @@ -93,7 +93,7 @@ (check-equal? (run '(= (add1 4) 5)) #t) (check-equal? (run '(< 5 5)) #f) (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (check-equal? (run '(< (add1 4) 5)) #f)) (begin ;; Hustle (check-equal? (run '(empty? (cons 1 2))) #f) diff --git a/hoax/test/interp.rkt b/hoax/test/interp.rkt deleted file mode 100644 index 0a2dab1..0000000 --- a/hoax/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ (e) (interp (parse-closed e)))) -(test/io (λ (in e) (interp/io (parse-closed e) in))) - diff --git a/hoax/test/run-compile-tests.rkt b/hoax/test/run-compile-tests.rkt new file mode 100644 index 0000000..9cc5971 --- /dev/null +++ b/hoax/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ (e) (run (compile (parse-closed e))))) +(test/io (λ (i e) (run/io (compile (parse-closed e)) i))) + diff --git a/hoax/test/interp-heap-bits.rkt b/hoax/test/run-interp-heap-bits-tests.rkt similarity index 50% rename from hoax/test/interp-heap-bits.rkt rename to hoax/test/run-interp-heap-bits-tests.rkt index be21e60..115f689 100644 --- a/hoax/test/interp-heap-bits.rkt +++ b/hoax/test/run-interp-heap-bits-tests.rkt @@ -1,8 +1,8 @@ #lang racket -(require "test-runner.rkt") -(require "../parse.rkt") -(require "../interp-heap-bits.rkt") -(require "../interp-io.rkt") +(require "define-tests.rkt") +(require "../syntax/parse.rkt") +(require "../interpreter/interp-heap-bits.rkt") +(require "../interpreter/interp-io.rkt") (test (λ (e) (interp (parse e)))) diff --git a/hustle/test/interp-heap-bits.rkt b/hoax/test/run-interp-heap-tests.rkt similarity index 51% rename from hustle/test/interp-heap-bits.rkt rename to hoax/test/run-interp-heap-tests.rkt index be21e60..252f89e 100644 --- a/hustle/test/interp-heap-bits.rkt +++ b/hoax/test/run-interp-heap-tests.rkt @@ -1,8 +1,8 @@ #lang racket -(require "test-runner.rkt") -(require "../parse.rkt") -(require "../interp-heap-bits.rkt") -(require "../interp-io.rkt") +(require "define-tests.rkt") +(require "../syntax/parse.rkt") +(require "../interpreter/interp-heap.rkt") +(require "../interpreter/interp-io.rkt") (test (λ (e) (interp (parse e)))) diff --git a/hoax/test/run-interp-tests.rkt b/hoax/test/run-interp-tests.rkt new file mode 100644 index 0000000..32de7cc --- /dev/null +++ b/hoax/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ (e) (interp (parse-closed e)))) +(test/io (λ (in e) (interp/io (parse-closed e) in))) + diff --git a/hoax/test/parse.rkt b/hoax/test/run-parse-tests.rkt similarity index 96% rename from hoax/test/parse.rkt rename to hoax/test/run-parse-tests.rkt index 244f4a5..22b6a45 100644 --- a/hoax/test/parse.rkt +++ b/hoax/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/hoax/test/test-progs.rkt b/hoax/test/test-progs.rkt deleted file mode 100644 index 0eca217..0000000 --- a/hoax/test/test-progs.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang racket -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit - "../../test-programs/get-progs.rkt" - "../run.rkt") -(for-each test-prog (get-progs "hoax")) diff --git a/hustle/build-runtime.rkt b/hustle/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/hustle/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/hustle/assert.rkt b/hustle/compiler/assert.rkt similarity index 97% rename from hustle/assert.rkt rename to hustle/compiler/assert.rkt index 4a4d79a..c7b9c05 100644 --- a/hustle/assert.rkt +++ b/hustle/compiler/assert.rkt @@ -2,7 +2,7 @@ (provide assert-integer assert-char assert-byte assert-codepoint assert-box assert-cons) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") (define (assert-type mask type) (λ (r) diff --git a/hustle/compile-ops.rkt b/hustle/compiler/compile-ops.rkt similarity index 98% rename from hustle/compile-ops.rkt rename to hustle/compiler/compile-ops.rkt index a6be158..fcfc4d1 100644 --- a/hustle/compile-ops.rkt +++ b/hustle/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 pad-stack) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) diff --git a/hustle/compile-stdin.rkt b/hustle/compiler/compile-stdin.rkt similarity index 88% rename from hustle/compile-stdin.rkt rename to hustle/compiler/compile-stdin.rkt index b8e500c..dce355a 100644 --- a/hustle/compile-stdin.rkt +++ b/hustle/compiler/compile-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") (require a86/printer) diff --git a/hustle/compile.rkt b/hustle/compiler/compile.rkt similarity index 97% rename from hustle/compile.rkt rename to hustle/compiler/compile.rkt index bdd5add..d452a66 100644 --- a/hustle/compile.rkt +++ b/hustle/compiler/compile.rkt @@ -2,9 +2,9 @@ (provide compile compile-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; ClosedExpr -> Asm (define (compile e) diff --git a/hustle/correct.rkt b/hustle/correct.rkt index d286ba1..1a7846d 100644 --- a/hustle/correct.rkt +++ b/hustle/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/hustle/correctness.rkt b/hustle/correctness.rkt deleted file mode 100644 index b117f26..0000000 --- a/hustle/correctness.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require "interp.rkt" - "compile.rkt" - "types.rkt" - "parse.rkt" - "run.rkt" - rackunit) - - -(define (check-compiler e) - (check-equal? (run (compile (parse e))) - (interp (parse e)) - e)) diff --git a/hustle/exec-io.rkt b/hustle/exec-io.rkt deleted file mode 100644 index d385fc4..0000000 --- a/hustle/exec-io.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile e) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/hustle/exec.rkt b/hustle/exec.rkt deleted file mode 100644 index 4ad3df2..0000000 --- a/hustle/exec.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Expr -> Answer -(define (exec e) - (run (compile e))) - -;; Expr String -> (cons Answer String) -(define (exec/io e in) - (run/io (compile e) in)) - diff --git a/hustle/executor/decode.rkt b/hustle/executor/decode.rkt new file mode 100644 index 0000000..3f1025e --- /dev/null +++ b/hustle/executor/decode.rkt @@ -0,0 +1,31 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (mem-ref (- b type-box))))] + [(cons-bits? b) + (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) + (bits->value (mem-ref (+ 8 (- b type-cons)))))] + [else (error "invalid bits")])) + +(define (mem-ref i) + (ptr-ref (cast i _int64 _pointer) _int64)) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/hustle/executor/exec.rkt b/hustle/executor/exec.rkt new file mode 100644 index 0000000..cd5745e --- /dev/null +++ b/hustle/executor/exec.rkt @@ -0,0 +1,55 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (exec/state prog) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/hustle/executor/run-stdin.rkt b/hustle/executor/run-stdin.rkt new file mode 100644 index 0000000..ac60d60 --- /dev/null +++ b/hustle/executor/run-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + + (run (compile (parse (read))))) + diff --git a/hustle/executor/run.rkt b/hustle/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/hustle/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/hustle/env.rkt b/hustle/interpreter/env.rkt similarity index 100% rename from hustle/env.rkt rename to hustle/interpreter/env.rkt diff --git a/hustle/heap-bits.rkt b/hustle/interpreter/heap-bits.rkt similarity index 95% rename from hustle/heap-bits.rkt rename to hustle/interpreter/heap-bits.rkt index 43cd566..24aa14c 100644 --- a/hustle/heap-bits.rkt +++ b/hustle/interpreter/heap-bits.rkt @@ -1,5 +1,5 @@ #lang racket -(require "types.rkt") +(require "../runtime/types.rkt") (provide (struct-out heap) heap-ref alloc-box alloc-cons) diff --git a/hustle/heap.rkt b/hustle/interpreter/heap.rkt similarity index 100% rename from hustle/heap.rkt rename to hustle/interpreter/heap.rkt diff --git a/hustle/interp-heap-bits.rkt b/hustle/interpreter/interp-heap-bits.rkt similarity index 96% rename from hustle/interp-heap-bits.rkt rename to hustle/interpreter/interp-heap-bits.rkt index 6d2ef99..f399256 100644 --- a/hustle/interp-heap-bits.rkt +++ b/hustle/interpreter/interp-heap-bits.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "env.rkt") (require "heap-bits.rkt") (require "interp-prims-heap-bits.rkt") diff --git a/hustle/interp-heap.rkt b/hustle/interpreter/interp-heap.rkt similarity index 98% rename from hustle/interp-heap.rkt rename to hustle/interpreter/interp-heap.rkt index 9d9c198..e17005e 100644 --- a/hustle/interp-heap.rkt +++ b/hustle/interpreter/interp-heap.rkt @@ -3,7 +3,7 @@ (require "env.rkt") (require "unload.rkt") (require "interp-prims-heap.rkt") -(require "ast.rkt") +(require "../syntax/ast.rkt") ;; type Answer* = ;; | (cons Heap Value*) diff --git a/hustle/interp-io.rkt b/hustle/interpreter/interp-io.rkt similarity index 100% rename from hustle/interp-io.rkt rename to hustle/interpreter/interp-io.rkt diff --git a/hustle/interp-prim.rkt b/hustle/interpreter/interp-prim.rkt similarity index 100% rename from hustle/interp-prim.rkt rename to hustle/interpreter/interp-prim.rkt diff --git a/hustle/interp-prims-heap-bits.rkt b/hustle/interpreter/interp-prims-heap-bits.rkt similarity index 98% rename from hustle/interp-prims-heap-bits.rkt rename to hustle/interpreter/interp-prims-heap-bits.rkt index 393eeac..bfdcdc6 100644 --- a/hustle/interp-prims-heap-bits.rkt +++ b/hustle/interpreter/interp-prims-heap-bits.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp-prim0 interp-prim1 interp-prim2) (require "heap-bits.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") ;; Op0 Heap -> Answer* (define (interp-prim0 op h) diff --git a/hustle/interp-prims-heap.rkt b/hustle/interpreter/interp-prims-heap.rkt similarity index 100% rename from hustle/interp-prims-heap.rkt rename to hustle/interpreter/interp-prims-heap.rkt diff --git a/hustle/interp-stdin.rkt b/hustle/interpreter/interp-stdin.rkt similarity index 87% rename from hustle/interp-stdin.rkt rename to hustle/interpreter/interp-stdin.rkt index 0a8c3e6..35ce332 100644 --- a/hustle/interp-stdin.rkt +++ b/hustle/interpreter/interp-stdin.rkt @@ -1,6 +1,6 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") ;; -> Void diff --git a/hustle/interp.rkt b/hustle/interpreter/interp.rkt similarity index 97% rename from hustle/interp.rkt rename to hustle/interpreter/interp.rkt index e2d305c..a97c98a 100644 --- a/hustle/interp.rkt +++ b/hustle/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/hustle/unload-bits.rkt b/hustle/interpreter/unload-bits.rkt similarity index 88% rename from hustle/unload-bits.rkt rename to hustle/interpreter/unload-bits.rkt index d9b0a73..eef7a02 100644 --- a/hustle/unload-bits.rkt +++ b/hustle/interpreter/unload-bits.rkt @@ -1,7 +1,8 @@ #lang racket (provide unload unload-value) (require "heap-bits.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") +(require "../executor/decode.rkt") ;; Heap Answer* -> Answer (define (unload h a) diff --git a/hustle/unload.rkt b/hustle/interpreter/unload.rkt similarity index 100% rename from hustle/unload.rkt rename to hustle/interpreter/unload.rkt diff --git a/hustle/io.c b/hustle/io.c deleted file mode 100644 index 8a417c9..0000000 --- a/hustle/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/hustle/main.c b/hustle/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/hustle/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/hustle/main.rkt b/hustle/main.rkt index 50cf56e..f9851a3 100644 --- a/hustle/main.rkt +++ b/hustle/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/hustle/run-stdin.rkt b/hustle/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/hustle/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/hustle/run.rkt b/hustle/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/hustle/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/hustle/runtime/Makefile b/hustle/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/hustle/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/hustle/runtime/error.c b/hustle/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/hustle/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/hustle/runtime/io.c b/hustle/runtime/io.c new file mode 100644 index 0000000..139dccb --- /dev/null +++ b/hustle/runtime/io.c @@ -0,0 +1,25 @@ +#include +#include +#include "types.h" +#include "values.h" +#include "runtime.h" + +val_t read_byte(void) +{ + char c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); +} + +val_t peek_byte(void) +{ + char c = getc(stdin); + ungetc(c, stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); + +} + +val_t write_byte(val_t c) +{ + putc((char) val_unwrap_int(c), stdout); + return val_wrap_void(); +} diff --git a/hustle/runtime/main.c b/hustle/runtime/main.c new file mode 100644 index 0000000..6fa3ab3 --- /dev/null +++ b/hustle/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/hustle/print.c b/hustle/runtime/print.c similarity index 100% rename from hustle/print.c rename to hustle/runtime/print.c diff --git a/hustle/print.h b/hustle/runtime/print.h similarity index 100% rename from hustle/print.h rename to hustle/runtime/print.h diff --git a/hustle/runtime/runtime.h b/hustle/runtime/runtime.h new file mode 100644 index 0000000..ec422c7 --- /dev/null +++ b/hustle/runtime/runtime.h @@ -0,0 +1,14 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +val_t entry(val_t *heap); + +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/hustle/types.h b/hustle/runtime/types.h similarity index 100% rename from hustle/types.h rename to hustle/runtime/types.h diff --git a/hustle/runtime/types.rkt b/hustle/runtime/types.rkt new file mode 100644 index 0000000..5569f65 --- /dev/null +++ b/hustle/runtime/types.rkt @@ -0,0 +1,44 @@ +#lang racket +(provide (all-defined-out)) + +(define imm-shift 3) +(define imm-mask #b111) +(define ptr-mask #b111) +(define type-box #b001) +(define type-cons #b010) +(define int-shift (+ 1 imm-shift)) +(define mask-int #b1111) +(define char-shift (+ 2 imm-shift)) +(define type-int #b0000) +(define type-char #b01000) +(define mask-char #b11111) + +;; Value -> Integer +;; v must be an immediate +(define (value->bits v) + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eq? v eof) #b01011000] + [(eq? v (void)) #b01111000] + [(eq? v '()) #b10011000] + [(integer? v) (arithmetic-shift v int-shift)] + [(char? v) + (bitwise-ior type-char + (arithmetic-shift (char->integer v) char-shift))] + [else (error "not an immediate value" v)])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + +(define (char-bits? v) + (= type-char (bitwise-and v mask-char))) + +(define (imm-bits? v) + (zero? (bitwise-and v imm-mask))) + +(define (cons-bits? v) + (= type-cons (bitwise-and v imm-mask))) + +(define (box-bits? v) + (= type-box (bitwise-and v imm-mask))) + diff --git a/hustle/values.c b/hustle/runtime/values.c similarity index 100% rename from hustle/values.c rename to hustle/runtime/values.c diff --git a/hustle/values.h b/hustle/runtime/values.h similarity index 100% rename from hustle/values.h rename to hustle/runtime/values.h diff --git a/hustle/semantics.rkt b/hustle/semantics.rkt deleted file mode 100644 index 7e416ab..0000000 --- a/hustle/semantics.rkt +++ /dev/null @@ -1,351 +0,0 @@ -#lang racket -(provide H Hm H-concrete 𝑯 𝑯′ 𝑯-𝒆𝒏𝒗 𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 𝑯-𝒑𝒓𝒊𝒎 𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 lookup ext convert unload) -(require redex/reduction-semantics - (only-in "../fraud/semantics.rkt" G G-concrete)) - -(define-extended-language H-concrete G-concrete - (p2 ::= .... cons) - (p1 ::= .... box unbox car cdr)) - -(define-extended-language H G - (p2 ::= .... 'cons) - (p1 ::= .... 'box 'unbox 'car 'cdr) - (e ::= .... (Empty)) - (v ::= .... (box v) (cons v v) '())) - - -(module+ test - (test-equal (redex-match? H e (term (Empty))) #t) - (test-equal (redex-match? H e (term (Prim2 'cons (Int 3) (Empty)))) #t) - (test-equal (redex-match? H e (term (Prim2 'cons (Var x) (Var y)))) #t) - (test-equal (redex-match? H v (term (cons 1 2))) #t) - (test-equal (redex-match? H v (term (cons 1 (cons 2 '())))) #t)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-judgment-form H - #:contract (𝑯 e a) - #:mode (𝑯 I O) - [(𝑯-𝒆𝒏𝒗 e () a) - ---------- - (𝑯 e a)]) - -;; Identical to 𝑮-𝒆𝒏𝒗 -(define-judgment-form H - #:contract (𝑯-𝒆𝒏𝒗 e r a) - #:mode (𝑯-𝒆𝒏𝒗 I I O) - - ;; Value - [----------- "int-lit" - (𝑯-𝒆𝒏𝒗 (Int i) r i)] - [----------- "bool-lit" - (𝑯-𝒆𝒏𝒗 (Bool b) r b)] - [----------- "empty-lit" - (𝑯-𝒆𝒏𝒗 (Empty) r '())] - - ;; If - [(𝑯-𝒆𝒏𝒗 e_0 r v_0) (side-condition (is-true v_0)) (𝑯-𝒆𝒏𝒗 e_1 r a) - -------- "if-true" - (𝑯-𝒆𝒏𝒗 (If e_0 e_1 e_2) r a)] - - [(𝑯-𝒆𝒏𝒗 e_0 r v_0) (side-condition (is-false v_0)) (𝑯-𝒆𝒏𝒗 e_2 r a) - -------- "if-false" - (𝑯-𝒆𝒏𝒗 (If e_0 e_1 e_2) r a)] - - [(𝑯-𝒆𝒏𝒗 e_0 r err) - -------- "if-err" - (𝑯-𝒆𝒏𝒗 (If e_0 e_1 e_2) r err)] - - ;; Let and variable - [(where a (lookup r x)) - ----------- "var" - (𝑯-𝒆𝒏𝒗 (Var x) r a)] - - [(𝑯-𝒆𝒏𝒗 e_0 r v_0) (𝑯-𝒆𝒏𝒗 e_1 (ext r x v_0) a) - ----- "let" - (𝑯-𝒆𝒏𝒗 (Let x e_0 e_1) r a)] - - [(𝑯-𝒆𝒏𝒗 e_0 r err) - ----------- "let-err" - (𝑯-𝒆𝒏𝒗 (Let x e_0 e_1) r err)] - - ;; Primitive application - [(𝑯-𝒆𝒏𝒗 e_0 r a_0) - ----------- "prim1" - (𝑯-𝒆𝒏𝒗 (Prim1 p e_0) r (𝑯-𝒑𝒓𝒊𝒎 p a_0))] - - [(𝑯-𝒆𝒏𝒗 e_0 r a_0) - (𝑯-𝒆𝒏𝒗 e_1 r a_1) - ----------- "prim2" - (𝑯-𝒆𝒏𝒗 (Prim2 p e_0 e_1) r (𝑯-𝒑𝒓𝒊𝒎 p a_0 a_1))]) - -(define-metafunction H - 𝑯-𝒑𝒓𝒊𝒎 : p a ... -> a - [(𝑯-𝒑𝒓𝒊𝒎 p v ... err _ ...) err] - [(𝑯-𝒑𝒓𝒊𝒎 'add1 i_0) ,(+ (term i_0) (term 1))] - [(𝑯-𝒑𝒓𝒊𝒎 'sub1 i_0) ,(- (term i_0) (term 1))] - [(𝑯-𝒑𝒓𝒊𝒎 'zero? 0) #t] - [(𝑯-𝒑𝒓𝒊𝒎 'zero? i) #f] - [(𝑯-𝒑𝒓𝒊𝒎 '+ i_0 i_1) ,(+ (term i_0) (term i_1))] - [(𝑯-𝒑𝒓𝒊𝒎 '- i_0 i_1) ,(- (term i_0) (term i_1))] - [(𝑯-𝒑𝒓𝒊𝒎 'box v) (box v)] - [(𝑯-𝒑𝒓𝒊𝒎 'unbox (box v)) v] - [(𝑯-𝒑𝒓𝒊𝒎 'cons v_1 v_2) (cons v_1 v_2)] - [(𝑯-𝒑𝒓𝒊𝒎 'car (cons v_1 v_2)) v_1] - [(𝑯-𝒑𝒓𝒊𝒎 'cdr (cons v_1 v_2)) v_2] - [(𝑯-𝒑𝒓𝒊𝒎 _ ...) err]) - - -(define-metafunction H - ext : r x v -> r - [(ext ((x_0 v_0) ...) x v) - ((x v) (x_0 v_0) ...)]) - -(define-metafunction H - lookup : r x -> a - [(lookup () x) err] - [(lookup ((x v) (x_1 v_1) ...) x) v] - [(lookup ((x_0 v_0) (x_1 v_1) ...) x) - (lookup ((x_1 v_1) ...) x)]) - -(define-metafunction H - is-true : v -> boolean - [(is-true #f) #f] - [(is-true v) #t]) - -(define-metafunction H - is-false : v -> boolean - [(is-false #f) #t] - [(is-false v) #f]) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(define-extended-language Hm_hidden H - ( ::= (& natural))) - -(define-extended-language Hm Hm_hidden - (α ::= ) - (v ::= integer boolean (box α) (cons α) '()) - (s ::= (v) (v v)) - (σ ::= ((α s) ...))) - -(define-judgment-form Hm - #:contract (𝑯′ e any) - #:mode (𝑯′ I O) - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e () () σ a) - ----------------------- - (𝑯′ e (unload σ a))]) - - -(define-judgment-form Hm - #:contract (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e r σ σ a) - #:mode (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 I I I O O) - - ;; Value - [----------- "int-lit" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Int i) r σ σ i)] - [----------- "bool-lit" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Bool b) r σ σ b)] - [----------- "empty-lit" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Empty) r σ σ '())] - - ;; If - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 v) - (side-condition (is-true v)) - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_1 σ_2 a) - -------- "if-true" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (If e_0 e_1 e_2) r σ_0 σ_2 a)] - - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 v) - (side-condition (is-false v)) - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_2 r σ_1 σ_2 a) - -------- "if-false" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (If e_0 e_1 e_2) r σ_0 σ_2 a)] - - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 err) - -------- "if-err" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (If e_0 e_1 e_2) r σ_0 σ_1 err)] - - ;; Let and variable - [(where a (lookup r x)) - ----------- "var" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Var x) r σ σ a)] - - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 v_0) - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_1 (ext r x v_0) σ_1 σ_2 a) - ----- "let" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Let x e_0 e_1) r σ_0 σ_2 a)] - - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 err) - ----------- "let-err" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Let x e_0 e_1) r σ_0 σ_1 err)] - - ;; Primitive application - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 a_0) - (where (σ_2 a) (𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 p a_0 σ_1)) - ----------- "prim1" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Prim1 p e_0) r σ_0 σ_2 a)] - - [(𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_0 r σ_0 σ_1 a_0) - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 e_1 r σ_1 σ_2 a_1) - (where (σ_3 a) (𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 p a_0 a_1 σ_2)) - ----------- "prim2" - (𝑯-𝒎𝒆𝒎-𝒆𝒏𝒗 (Prim2 p e_0 e_1) r σ_0 σ_3 a)]) - -(define-metafunction Hm - 𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 : p a ... σ -> (σ a) - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 p v ... err _ ... σ) (σ err)] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'add1 i_0 σ) (σ ,(+ (term i_0) 1))] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'sub1 i_0 σ) (σ ,(- (term i_0) 1))] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'zero? 0 σ) (σ #t)] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'zero? i σ) (σ #f)] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 '+ i_0 i_1 σ) (σ ,(+ (term i_0) (term i_1)))] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 '- i_0 i_1 σ) (σ ,(- (term i_0) (term i_1)))] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'box v σ) (alloc σ (box v))] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'unbox (box α) σ) (σ v) (where (_ ... (α (v)) _ ...) σ)] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'cons v_1 v_2 σ) (alloc σ (cons v_1 v_2))] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'car (cons α) σ) (σ v) (where (_ ... (α (v _)) _ ...) σ)] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 'cdr (cons α) σ) (σ v) (where (_ ... (α (_ v)) _ ...) σ)] - [(𝑯-𝒎𝒆𝒎-𝒑𝒓𝒊𝒎 _ ... σ) (σ err)]) - -(define-metafunction Hm - alloc : σ (_ v ...) -> (σ v) - [(alloc () (any_cons v ...)) ((((& 0) (v ...))) (any_cons (& 0)))] - [(alloc ((α_0 s_0) ... ((& i) s_n)) (any_cons v ...)) - (((α_0 s_0) ... ((& i) s_n) ((& ,(add1 (term i))) (v ...))) - (any_cons (& ,(add1 (term i)))))]) - - -(define-metafunction Hm - unload : σ a -> any_H_a - [(unload σ err) err] - [(unload σ i) i] - [(unload σ b) b] - [(unload σ '()) '()] - [(unload σ (box α)) - (box (unload σ v)) - (where (_ ... (α (v)) _ ...) σ)] - [(unload σ (cons α)) - (cons (unload σ v_1) - (unload σ v_2)) - (where (_ ... (α (v_1 v_2)) _ ...) σ)]) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Convert v to using Racket pairs, boxes, and null -(define-metafunction H - convert : a -> any - [(convert '()) ()] - [(convert (box v_0)) ,(box (term (convert v_0)))] - [(convert (cons v_0 v_1)) ,(cons (term (convert v_0)) (term (convert v_1)))] - [(convert a) a]) - -(module+ test - (test-judgment-holds (𝑯 (Int 7) 7)) - (test-judgment-holds (𝑯 (Prim1 'add1 (Int 7)) 8)) - - (test-judgment-holds (𝑯 (Prim1 'add1 (Bool #f)) err)) - - (test-judgment-holds (𝑯 (Let x (Int 7) (Int 8)) 8)) - (test-judgment-holds (𝑯 (Let x (Int 7) (Var x)) 7)) - (test-judgment-holds (𝑯 (Let x (Int 7) (Prim1 'add1 (Var x))) 8)) - (test-judgment-holds (𝑯 (Prim1 'sub1 (Let x (Int 7) (Prim1 'add1 (Var x)))) 7)) - (test-judgment-holds (𝑯 (Prim1 'sub1 (Let x (Int 7) - (Let y (Var x) - (Prim1 'add1 (Var x))))) - 7)) - (test-judgment-holds (𝑯 (Prim1 'sub1 (Let x (Int 7) - (Let x (Int 8) - (Prim1 'add1 (Var x))))) - 8)) - - (test-judgment-holds (𝑯 (Prim1 'zero? (Int 0)) #t)) - (test-judgment-holds (𝑯 (Prim1 'zero? (Int 1)) #f)) - (test-judgment-holds (𝑯 (Prim1 'zero? (Bool #f)) err)) - - (test-judgment-holds (𝑯 (Prim2 '+ (Int 1) (Int 2)) 3)) - (test-judgment-holds (𝑯 (Prim2 '- (Int 1) (Int 2)) -1)) - (test-judgment-holds (𝑯 (Prim1 'add1 (Bool #f)) err)) - (test-judgment-holds (𝑯 (If (Prim1 'add1 (Bool #f)) (Int 1) (Int 2)) err)) - (test-judgment-holds (𝑯 (If (Prim1 'zero? (Bool #t)) (Prim1 'add1 (Bool #f)) (Int 2)) err)) - (test-judgment-holds (𝑯 (Prim2 '+ (Int 1) (Prim1 'add1 (Bool #f))) err)) - (test-judgment-holds (𝑯 (Prim2 '+ (Int 1) (Bool #f)) err)) - (test-judgment-holds (𝑯 (Prim2 '- (Int 1) (Bool #f)) err)) - (test-judgment-holds (𝑯 (Prim2 '- (Prim1 'add1 (Bool #f)) (Bool #f)) err)) - - (test-judgment-holds (𝑯 (Empty) '())) - (test-judgment-holds (𝑯 (Prim2 'cons (Int 1) (Int 2)) (cons 1 2))) - (test-judgment-holds (𝑯 (Prim2 'cons (Int 1) (Prim1 'add1 (Bool #f))) err)) - (test-judgment-holds (𝑯 (Let x (Int 1) - (Let y (Int 2) - (Prim2 'cons (Var x) (Var y)))) - (cons 1 2))) - (test-judgment-holds (𝑯 (Prim1 'car (Prim2 'cons (Int 1) (Int 2))) 1)) - (test-judgment-holds (𝑯 (Prim1 'cdr (Prim2 'cons (Int 1) (Int 2))) 2)) - (test-judgment-holds (𝑯 (Prim1 'cdr (Prim2 'cons (Int 1) (Prim2 'cons (Int 2) (Empty)))) (cons 2 '()))) - (test-judgment-holds (𝑯 (Prim1 'car (Prim2 'cons (Prim1 'add1 (Int 7)) (Empty))) 8)) - (test-judgment-holds (𝑯 (Prim1 'box (Int 7)) (box 7))) - (test-judgment-holds (𝑯 (Prim1 'unbox (Prim1 'box (Int 7))) 7)) - (test-judgment-holds (𝑯 (Prim1 'unbox (Prim1 'unbox (Int 7))) err)) - - (test-equal (term (convert '())) '()) - (test-equal (term (convert (cons 1 2))) '(1 . 2))) - -(module+ test - (test-judgment-holds (𝑯′ (Int 7) 7)) - (test-judgment-holds (𝑯′ (Prim1 'add1 (Int 7)) 8)) - - (test-judgment-holds (𝑯′ (Prim1 'add1 (Bool #f)) err)) - - (test-judgment-holds (𝑯′ (Let x (Int 7) (Int 8)) 8)) - (test-judgment-holds (𝑯′ (Let x (Int 7) (Var x)) 7)) - (test-judgment-holds (𝑯′ (Let x (Int 7) (Prim1 'add1 (Var x))) 8)) - (test-judgment-holds (𝑯′ (Prim1 'sub1 (Let x (Int 7) (Prim1 'add1 (Var x)))) 7)) - (test-judgment-holds (𝑯′ (Prim1 'sub1 (Let x (Int 7) - (Let y (Var x) - (Prim1 'add1 (Var x))))) - 7)) - (test-judgment-holds (𝑯′ (Prim1 'sub1 (Let x (Int 7) - (Let x (Int 8) - (Prim1 'add1 (Var x))))) - 8)) - - (test-judgment-holds (𝑯′ (Prim1 'zero? (Int 0)) #t)) - (test-judgment-holds (𝑯′ (Prim1 'zero? (Int 1)) #f)) - (test-judgment-holds (𝑯′ (Prim1 'zero? (Bool #f)) err)) - - (test-judgment-holds (𝑯′ (Prim2 '+ (Int 1) (Int 2)) 3)) - (test-judgment-holds (𝑯′ (Prim2 '- (Int 1) (Int 2)) -1)) - (test-judgment-holds (𝑯′ (Prim1 'add1 (Bool #f)) err)) - (test-judgment-holds (𝑯′ (If (Prim1 'add1 (Bool #f)) (Int 1) (Int 2)) err)) - (test-judgment-holds (𝑯′ (If (Prim1 'zero? (Bool #t)) (Prim1 'add1 (Bool #f)) (Int 2)) err)) - (test-judgment-holds (𝑯′ (Prim2 '+ (Int 1) (Prim1 'add1 (Bool #f))) err)) - (test-judgment-holds (𝑯′ (Prim2 '+ (Int 1) (Bool #f)) err)) - (test-judgment-holds (𝑯′ (Prim2 '- (Int 1) (Bool #f)) err)) - (test-judgment-holds (𝑯′ (Prim2 '- (Prim1 'add1 (Bool #f)) (Bool #f)) err)) - - (test-judgment-holds (𝑯′ (Empty) '())) - (test-judgment-holds (𝑯′ (Prim2 'cons (Int 1) (Int 2)) (cons 1 2))) - (test-judgment-holds (𝑯′ (Prim2 'cons (Int 1) (Prim1 'add1 (Bool #f))) err)) - (test-judgment-holds (𝑯′ (Let x (Int 1) - (Let y (Int 2) - (Prim2 'cons (Var x) (Var y)))) - (cons 1 2))) - (test-judgment-holds (𝑯′ (Prim1 'car (Prim2 'cons (Int 1) (Int 2))) 1)) - (test-judgment-holds (𝑯′ (Prim1 'cdr (Prim2 'cons (Int 1) (Int 2))) 2)) - (test-judgment-holds (𝑯′ (Prim1 'cdr (Prim2 'cons (Int 1) (Prim2 'cons (Int 2) (Empty)))) (cons 2 '()))) - (test-judgment-holds (𝑯′ (Prim1 'car (Prim2 'cons (Prim1 'add1 (Int 7)) (Empty))) 8)) - (test-judgment-holds (𝑯′ (Prim1 'box (Int 7)) (box 7))) - (test-judgment-holds (𝑯′ (Prim1 'unbox (Prim1 'box (Int 7))) 7)) - (test-judgment-holds (𝑯′ (Prim1 'unbox (Prim1 'unbox (Int 7))) err))) - - - -(module+ test - ;; Check that the semantics is total function - (redex-check H e (redex-match? H (a_0) (judgment-holds (𝑯 e a) a)))) diff --git a/hustle/ast.rkt b/hustle/syntax/ast.rkt similarity index 100% rename from hustle/ast.rkt rename to hustle/syntax/ast.rkt diff --git a/hustle/parse.rkt b/hustle/syntax/parse.rkt similarity index 100% rename from hustle/parse.rkt rename to hustle/syntax/parse.rkt diff --git a/hustle/random.rkt b/hustle/syntax/random.rkt similarity index 100% rename from hustle/random.rkt rename to hustle/syntax/random.rkt diff --git a/hustle/test/compile.rkt b/hustle/test/compile.rkt deleted file mode 100644 index 3d22968..0000000 --- a/hustle/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ (e) (exec (parse-closed e)))) -(test/io (λ (i e) (exec/io (parse-closed e) i))) - diff --git a/hustle/test/test-runner.rkt b/hustle/test/define-tests.rkt similarity index 98% rename from hustle/test/test-runner.rkt rename to hustle/test/define-tests.rkt index 8079325..8557916 100644 --- a/hustle/test/test-runner.rkt +++ b/hustle/test/define-tests.rkt @@ -93,7 +93,7 @@ (check-equal? (run '(= (add1 4) 5)) #t) (check-equal? (run '(< 5 5)) #f) (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (check-equal? (run '(< (add1 4) 5)) #f)) (begin ;; Hustle (check-equal? (run '(empty? (cons 1 2))) #f) diff --git a/hustle/test/interp.rkt b/hustle/test/interp.rkt deleted file mode 100644 index 0a2dab1..0000000 --- a/hustle/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ (e) (interp (parse-closed e)))) -(test/io (λ (in e) (interp/io (parse-closed e) in))) - diff --git a/hustle/test/run-compile-tests.rkt b/hustle/test/run-compile-tests.rkt new file mode 100644 index 0000000..9cc5971 --- /dev/null +++ b/hustle/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ (e) (run (compile (parse-closed e))))) +(test/io (λ (i e) (run/io (compile (parse-closed e)) i))) + diff --git a/hoax/test/interp-heap.rkt b/hustle/test/run-interp-heap-bits-tests.rkt similarity index 50% rename from hoax/test/interp-heap.rkt rename to hustle/test/run-interp-heap-bits-tests.rkt index 6ad0cb9..115f689 100644 --- a/hoax/test/interp-heap.rkt +++ b/hustle/test/run-interp-heap-bits-tests.rkt @@ -1,8 +1,8 @@ #lang racket -(require "test-runner.rkt") -(require "../parse.rkt") -(require "../interp-heap.rkt") -(require "../interp-io.rkt") +(require "define-tests.rkt") +(require "../syntax/parse.rkt") +(require "../interpreter/interp-heap-bits.rkt") +(require "../interpreter/interp-io.rkt") (test (λ (e) (interp (parse e)))) diff --git a/hustle/test/interp-heap.rkt b/hustle/test/run-interp-heap-tests.rkt similarity index 51% rename from hustle/test/interp-heap.rkt rename to hustle/test/run-interp-heap-tests.rkt index 6ad0cb9..252f89e 100644 --- a/hustle/test/interp-heap.rkt +++ b/hustle/test/run-interp-heap-tests.rkt @@ -1,8 +1,8 @@ #lang racket -(require "test-runner.rkt") -(require "../parse.rkt") -(require "../interp-heap.rkt") -(require "../interp-io.rkt") +(require "define-tests.rkt") +(require "../syntax/parse.rkt") +(require "../interpreter/interp-heap.rkt") +(require "../interpreter/interp-io.rkt") (test (λ (e) (interp (parse e)))) diff --git a/hustle/test/run-interp-tests.rkt b/hustle/test/run-interp-tests.rkt new file mode 100644 index 0000000..32de7cc --- /dev/null +++ b/hustle/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ (e) (interp (parse-closed e)))) +(test/io (λ (in e) (interp/io (parse-closed e) in))) + diff --git a/hustle/test/parse.rkt b/hustle/test/run-parse-tests.rkt similarity index 96% rename from hustle/test/parse.rkt rename to hustle/test/run-parse-tests.rkt index 2624a74..997e985 100644 --- a/hustle/test/parse.rkt +++ b/hustle/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) diff --git a/iniquity-gc/Makefile b/iniquity-gc/Makefile deleted file mode 100644 index 690ca95..0000000 --- a/iniquity-gc/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -ifeq ($(shell uname), Darwin) - LANGS_CC ?= arch -x86_64 clang - LANGS_AS ?= arch -x86_64 clang -c -else - LANGS_CC ?= clang - LANGS_AS ?= clang -c -endif - -objs = \ - main.o \ - print.o \ - values.o \ - io.o \ - gc.o - -default: submit.zip - -submit.zip: - zip submit.zip -r * \ - -x \*.[os] -x \*~ -x \*zip \ - -x \*Zone.Identifier -x \*\*compiled\*\* - -runtime.o: $(objs) - ld -r $(objs) -o runtime.o - -%.run: %.o runtime.o - $(LANGS_CC) runtime.o $< -o $@ - -.c.o: - $(LANGS_CC) -fPIC -c -g -o $@ $< - -.s.o: - $(LANGS_AS) -o $@ $< - -%.s: %.rkt - cat $< | racket -t compile-stdin.rkt -m > $@ - -clean: - @$(RM) *.o *.s *.run ||: - @echo "$(shell basename $(shell pwd)): cleaned!" - -%.test: %.run %.rkt - @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" diff --git a/iniquity-gc/ast.rkt b/iniquity-gc/ast.rkt deleted file mode 100644 index 29e4e06..0000000 --- a/iniquity-gc/ast.rkt +++ /dev/null @@ -1,53 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = (Prog (Listof Defn) Expr) -(struct Prog (ds e) #:prefab) - -;; type Defn = (Defn Id (Listof Id) Expr) -(struct Defn (f xs e) #:prefab) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; | (App Id (Listof Expr)) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | vector-length -;; | 'string? | string-length -;; type Op2 = '+ | '- | '< | '= -;; | 'cons -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) -(struct App (f es) #:prefab) diff --git a/iniquity-gc/build-runtime.rkt b/iniquity-gc/build-runtime.rkt deleted file mode 100644 index 66aad89..0000000 --- a/iniquity-gc/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require racket/runtime-path) -(provide runtime-path) - -(define-runtime-path here ".") - -(void - (system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o"))) - -(define runtime-path - (path->string - (normalize-path (build-path here "runtime.o")))) diff --git a/iniquity-gc/compile-ops.rkt b/iniquity-gc/compile-ops.rkt deleted file mode 100644 index 4ce8d09..0000000 --- a/iniquity-gc/compile-ops.rkt +++ /dev/null @@ -1,427 +0,0 @@ -#lang racket -(provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack unpad-stack allocate) -(require "ast.rkt" "types.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg -(define rsi 'rsi) ; arg -(define rdx 'rdx) ; arg -(define rcx 'rcx) ; arg -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r14 'r14) ; stack pad (non-volatile) -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack -(define rbp 'rbp) ; base stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)] - ['dump-memory-stats - (seq (Mov rdi rsp) - (Mov rsi rbp) - (Mov rdx rbx) - pad-stack - (Call 'print_memory) - unpad-stack - (Mov rax (value->bits (void))))] - ['collect-garbage - (seq (Mov rdi rsp) - (Mov rsi rbp) - (Mov rdx rbx) - pad-stack - (Call 'collect_garbage) - unpad-stack - (Mov rbx rax) - (Mov rax (value->bits (void))))])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-imm 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-imm eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Push rax) - (allocate 1) - (Pop rax) - (Mov (Mem rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Mem rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Mem rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Mem rax 0)))] - ['empty? (eq-imm '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Mem rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Mem rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))])) - -(define (allocate n) - (seq (Mov rdi rsp) - (Mov rsi rbp) - (Mov rdx rbx) - (Mov rcx n) - pad-stack - (Call 'alloc_val) - unpad-stack - (Mov rbx rax))) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (Mov rax (value->bits #t)) - (let ((true (gensym))) - (seq (Jl true) - (Mov rax (value->bits #f)) - (Label true))))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (Mov rax (value->bits #t)) - (let ((true (gensym))) - (seq (Je true) - (Mov rax (value->bits #f)) - (Label true))))] - ;; tricky: if you have a pointer in a register, GC might collect - ;; what it points to and create a dangling reference - ['cons - (seq (Push rax) - (allocate 2) - (Pop rax) - (Mov (Mem rbx 0) rax) - (Pop rax) - (Mov (Mem rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (eq r8 rax))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - - (Push rax) - (Mov rax r8) - (Sar rax int-shift) - (Add rax 1) - (allocate rax) - (Pop rax) - - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Mem rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Mem rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - ['vector-ref - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Mem r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Push rax) - (Mov rax r8) - (Sar rax int-shift) - (Add rax 1) ; adds 1 - (Sar rax 1) ; when - (Sal rax 1) ; len is odd - (Add rax 1) - (allocate rax) - (Pop rax) - - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Mem rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Mem rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Mem r8 8)) - (Sal rax char-shift) - (Or rax type-char))] - - ['set-box! - (seq (Pop r8) - (assert-box r8) - (Xor r8 type-box) - (Mov (Mem r8 0) rax) - (Mov rax (value->bits (void))))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Mem r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (value->bits #t)) - (Je l) - (Mov rax (value->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; Value -> Asm -(define (eq-imm imm) - (let ((l1 (gensym))) - (seq (Cmp rax (value->bits imm)) - (Mov rax (value->bits #t)) - (Je l1) - (Mov rax (value->bits #f)) - (Label l1)))) - -(define (eq ir1 ir2) - (let ((l1 (gensym))) - (seq (Cmp ir1 ir2) - (Mov rax (value->bits #t)) - (Je l1) - (Mov rax (value->bits #f)) - (Label l1)))) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/iniquity-gc/compile.rkt b/iniquity-gc/compile.rkt deleted file mode 100644 index fb9b813..0000000 --- a/iniquity-gc/compile.rkt +++ /dev/null @@ -1,205 +0,0 @@ -#lang racket -(provide compile compile-e) -(require "ast.rkt" "types.rkt" "compile-ops.rkt" a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg - -;; type CEnv = [Listof Variable] - -;; Prog -> Asm -(define (compile p) - (match p - [(Prog ds e) - (prog (externs) - (Global 'entry) - (Label 'entry) - (Push 'rbx) - (Push 'rbp) - (Mov 'rbp 'rsp) ; save stack base pointer - (Mov rbx rdi) ; recv heap pointer - (compile-e e '()) - (Pop 'rbp) - (Pop 'rbx) - (Ret) - (compile-defines ds) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error))])) - -(define (externs) - (seq (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error) - (Extern 'print_memory) - (Extern 'collect_garbage) - (Extern 'alloc_val))) - -;; [Listof Defn] -> Asm -(define (compile-defines ds) - (match ds - ['() (seq)] - [(cons d ds) - (seq (compile-define d) - (compile-defines ds))])) - -;; Defn -> Asm -(define (compile-define d) - (match d - [(Defn f xs e) - (seq (Label (symbol->label f)) - (compile-e e (reverse xs)) - (Add rsp (* 8 (length xs))) ; pop args - (Ret))])) - -;; Expr CEnv -> Asm -(define (compile-e e c) - (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Var x) (compile-variable x c)] - [(Str s) (compile-string s)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] - [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c)] - [(Begin e1 e2) (compile-begin e1 e2 c)] - [(Let x e1 e2) (compile-let x e1 e2 c)] - [(App f es) (compile-app f es c)])) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) - -;; Id CEnv -> Asm -(define (compile-variable x c) - (let ((i (lookup x c))) - (seq (Mov rax (Mem rsp i))))) - -;; String -> Asm -(define (compile-string s) - (let ((len (string-length s))) - (if (zero? len) - (seq (Mov rax type-str)) - (seq (allocate (add1 (quotient (add1 len) 2))) - (Mov rax len) - (Mov (Mem rbx 0) rax) - (compile-string-chars (string->list s) 8) - (Mov rax rbx) - (Or rax type-str) - (Add rbx - (+ 8 (* 4 (if (odd? len) (add1 len) len)))))))) - -;; [Listof Char] Integer -> Asm -(define (compile-string-chars cs i) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Mov rax (char->integer c)) - (Mov (Mem rbx i) 'eax) - (compile-string-chars cs (+ 4 i)))])) - -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) - (compile-op0 p)) - -;; Op1 Expr CEnv -> Asm -(define (compile-prim1 p e c) - (seq (compile-e e c) - (compile-op1 p))) - -;; Op2 Expr Expr CEnv -> Asm -(define (compile-prim2 p e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (compile-op2 p))) - -;; Op3 Expr Expr Expr CEnv -> Asm -(define (compile-prim3 p e1 e2 e3 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons #f c)) - (Push rax) - (compile-e e3 (cons #f (cons #f c))) - (compile-op3 p))) - -;; Expr Expr Expr CEnv -> Asm -(define (compile-if e1 e2 e3 c) - (let ((l1 (gensym 'if)) - (l2 (gensym 'if))) - (seq (compile-e e1 c) - (Cmp rax (value->bits #f)) - (Je l1) - (compile-e e2 c) - (Jmp l2) - (Label l1) - (compile-e e3 c) - (Label l2)))) - -;; Expr Expr CEnv -> Asm -(define (compile-begin e1 e2 c) - (seq (compile-e e1 c) - (compile-e e2 c))) - -;; Id Expr Expr CEnv -> Asm -(define (compile-let x e1 e2 c) - (seq (compile-e e1 c) - (Push rax) - (compile-e e2 (cons x c)) - (Add rsp 8))) - -;; Id [Listof Expr] CEnv -> Asm -;; The return address is placed above the arguments, so callee pops -;; arguments and return address is next frame -(define (compile-app f es c) - (let ((r (gensym 'ret))) - (seq (Lea rax r) - (Push rax) - (compile-es es (cons #f c)) - (Jmp (symbol->label f)) - (Label r)))) - -;; [Listof Expr] CEnv -> Asm -(define (compile-es es c) - (match es - ['() '()] - [(cons e es) - (seq (compile-e e c) - (Push rax) - (compile-es es (cons #f c)))])) - -;; Id CEnv -> Integer -(define (lookup x cenv) - (match cenv - ['() (error "undefined variable:" x)] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (+ 8 (lookup x rest))])])) - -;; Symbol -> Label -;; Produce a symbol that is a valid Nasm label -(define (symbol->label s) - (string->symbol - (string-append - "label_" - (list->string - (map (λ (c) - (if (or (char<=? #\a c #\z) - (char<=? #\A c #\Z) - (char<=? #\0 c #\9) - (memq c '(#\_ #\$ #\# #\@ #\~ #\. #\?))) - c - #\_)) - (string->list (symbol->string s)))) - "_" - (number->string (eq-hash-code s) 16)))) diff --git a/iniquity-gc/gc.c b/iniquity-gc/gc.c deleted file mode 100644 index a5f5e48..0000000 --- a/iniquity-gc/gc.c +++ /dev/null @@ -1,150 +0,0 @@ -#include -#include -#include -#include -#include "values.h" -#include "runtime.h" - -const char* val_typeof_string(int64_t t) { - switch (val_typeof(t)) { - case T_INT: return "INT"; - case T_BOOL: return "BOOL"; - case T_CHAR: return "CHAR"; - case T_EOF: return "EOF"; - case T_VOID: return "VOID"; - case T_EMPTY: return "EMPTY"; - case T_BOX: return "BOX"; - case T_CONS: return "CONS"; - case T_VECT: return "VECT"; - case T_STR: return "STR"; - default: return "UNKNOWN"; - } -} - -void step(val_t** to_curr, val_t** to_next, int count, int* t_back) { - type_t t; - int i; - int size; - val_t v; - val_t *ptr_v; - for (i = 0; i < count; i++) { - v = **to_curr; - t = val_typeof(v); - switch (t) { - case T_BOX: - case T_CONS: - case T_VECT: - case T_STR: - ptr_v = val_unwrap(v); - if (ptr_v >= from && ptr_v < from + heap_size) { - // this is a pointer to from space so we need to deal with it - if (val_unwrap(*ptr_v) >= to && - val_unwrap(*ptr_v) < to + heap_size) { - // it points to a fwd pointer (points in to to-space), so just set - // curr to what it points to. - **to_curr = *ptr_v; - *to_curr = *to_curr + 1; - } else { - // copy, fwd, update - size = val_size(ptr_v, t); - types[*t_back] = t; // enqueue type - *t_back = *t_back + 1; - memcpy(*to_next, ptr_v, 8 * size); // copy - *ptr_v = val_wrap(*to_next, t); // fwd - **to_curr = val_wrap(*to_next, t); // update - *to_next = *to_next + size; - *to_curr = *to_curr + 1; - } - } else { - // looks like a pointer, but doesn't point to from-space - // leave it alone - *to_curr = *to_curr + 1; - } - break; - default: - // not a pointer - *to_curr = *to_curr + 1; - } - } -} - - -int64_t* collect_garbage(int64_t* rsp, int64_t *rbp, int64_t* rbx) { - - printf("Collect garbage: rsp = %" PRIx64 ", rbp = %" PRIx64 ", rbx = %" PRIx64 "\n", - (int64_t)rsp, (int64_t)rbp, (int64_t)rbx); - - int stack_count = rbp - rsp; - - val_t *tmp; - val_t *to_next = to; - val_t *to_curr = to; - - int t_back = 0; - int t_front = 0; - - // Step through everything on the stack - val_t *rsp_curr = rsp; - step(&rsp_curr, &to_next, stack_count, &t_back); - int vi; - // now play catch up between to_curr and to_next - while (to_curr != to_next) { - switch (types[t_front++]) { - case T_VECT: - vi = to_curr[0]; - to_curr++; - step(&to_curr, &to_next, vi, &t_back); - break; - case T_BOX: - step(&to_curr, &to_next, 1, &t_back); - break; - case T_CONS: - step(&to_curr, &to_next, 2, &t_back); - break; - case T_STR: - to_curr = to_curr + 1 + ((*to_curr + 1) / 2); - break; - default: - to_curr++; - break; - } - } - - tmp = from; - from = to; - to = tmp; - return to_next; -} - - -void print_memory(int64_t* rsp, int64_t* rbp, int64_t* rbx) { - - int stack_count = rbp - rsp; - int heap_count = rbx - from; - - printf("----------------------------------------------------------------\n"); - int i; - - printf("STACK:\n"); - for (i = 0; i < stack_count; i++) { - printf("[%" PRIx64 "] = %016" PRIx64 ", %s\n", - (int64_t)rsp + 8*i, rsp[i], val_typeof_string(rsp[i])); - } - printf("HEAP:\n"); - for (i = 0; i < heap_count; i++) { - printf("[%" PRIx64 "] = %016" PRIx64 ", %s\n", - (int64_t)from + 8*i, from[i], val_typeof_string(from[i])); - } -} - -int64_t* alloc_val(int64_t* rsp, int64_t* rbp, int64_t* rbx, int words) { - if (rbx + words >= from + heap_size) { - rbx = collect_garbage(rsp, rbp, rbx); - if (rbx + words >= from + heap_size) { - printf("OUT OF MEMORY!!\n"); - error_handler(); - } - } - // printf("returning %" PRIx64 "\n", (int64_t)rbx); - return rbx; -} diff --git a/iniquity-gc/interp-prims.rkt b/iniquity-gc/interp-prims.rkt deleted file mode 100644 index 4cbabc6..0000000 --- a/iniquity-gc/interp-prims.rkt +++ /dev/null @@ -1,69 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [(list 'vector? v) (vector? v)] - [(list 'vector-length (? vector?)) (vector-length v)] - [(list 'string? v) (string? v)] - [(list 'string-length (? string?)) (string-length v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] - [(list 'make-vector (? integer?) _) - (if (<= 0 v1) - (make-vector v1 v2) - 'err)] - [(list 'vector-ref (? vector?) (? integer?)) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-ref v1 v2) - 'err)] - [(list 'make-string (? integer?) (? char?)) - (if (<= 0 v1) - (make-string v1 v2) - 'err)] - [(list 'string-ref (? string?) (? integer?)) - (if (<= 0 v2 (sub1 (string-length v1))) - (string-ref v1 v2) - 'err)] - [_ 'err])) - -;; Op3 Value Value Value -> Answer -(define (interp-prim3 p v1 v2 v3) - (match (list p v1 v2 v3) - [(list 'vector-set! (? vector?) (? integer?) _) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/iniquity-gc/interp.rkt b/iniquity-gc/interp.rkt deleted file mode 100644 index 3576d43..0000000 --- a/iniquity-gc/interp.rkt +++ /dev/null @@ -1,110 +0,0 @@ -#lang racket -(provide interp interp-env) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (lookup r x)] - [(Str s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim0 'dump-memory-stats) (dump-memory-stats)] - [(Prim0 'collect-garbage) (collect-garbage)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(App f es) - (match (interp-env* es r ds) - ['err 'err] - [vs - (match (defns-lookup ds f) - [(Defn f xs e) - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (zip xs vs) ds) - 'err)])])])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> Defn -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/iniquity-gc/main.c b/iniquity-gc/main.c deleted file mode 100644 index 1157f0b..0000000 --- a/iniquity-gc/main.c +++ /dev/null @@ -1,46 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; -val_t *to; -val_t *from; -type_t *types; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(2 * 8 * heap_size); - from = heap; - to = heap + heap_size; - types = malloc(sizeof(type_t) * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/iniquity-gc/parse.rkt b/iniquity-gc/parse.rkt deleted file mode 100644 index b5d9565..0000000 --- a/iniquity-gc/parse.rkt +++ /dev/null @@ -1,65 +0,0 @@ -#lang racket -(provide parse parse-define parse-e) -(require "ast.rkt") - -;; [Listof S-Expr] -> Prog -(define (parse s) - (match s - [(cons (and (cons 'define _) d) s) - (match (parse s) - [(Prog ds e) - (Prog (cons (parse-define d) ds) e)])] - [(cons e '()) (Prog '() (parse-e e))] - [_ (error "program parse error")])) - -;; S-Expr -> Defn -(define (parse-define s) - (match s - [(list 'define (list-rest (? symbol? f) xs) e) - (if (andmap symbol? xs) - (Defn f xs (parse-e e)) - (error "parse definition error"))] - [_ (error "Parse defn error" s)])) - -;; S-Expr -> Expr -(define (parse-e s) - (match s - [(? integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse-e e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'begin e1 e2) - (Begin (parse-e e1) (parse-e e2))] - [(list 'if e1 e2 e3) - (If (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse-e e1) (parse-e e2))] - [(cons (? symbol? f) es) - (App f (map parse-e es))] - [_ (error "Parse error" s)])) - -(define op0 - '(read-byte peek-byte void dump-memory-stats collect-garbage)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref set-box!)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/iniquity-gc/print.c b/iniquity-gc/print.c deleted file mode 100644 index acb1413..0000000 --- a/iniquity-gc/print.c +++ /dev/null @@ -1,839 +0,0 @@ -#include -#include -#include "values.h" - -void print_char(val_char_t); -void print_codepoint(val_char_t); -void print_cons(val_cons_t *); -void print_vect(val_vect_t*); -void print_str(val_str_t*); -void print_str_char(val_char_t); -void print_result_interior(val_t); -int utf8_encode_char(val_char_t, char *); - -void print_result(val_t x) -{ - switch (val_typeof(x)) { - case T_INT: - printf("%" PRId64, val_unwrap_int(x)); - break; - case T_BOOL: - printf(val_unwrap_bool(x) ? "#t" : "#f"); - break; - case T_CHAR: - print_char(val_unwrap_char(x)); - break; - case T_EOF: - printf("#"); - break; - case T_VOID: - break; - case T_EMPTY: - case T_BOX: - case T_CONS: - case T_VECT: - printf("'"); - print_result_interior(x); - break; - case T_STR: - putchar('"'); - print_str(val_unwrap_str(x)); - putchar('"'); - break; - case T_INVALID: - printf("internal error"); - } -} - -void print_result_interior(val_t x) -{ - switch (val_typeof(x)) { - case T_EMPTY: - printf("()"); - break; - case T_BOX: - printf("#&"); - print_result_interior(val_unwrap_box(x)->val); - break; - case T_CONS: - printf("("); - print_cons(val_unwrap_cons(x)); - printf(")"); - break; - case T_VECT: - print_vect(val_unwrap_vect(x)); - break; - default: - print_result(x); - } -} - -void print_vect(val_vect_t *v) -{ - uint64_t i; - - if (!v) { printf("#()"); return; } - - printf("#("); - for (i = 0; i < v->len; ++i) { - print_result_interior(v->elems[i]); - - if (i < v->len - 1) - putchar(' '); - } - printf(")"); -} - -void print_cons(val_cons_t *cons) -{ - print_result_interior(cons->fst); - - switch (val_typeof(cons->snd)) { - case T_EMPTY: - // nothing - break; - case T_CONS: - printf(" "); - print_cons(val_unwrap_cons(cons->snd)); - break; - default: - printf(" . "); - print_result_interior(cons->snd); - break; - } -} - -void print_str(val_str_t* s) -{ - if (!s) return; - uint64_t i; - for (i = 0; i < s->len; ++i) - print_str_char(s->codepoints[i]); -} - -void print_str_char_u(val_char_t c) -{ - printf("\\u%04X", c); -} - -void print_str_char_U(val_char_t c) -{ - printf("\\U%08X", c); -} - -void print_str_char(val_char_t c) -{ - switch (c) { - case 0 ... 6: - print_str_char_u(c); - break; - case 7: - printf("\\a"); - break; - case 8: - printf("\\b"); - break; - case 9: - printf("\\t"); - break; - case 10: - printf("\\n"); - break; - case 11: - printf("\\v"); - break; - case 12: - printf("\\f"); - break; - case 13: - printf("\\r"); - break; - case 14 ... 26: - print_str_char_u(c); - break; - case 27: - printf("\\e"); - break; - case 28 ... 31: - print_str_char_u(c); - break; - case 34: - printf("\\\""); - break; - case 39: - printf("'"); - break; - case 92: - printf("\\\\"); - break; - case 127 ... 159: - case 173 ... 173: - case 888 ... 889: - case 896 ... 899: - case 907 ... 907: - case 909 ... 909: - case 930 ... 930: - case 1328 ... 1328: - case 1367 ... 1368: - case 1376 ... 1376: - case 1416 ... 1416: - case 1419 ... 1420: - case 1424 ... 1424: - case 1480 ... 1487: - case 1515 ... 1519: - case 1525 ... 1541: - case 1564 ... 1565: - case 1757 ... 1757: - case 1806 ... 1807: - case 1867 ... 1868: - case 1970 ... 1983: - case 2043 ... 2047: - case 2094 ... 2095: - case 2111 ... 2111: - case 2140 ... 2141: - case 2143 ... 2207: - case 2227 ... 2275: - case 2436 ... 2436: - case 2445 ... 2446: - case 2449 ... 2450: - case 2473 ... 2473: - case 2481 ... 2481: - case 2483 ... 2485: - case 2490 ... 2491: - case 2501 ... 2502: - case 2505 ... 2506: - case 2511 ... 2518: - case 2520 ... 2523: - case 2526 ... 2526: - case 2532 ... 2533: - case 2556 ... 2560: - case 2564 ... 2564: - case 2571 ... 2574: - case 2577 ... 2578: - case 2601 ... 2601: - case 2609 ... 2609: - case 2612 ... 2612: - case 2615 ... 2615: - case 2618 ... 2619: - case 2621 ... 2621: - case 2627 ... 2630: - case 2633 ... 2634: - case 2638 ... 2640: - case 2642 ... 2648: - case 2653 ... 2653: - case 2655 ... 2661: - case 2678 ... 2688: - case 2692 ... 2692: - case 2702 ... 2702: - case 2706 ... 2706: - case 2729 ... 2729: - case 2737 ... 2737: - case 2740 ... 2740: - case 2746 ... 2747: - case 2758 ... 2758: - case 2762 ... 2762: - case 2766 ... 2767: - case 2769 ... 2783: - case 2788 ... 2789: - case 2802 ... 2816: - case 2820 ... 2820: - case 2829 ... 2830: - case 2833 ... 2834: - case 2857 ... 2857: - case 2865 ... 2865: - case 2868 ... 2868: - case 2874 ... 2875: - case 2885 ... 2886: - case 2889 ... 2890: - case 2894 ... 2901: - case 2904 ... 2907: - case 2910 ... 2910: - case 2916 ... 2917: - case 2936 ... 2945: - case 2948 ... 2948: - case 2955 ... 2957: - case 2961 ... 2961: - case 2966 ... 2968: - case 2971 ... 2971: - case 2973 ... 2973: - case 2976 ... 2978: - case 2981 ... 2983: - case 2987 ... 2989: - case 3002 ... 3005: - case 3011 ... 3013: - case 3017 ... 3017: - case 3022 ... 3023: - case 3025 ... 3030: - case 3032 ... 3045: - case 3067 ... 3071: - case 3076 ... 3076: - case 3085 ... 3085: - case 3089 ... 3089: - case 3113 ... 3113: - case 3130 ... 3132: - case 3141 ... 3141: - case 3145 ... 3145: - case 3150 ... 3156: - case 3159 ... 3159: - case 3162 ... 3167: - case 3172 ... 3173: - case 3184 ... 3191: - case 3200 ... 3200: - case 3204 ... 3204: - case 3213 ... 3213: - case 3217 ... 3217: - case 3241 ... 3241: - case 3252 ... 3252: - case 3258 ... 3259: - case 3269 ... 3269: - case 3273 ... 3273: - case 3278 ... 3284: - case 3287 ... 3293: - case 3295 ... 3295: - case 3300 ... 3301: - case 3312 ... 3312: - case 3315 ... 3328: - case 3332 ... 3332: - case 3341 ... 3341: - case 3345 ... 3345: - case 3387 ... 3388: - case 3397 ... 3397: - case 3401 ... 3401: - case 3407 ... 3414: - case 3416 ... 3423: - case 3428 ... 3429: - case 3446 ... 3448: - case 3456 ... 3457: - case 3460 ... 3460: - case 3479 ... 3481: - case 3506 ... 3506: - case 3516 ... 3516: - case 3518 ... 3519: - case 3527 ... 3529: - case 3531 ... 3534: - case 3541 ... 3541: - case 3543 ... 3543: - case 3552 ... 3557: - case 3568 ... 3569: - case 3573 ... 3584: - case 3643 ... 3646: - case 3676 ... 3712: - case 3715 ... 3715: - case 3717 ... 3718: - case 3721 ... 3721: - case 3723 ... 3724: - case 3726 ... 3731: - case 3736 ... 3736: - case 3744 ... 3744: - case 3748 ... 3748: - case 3750 ... 3750: - case 3752 ... 3753: - case 3756 ... 3756: - case 3770 ... 3770: - case 3774 ... 3775: - case 3781 ... 3781: - case 3783 ... 3783: - case 3790 ... 3791: - case 3802 ... 3803: - case 3808 ... 3839: - case 3912 ... 3912: - case 3949 ... 3952: - case 3992 ... 3992: - case 4029 ... 4029: - case 4045 ... 4045: - case 4059 ... 4095: - case 4294 ... 4294: - case 4296 ... 4300: - case 4302 ... 4303: - case 4681 ... 4681: - case 4686 ... 4687: - case 4695 ... 4695: - case 4697 ... 4697: - case 4702 ... 4703: - case 4745 ... 4745: - case 4750 ... 4751: - case 4785 ... 4785: - case 4790 ... 4791: - case 4799 ... 4799: - case 4801 ... 4801: - case 4806 ... 4807: - case 4823 ... 4823: - case 4881 ... 4881: - case 4886 ... 4887: - case 4955 ... 4956: - case 4989 ... 4991: - case 5018 ... 5023: - case 5109 ... 5119: - case 5789 ... 5791: - case 5881 ... 5887: - case 5901 ... 5901: - case 5909 ... 5919: - case 5943 ... 5951: - case 5972 ... 5983: - case 5997 ... 5997: - case 6001 ... 6001: - case 6004 ... 6015: - case 6110 ... 6111: - case 6122 ... 6127: - case 6138 ... 6143: - case 6158 ... 6159: - case 6170 ... 6175: - case 6264 ... 6271: - case 6315 ... 6319: - case 6390 ... 6399: - case 6431 ... 6431: - case 6444 ... 6447: - case 6460 ... 6463: - case 6465 ... 6467: - case 6510 ... 6511: - case 6517 ... 6527: - case 6572 ... 6575: - case 6602 ... 6607: - case 6619 ... 6621: - case 6684 ... 6685: - case 6751 ... 6751: - case 6781 ... 6782: - case 6794 ... 6799: - case 6810 ... 6815: - case 6830 ... 6831: - case 6847 ... 6911: - case 6988 ... 6991: - case 7037 ... 7039: - case 7156 ... 7163: - case 7224 ... 7226: - case 7242 ... 7244: - case 7296 ... 7359: - case 7368 ... 7375: - case 7415 ... 7415: - case 7418 ... 7423: - case 7670 ... 7675: - case 7958 ... 7959: - case 7966 ... 7967: - case 8006 ... 8007: - case 8014 ... 8015: - case 8024 ... 8024: - case 8026 ... 8026: - case 8028 ... 8028: - case 8030 ... 8030: - case 8062 ... 8063: - case 8117 ... 8117: - case 8133 ... 8133: - case 8148 ... 8149: - case 8156 ... 8156: - case 8176 ... 8177: - case 8181 ... 8181: - case 8191 ... 8191: - case 8203 ... 8207: - case 8232 ... 8238: - case 8288 ... 8303: - case 8306 ... 8307: - case 8335 ... 8335: - case 8349 ... 8351: - case 8382 ... 8399: - case 8433 ... 8447: - case 8586 ... 8591: - case 9211 ... 9215: - case 9255 ... 9279: - case 9291 ... 9311: - case 11124 ... 11125: - case 11158 ... 11159: - case 11194 ... 11196: - case 11209 ... 11209: - case 11218 ... 11263: - case 11311 ... 11311: - case 11359 ... 11359: - case 11508 ... 11512: - case 11558 ... 11558: - case 11560 ... 11564: - case 11566 ... 11567: - case 11624 ... 11630: - case 11633 ... 11646: - case 11671 ... 11679: - case 11687 ... 11687: - case 11695 ... 11695: - case 11703 ... 11703: - case 11711 ... 11711: - case 11719 ... 11719: - case 11727 ... 11727: - case 11735 ... 11735: - case 11743 ... 11743: - case 11843 ... 11903: - case 11930 ... 11930: - case 12020 ... 12031: - case 12246 ... 12271: - case 12284 ... 12287: - case 12352 ... 12352: - case 12439 ... 12440: - case 12544 ... 12548: - case 12590 ... 12592: - case 12687 ... 12687: - case 12731 ... 12735: - case 12772 ... 12783: - case 12831 ... 12831: - case 13055 ... 13055: - case 19894 ... 19903: - case 40909 ... 40959: - case 42125 ... 42127: - case 42183 ... 42191: - case 42540 ... 42559: - case 42654 ... 42654: - case 42744 ... 42751: - case 42895 ... 42895: - case 42926 ... 42927: - case 42930 ... 42998: - case 43052 ... 43055: - case 43066 ... 43071: - case 43128 ... 43135: - case 43205 ... 43213: - case 43226 ... 43231: - case 43260 ... 43263: - case 43348 ... 43358: - case 43389 ... 43391: - case 43470 ... 43470: - case 43482 ... 43485: - case 43519 ... 43519: - case 43575 ... 43583: - case 43598 ... 43599: - case 43610 ... 43611: - case 43715 ... 43738: - case 43767 ... 43776: - case 43783 ... 43784: - case 43791 ... 43792: - case 43799 ... 43807: - case 43815 ... 43815: - case 43823 ... 43823: - case 43872 ... 43875: - case 43878 ... 43967: - case 44014 ... 44015: - case 44026 ... 44031: - case 55204 ... 55215: - case 55239 ... 55242: - case 55292 ... 55295: - case 57344 ... 63743: - case 64110 ... 64111: - case 64218 ... 64255: - case 64263 ... 64274: - case 64280 ... 64284: - case 64311 ... 64311: - case 64317 ... 64317: - case 64319 ... 64319: - case 64322 ... 64322: - case 64325 ... 64325: - case 64450 ... 64466: - case 64832 ... 64847: - case 64912 ... 64913: - case 64968 ... 65007: - case 65022 ... 65023: - case 65050 ... 65055: - case 65070 ... 65071: - case 65107 ... 65107: - case 65127 ... 65127: - case 65132 ... 65135: - case 65141 ... 65141: - case 65277 ... 65280: - case 65471 ... 65473: - case 65480 ... 65481: - case 65488 ... 65489: - case 65496 ... 65497: - case 65501 ... 65503: - case 65511 ... 65511: - case 65519 ... 65531: - case 65534 ... 65535: - print_str_char_u(c); - break; - case 65548 ... 65548: - case 65575 ... 65575: - case 65595 ... 65595: - case 65598 ... 65598: - case 65614 ... 65615: - case 65630 ... 65663: - case 65787 ... 65791: - case 65795 ... 65798: - case 65844 ... 65846: - case 65933 ... 65935: - case 65948 ... 65951: - case 65953 ... 65999: - case 66046 ... 66175: - case 66205 ... 66207: - case 66257 ... 66271: - case 66300 ... 66303: - case 66340 ... 66351: - case 66379 ... 66383: - case 66427 ... 66431: - case 66462 ... 66462: - case 66500 ... 66503: - case 66518 ... 66559: - case 66718 ... 66719: - case 66730 ... 66815: - case 66856 ... 66863: - case 66916 ... 66926: - case 66928 ... 67071: - case 67383 ... 67391: - case 67414 ... 67423: - case 67432 ... 67583: - case 67590 ... 67591: - case 67593 ... 67593: - case 67638 ... 67638: - case 67641 ... 67643: - case 67645 ... 67646: - case 67670 ... 67670: - case 67743 ... 67750: - case 67760 ... 67839: - case 67868 ... 67870: - case 67898 ... 67902: - case 67904 ... 67967: - case 68024 ... 68029: - case 68032 ... 68095: - case 68100 ... 68100: - case 68103 ... 68107: - case 68116 ... 68116: - case 68120 ... 68120: - case 68148 ... 68151: - case 68155 ... 68158: - case 68168 ... 68175: - case 68185 ... 68191: - case 68256 ... 68287: - case 68327 ... 68330: - case 68343 ... 68351: - case 68406 ... 68408: - case 68438 ... 68439: - case 68467 ... 68471: - case 68498 ... 68504: - case 68509 ... 68520: - case 68528 ... 68607: - case 68681 ... 69215: - case 69247 ... 69631: - case 69710 ... 69713: - case 69744 ... 69758: - case 69821 ... 69821: - case 69826 ... 69839: - case 69865 ... 69871: - case 69882 ... 69887: - case 69941 ... 69941: - case 69956 ... 69967: - case 70007 ... 70015: - case 70089 ... 70092: - case 70094 ... 70095: - case 70107 ... 70112: - case 70133 ... 70143: - case 70162 ... 70162: - case 70206 ... 70319: - case 70379 ... 70383: - case 70394 ... 70400: - case 70404 ... 70404: - case 70413 ... 70414: - case 70417 ... 70418: - case 70441 ... 70441: - case 70449 ... 70449: - case 70452 ... 70452: - case 70458 ... 70459: - case 70469 ... 70470: - case 70473 ... 70474: - case 70478 ... 70486: - case 70488 ... 70492: - case 70500 ... 70501: - case 70509 ... 70511: - case 70517 ... 70783: - case 70856 ... 70863: - case 70874 ... 71039: - case 71094 ... 71095: - case 71114 ... 71167: - case 71237 ... 71247: - case 71258 ... 71295: - case 71352 ... 71359: - case 71370 ... 71839: - case 71923 ... 71934: - case 71936 ... 72383: - case 72441 ... 73727: - case 74649 ... 74751: - case 74863 ... 74863: - case 74869 ... 77823: - case 78895 ... 92159: - case 92729 ... 92735: - case 92767 ... 92767: - case 92778 ... 92781: - case 92784 ... 92879: - case 92910 ... 92911: - case 92918 ... 92927: - case 92998 ... 93007: - case 93018 ... 93018: - case 93026 ... 93026: - case 93048 ... 93052: - case 93072 ... 93951: - case 94021 ... 94031: - case 94079 ... 94094: - case 94112 ... 110591: - case 110594 ... 113663: - case 113771 ... 113775: - case 113789 ... 113791: - case 113801 ... 113807: - case 113818 ... 113819: - case 113824 ... 118783: - case 119030 ... 119039: - case 119079 ... 119080: - case 119155 ... 119162: - case 119262 ... 119295: - case 119366 ... 119551: - case 119639 ... 119647: - case 119666 ... 119807: - case 119893 ... 119893: - case 119965 ... 119965: - case 119968 ... 119969: - case 119971 ... 119972: - case 119975 ... 119976: - case 119981 ... 119981: - case 119994 ... 119994: - case 119996 ... 119996: - case 120004 ... 120004: - case 120070 ... 120070: - case 120075 ... 120076: - case 120085 ... 120085: - case 120093 ... 120093: - case 120122 ... 120122: - case 120127 ... 120127: - case 120133 ... 120133: - case 120135 ... 120137: - case 120145 ... 120145: - case 120486 ... 120487: - case 120780 ... 120781: - case 120832 ... 124927: - case 125125 ... 125126: - case 125143 ... 126463: - case 126468 ... 126468: - case 126496 ... 126496: - case 126499 ... 126499: - case 126501 ... 126502: - case 126504 ... 126504: - case 126515 ... 126515: - case 126520 ... 126520: - case 126522 ... 126522: - case 126524 ... 126529: - case 126531 ... 126534: - case 126536 ... 126536: - case 126538 ... 126538: - case 126540 ... 126540: - case 126544 ... 126544: - case 126547 ... 126547: - case 126549 ... 126550: - case 126552 ... 126552: - case 126554 ... 126554: - case 126556 ... 126556: - case 126558 ... 126558: - case 126560 ... 126560: - case 126563 ... 126563: - case 126565 ... 126566: - case 126571 ... 126571: - case 126579 ... 126579: - case 126584 ... 126584: - case 126589 ... 126589: - case 126591 ... 126591: - case 126602 ... 126602: - case 126620 ... 126624: - case 126628 ... 126628: - case 126634 ... 126634: - case 126652 ... 126703: - case 126706 ... 126975: - case 127020 ... 127023: - case 127124 ... 127135: - case 127151 ... 127152: - case 127168 ... 127168: - case 127184 ... 127184: - case 127222 ... 127231: - case 127245 ... 127247: - case 127279 ... 127279: - case 127340 ... 127343: - case 127387 ... 127461: - case 127491 ... 127503: - case 127547 ... 127551: - case 127561 ... 127567: - case 127570 ... 127743: - case 127789 ... 127791: - case 127870 ... 127871: - case 127951 ... 127955: - case 127992 ... 127999: - case 128255 ... 128255: - case 128331 ... 128335: - case 128378 ... 128378: - case 128420 ... 128420: - case 128579 ... 128580: - case 128720 ... 128735: - case 128749 ... 128751: - case 128756 ... 128767: - case 128884 ... 128895: - case 128981 ... 129023: - case 129036 ... 129039: - case 129096 ... 129103: - case 129114 ... 129119: - case 129160 ... 129167: - case 129198 ... 131071: - case 173783 ... 173823: - case 177973 ... 177983: - case 178206 ... 194559: - case 195102 ... 917759: - case 918000 ... 1114110: - print_str_char_U(c); - break; - default: - print_codepoint(c); - break; - } -} - -void print_char(val_char_t c) -{ - printf("#\\"); - switch (c) { - case 0: - printf("nul"); break; - case 8: - printf("backspace"); break; - case 9: - printf("tab"); break; - case 10: - printf("newline"); break; - case 11: - printf("vtab"); break; - case 12: - printf("page"); break; - case 13: - printf("return"); break; - case 32: - printf("space"); break; - case 127: - printf("rubout"); break; - default: - print_codepoint(c); - } -} - -void print_codepoint(val_char_t c) -{ - char buffer[5] = {0}; - utf8_encode_char(c, buffer); - printf("%s", buffer); -} - -int utf8_encode_char(val_char_t c, char *buffer) -{ - // Output to buffer using UTF-8 encoding of codepoint - // https://en.wikipedia.org/wiki/UTF-8 - if (c < 128) { - buffer[0] = (char) c; - return 1; - } else if (c < 2048) { - buffer[0] = (char)(c >> 6) | 192; - buffer[1] = ((char) c & 63) | 128; - return 2; - } else if (c < 65536) { - buffer[0] = (char)(c >> 12) | 224; - buffer[1] = ((char)(c >> 6) & 63) | 128; - buffer[2] = ((char) c & 63) | 128; - return 3; - } else { - buffer[0] = (char)(c >> 18) | 240; - buffer[1] = ((char)(c >> 12) & 63) | 128; - buffer[2] = ((char)(c >> 6) & 63) | 128; - buffer[3] = ((char) c & 63) | 128; - return 4; - } -} diff --git a/iniquity-gc/run.rkt b/iniquity-gc/run.rkt deleted file mode 100644 index eaa53eb..0000000 --- a/iniquity-gc/run.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide run run/io) -(require "types.rkt" "build-runtime.rkt" - a86/interp) - -;; Asm -> Answer -(define (run is) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp is) - ['err 'err] - [b (bits->value b)]))) - -;; Asm String -> (cons Answer String) -(define (run/io is s) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp/io is s) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) diff --git a/iniquity-gc/runtime.h b/iniquity-gc/runtime.h deleted file mode 100644 index 6588ad1..0000000 --- a/iniquity-gc/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H -int64_t entry(); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern int64_t *heap; -extern val_t *from; -extern val_t *to; - -extern type_t *types; -#endif /* RUNTIME_H */ diff --git a/iniquity-gc/test/all.rkt b/iniquity-gc/test/all.rkt deleted file mode 100644 index f880d50..0000000 --- a/iniquity-gc/test/all.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang racket - -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit "../../test-programs/get-progs.rkt") -(for-each test-prog (get-progs "iniquity")) diff --git a/iniquity-gc/test/compile.rkt b/iniquity-gc/test/compile.rkt deleted file mode 100644 index 9a9d707..0000000 --- a/iniquity-gc/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../run.rkt") - -(test-runner (λ p (run (compile (parse p))))) -;(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/iniquity-gc/test/interp.rkt b/iniquity-gc/test/interp.rkt deleted file mode 100644 index cd7b654..0000000 --- a/iniquity-gc/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/iniquity-gc/test/test-runner.rkt b/iniquity-gc/test/test-runner.rkt deleted file mode 100644 index 7c044cd..0000000 --- a/iniquity-gc/test/test-runner.rkt +++ /dev/null @@ -1,312 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err) - - (check-equal? (run '(collect-garbage)) (void)) - (check-equal? (run '(begin (box 0) (collect-garbage))) (void)) - (check-equal? (run '(begin (collect-garbage) (box 0))) (box 0)) - (check-equal? (run '(let ((x (box 0))) (collect-garbage))) (void)) - (check-equal? (run '(let ((x (box 0))) - (begin (collect-garbage) - x))) - (box 0)) - ;; GC tests - (check-equal? (run - '(define (n-boxes n) - (if (zero? n) - (void) - (begin (box 0) - (n-boxes (sub1 n))))) - '(n-boxes 10001)) - (void)) - - ;; can't test this in the interpreter, because it doesn't exhaust the heap there. - #; - (check-equal? (run - '(define (nested-boxes n) - (if (zero? n) - (void) - (box (nested-boxes (sub1 n))))) - '(begin (nested-boxes 10001) (void))) - 'err) - ) - - - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz")) - - (check-equal? (run "" - '(define (f x) - (write-byte x)) - '(f 97)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x y) - (write-byte x)) - '(f 97 98)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x) - (let ((y x)) - (write-byte y))) - '(f 97)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x y) - (let ((y x)) - (write-byte y))) - '(f 97 98)) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x) - (write-byte x)) - '(let ((z 97)) - (f z))) - (cons (void) "a")) - (check-equal? (run "" - '(define (f x y) - (write-byte x)) - '(let ((z 97)) - (f z 98))) - (cons (void) "a"))) - - diff --git a/iniquity-gc/values.c b/iniquity-gc/values.c deleted file mode 100644 index df54ade..0000000 --- a/iniquity-gc/values.c +++ /dev/null @@ -1,143 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" - -type_t val_typeof(val_t x) -{ - switch (x & ptr_type_mask) { - case box_type_tag: - return T_BOX; - case cons_type_tag: - return T_CONS; - case vect_type_tag: - return T_VECT; - case str_type_tag: - return T_STR; - } - - if ((int_type_mask & x) == int_type_tag) - return T_INT; - if ((char_type_mask & x) == char_type_tag) - return T_CHAR; - - switch (x) { - case val_true: - case val_false: - return T_BOOL; - case val_eof: - return T_EOF; - case val_void: - return T_VOID; - case val_empty: - return T_EMPTY; - } - - return T_INVALID; -} - -val_t* val_unwrap(val_t v) { - return (val_t*)((v >> imm_shift) << imm_shift); -} - -int64_t type_tag(type_t t) { - switch (t) { - case T_BOX: - return box_type_tag; - case T_CONS: - return cons_type_tag; - case T_STR: - return str_type_tag; - case T_VECT: - return vect_type_tag; - default: - printf("type_tag called on non-pointer type"); - exit(1); - } -} - -int val_size(val_t *v, type_t t) { - switch (t) { - case T_CONS: return 2; - case T_VECT: return 1 + v[0]; - case T_STR: return 1 + ((v[0] + 1) / 2); - default: return 1; - } -}; - -val_t val_wrap(val_t* v, type_t t) { - return (val_t)((int64_t)v ^ type_tag(t)); -} - -int64_t val_unwrap_int(val_t x) -{ - return x >> int_shift; -} -val_t val_wrap_int(int64_t i) -{ - return (i << int_shift) | int_type_tag; -} - -int val_unwrap_bool(val_t x) -{ - return x == val_true; -} -val_t val_wrap_bool(int b) -{ - return b ? val_true : val_false; -} - -val_char_t val_unwrap_char(val_t x) -{ - return (val_char_t)(x >> char_shift); -} -val_t val_wrap_char(val_char_t c) -{ - return (((val_t)c) << char_shift) | char_type_tag; -} - -val_t val_wrap_eof(void) -{ - return val_eof; -} - -val_t val_wrap_void(void) -{ - return val_void; -} - -val_box_t* val_unwrap_box(val_t x) -{ - return (val_box_t *)(x ^ box_type_tag); -} -val_t val_wrap_box(val_box_t* b) -{ - return ((val_t)b) | box_type_tag; -} - -val_cons_t* val_unwrap_cons(val_t x) -{ - return (val_cons_t *)(x ^ cons_type_tag); -} -val_t val_wrap_cons(val_cons_t *c) -{ - return ((val_t)c) | cons_type_tag; -} - -val_vect_t* val_unwrap_vect(val_t x) -{ - return (val_vect_t *)(x ^ vect_type_tag); -} -val_t val_wrap_vect(val_vect_t *v) -{ - return ((val_t)v) | vect_type_tag; -} - -val_str_t* val_unwrap_str(val_t x) -{ - return (val_str_t *)(x ^ str_type_tag); -} -val_t val_wrap_str(val_str_t *v) -{ - return ((val_t)v) | str_type_tag; -} diff --git a/iniquity-gc/values.h b/iniquity-gc/values.h deleted file mode 100644 index 00f7070..0000000 --- a/iniquity-gc/values.h +++ /dev/null @@ -1,80 +0,0 @@ -#ifndef VALUES_H -#define VALUES_H - -#include - -/* any abstract value */ -typedef int64_t val_t; - -typedef enum type_t { - T_INVALID = -1, - /* immediates */ - T_INT, - T_BOOL, - T_CHAR, - T_EOF, - T_VOID, - T_EMPTY, - /* pointers */ - T_BOX, - T_CONS, - T_VECT, - T_STR, -} type_t; - -typedef uint32_t val_char_t; -typedef struct val_box_t { - val_t val; -} val_box_t; -typedef struct val_cons_t { - val_t snd; - val_t fst; -} val_cons_t; -typedef struct val_vect_t { - uint64_t len; - val_t elems[]; -} val_vect_t; -typedef struct val_str_t { - uint64_t len; - val_char_t codepoints[]; -} val_str_t; - -/* return the type of x */ -type_t val_typeof(val_t x); - -/** - * Wrap/unwrap values - * - * The behavior of unwrap functions are undefined on type mismatch. - */ -val_t* val_unwrap(val_t v); // v is a pointer type value -val_t val_wrap(val_t* v, type_t t); - -int val_size(val_t *v, type_t t); - -int64_t val_unwrap_int(val_t x); -val_t val_wrap_int(int64_t i); - -int val_unwrap_bool(val_t x); -val_t val_wrap_bool(int b); - -val_char_t val_unwrap_char(val_t x); -val_t val_wrap_char(val_char_t b); - -val_t val_wrap_eof(); - -val_t val_wrap_void(); - -val_box_t* val_unwrap_box(val_t x); -val_t val_wrap_box(val_box_t* b); - -val_cons_t* val_unwrap_cons(val_t x); -val_t val_wrap_cons(val_cons_t* c); - -val_vect_t* val_unwrap_vect(val_t x); -val_t val_wrap_vect(val_vect_t* c); - -val_str_t* val_unwrap_str(val_t x); -val_t val_wrap_str(val_str_t* c); - -#endif diff --git a/iniquity/build-runtime.rkt b/iniquity/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/iniquity/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/hoax/assert.rkt b/iniquity/compiler/assert.rkt similarity index 97% rename from hoax/assert.rkt rename to iniquity/compiler/assert.rkt index cfc110a..380fc8d 100644 --- a/hoax/assert.rkt +++ b/iniquity/compiler/assert.rkt @@ -3,7 +3,7 @@ assert-box assert-cons assert-natural assert-vector assert-string) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") (define (assert-type mask type) (λ (r) diff --git a/knock/compile-ops.rkt b/iniquity/compiler/compile-ops.rkt similarity index 97% rename from knock/compile-ops.rkt rename to iniquity/compiler/compile-ops.rkt index 1bb76cb..1a58a86 100644 --- a/knock/compile-ops.rkt +++ b/iniquity/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) @@ -222,8 +222,8 @@ (Mov r9 (Mem r8 (- type-vect))) (Cmp r10 r9) (Jge 'err) - (Sar r10 1) ; convert to byte offset - (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) (Mov rax (value->bits (void))))])) (define (type-pred mask type) diff --git a/iniquity/compile-stdin.rkt b/iniquity/compiler/compile-stdin.rkt similarity index 79% rename from iniquity/compile-stdin.rkt rename to iniquity/compiler/compile-stdin.rkt index ed18b5e..f25989a 100644 --- a/iniquity/compile-stdin.rkt +++ b/iniquity/compiler/compile-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") (require a86/printer) ;; -> Void diff --git a/iniquity/compile.rkt b/iniquity/compiler/compile.rkt similarity index 96% rename from iniquity/compile.rkt rename to iniquity/compiler/compile.rkt index 55f8fa9..b585409 100644 --- a/iniquity/compile.rkt +++ b/iniquity/compiler/compile.rkt @@ -7,9 +7,9 @@ ; for notes (provide rsp) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Prog -> Asm @@ -19,11 +19,13 @@ (prog (Global 'entry) (Label 'entry) (Push rbx) ; save callee-saved register + (Push r15) (Mov rbx rdi) ; recv heap pointer (compile-e e '()) (Pop r15) ; restore callee-save register + (Pop rbx) (Ret) (compile-defines ds) @@ -48,6 +50,8 @@ (match d [(Defn f xs e) (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) ; arity check + (Jne 'err) (compile-e e (reverse xs)) (Add rsp (* 8 (length xs))) ; pop args (Ret))])) @@ -158,6 +162,7 @@ (seq (Lea rax r) (Push rax) (compile-es es (cons #f c)) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)) (Label r)))) diff --git a/iniquity/correct.rkt b/iniquity/correct.rkt index d286ba1..1a7846d 100644 --- a/iniquity/correct.rkt +++ b/iniquity/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/iniquity/exec-io.rkt b/iniquity/exec-io.rkt deleted file mode 100644 index fb1d306..0000000 --- a/iniquity/exec-io.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile p) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/iniquity/exec.rkt b/iniquity/exec.rkt deleted file mode 100644 index 59f36bf..0000000 --- a/iniquity/exec.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Prog -> Answer -(define (exec p) - (run (compile p))) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (run/io (compile p) in)) - diff --git a/iniquity/executor/decode.rkt b/iniquity/executor/decode.rkt new file mode 100644 index 0000000..6ee214f --- /dev/null +++ b/iniquity/executor/decode.rkt @@ -0,0 +1,45 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (mem-ref (- b type-box))))] + [(cons-bits? b) + (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) + (bits->value (mem-ref (+ 8 (- b type-cons)))))] + + [(vect-bits? b) + (let ((p (- b type-vect))) + (build-vector (bits->value (mem-ref p)) + (lambda (j) + (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] + [(str-bits? b) + (let ((p (- b type-str))) + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] + [else (error "invalid bits")])) + +(define (mem-ref i) + (ptr-ref (cast i _int64 _pointer) _int64)) + +(define (mem-ref32 i) + (ptr-ref (cast i _int64 _pointer) _int32)) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/iniquity/executor/exec.rkt b/iniquity/executor/exec.rkt new file mode 100644 index 0000000..cd5745e --- /dev/null +++ b/iniquity/executor/exec.rkt @@ -0,0 +1,55 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (exec/state prog) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/iniquity/executor/run-stdin.rkt b/iniquity/executor/run-stdin.rkt new file mode 100644 index 0000000..ac60d60 --- /dev/null +++ b/iniquity/executor/run-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + + (run (compile (parse (read))))) + diff --git a/iniquity/executor/run.rkt b/iniquity/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/iniquity/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/iniquity/interp-prims.rkt b/iniquity/interp-prims.rkt deleted file mode 100644 index 4cbabc6..0000000 --- a/iniquity/interp-prims.rkt +++ /dev/null @@ -1,69 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [(list 'vector? v) (vector? v)] - [(list 'vector-length (? vector?)) (vector-length v)] - [(list 'string? v) (string? v)] - [(list 'string-length (? string?)) (string-length v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] - [(list 'make-vector (? integer?) _) - (if (<= 0 v1) - (make-vector v1 v2) - 'err)] - [(list 'vector-ref (? vector?) (? integer?)) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-ref v1 v2) - 'err)] - [(list 'make-string (? integer?) (? char?)) - (if (<= 0 v1) - (make-string v1 v2) - 'err)] - [(list 'string-ref (? string?) (? integer?)) - (if (<= 0 v2 (sub1 (string-length v1))) - (string-ref v1 v2) - 'err)] - [_ 'err])) - -;; Op3 Value Value Value -> Answer -(define (interp-prim3 p v1 v2 v3) - (match (list p v1 v2 v3) - [(list 'vector-set! (? vector?) (? integer?) _) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/iniquity/env.rkt b/iniquity/interpreter/env.rkt similarity index 100% rename from iniquity/env.rkt rename to iniquity/interpreter/env.rkt diff --git a/iniquity/interp-io.rkt b/iniquity/interpreter/interp-io.rkt similarity index 100% rename from iniquity/interp-io.rkt rename to iniquity/interpreter/interp-io.rkt diff --git a/iniquity/interp-prim.rkt b/iniquity/interpreter/interp-prim.rkt similarity index 100% rename from iniquity/interp-prim.rkt rename to iniquity/interpreter/interp-prim.rkt diff --git a/iniquity/interp-stdin.rkt b/iniquity/interpreter/interp-stdin.rkt similarity index 78% rename from iniquity/interp-stdin.rkt rename to iniquity/interpreter/interp-stdin.rkt index df745af..7d85c32 100644 --- a/iniquity/interp-stdin.rkt +++ b/iniquity/interpreter/interp-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") ;; -> Void ;; Parse and interpret contents of stdin, diff --git a/jig/interp.rkt b/iniquity/interpreter/interp.rkt similarity index 98% rename from jig/interp.rkt rename to iniquity/interpreter/interp.rkt index 80f12e9..65a23b8 100644 --- a/jig/interp.rkt +++ b/iniquity/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/iniquity/io.c b/iniquity/io.c deleted file mode 100644 index 8a417c9..0000000 --- a/iniquity/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/iniquity/main.c b/iniquity/main.c deleted file mode 100644 index 4fcd8b6..0000000 --- a/iniquity/main.c +++ /dev/null @@ -1,41 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/iniquity/main.rkt b/iniquity/main.rkt index 50cf56e..f9851a3 100644 --- a/iniquity/main.rkt +++ b/iniquity/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/iniquity/run.rkt b/iniquity/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/iniquity/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/iniquity/runtime.h b/iniquity/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/iniquity/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/iniquity/runtime/Makefile b/iniquity/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/iniquity/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/iniquity/runtime/error.c b/iniquity/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/iniquity/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/iniquity/runtime/io.c b/iniquity/runtime/io.c new file mode 100644 index 0000000..139dccb --- /dev/null +++ b/iniquity/runtime/io.c @@ -0,0 +1,25 @@ +#include +#include +#include "types.h" +#include "values.h" +#include "runtime.h" + +val_t read_byte(void) +{ + char c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); +} + +val_t peek_byte(void) +{ + char c = getc(stdin); + ungetc(c, stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); + +} + +val_t write_byte(val_t c) +{ + putc((char) val_unwrap_int(c), stdout); + return val_wrap_void(); +} diff --git a/iniquity/runtime/main.c b/iniquity/runtime/main.c new file mode 100644 index 0000000..6fa3ab3 --- /dev/null +++ b/iniquity/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/iniquity/print.c b/iniquity/runtime/print.c similarity index 100% rename from iniquity/print.c rename to iniquity/runtime/print.c diff --git a/iniquity-gc/print.h b/iniquity/runtime/print.h similarity index 100% rename from iniquity-gc/print.h rename to iniquity/runtime/print.h diff --git a/iniquity/runtime/runtime.h b/iniquity/runtime/runtime.h new file mode 100644 index 0000000..ec422c7 --- /dev/null +++ b/iniquity/runtime/runtime.h @@ -0,0 +1,14 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +val_t entry(val_t *heap); + +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/iniquity-gc/types.h b/iniquity/runtime/types.h similarity index 100% rename from iniquity-gc/types.h rename to iniquity/runtime/types.h diff --git a/iniquity/runtime/types.rkt b/iniquity/runtime/types.rkt new file mode 100644 index 0000000..b9198f9 --- /dev/null +++ b/iniquity/runtime/types.rkt @@ -0,0 +1,52 @@ +#lang racket +(provide (all-defined-out)) + +(define imm-shift 3) +(define imm-mask #b111) +(define ptr-mask #b111) +(define type-box #b001) +(define type-cons #b010) +(define type-vect #b011) +(define type-str #b100) +(define int-shift (+ 1 imm-shift)) +(define mask-int #b1111) +(define char-shift (+ 2 imm-shift)) +(define type-int #b0000) +(define type-char #b01000) +(define mask-char #b11111) + +;; Value -> Integer +;; v must be an immediate +(define (value->bits v) + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eq? v eof) #b01011000] + [(eq? v (void)) #b01111000] + [(eq? v '()) #b10011000] + [(integer? v) (arithmetic-shift v int-shift)] + [(char? v) + (bitwise-ior type-char + (arithmetic-shift (char->integer v) char-shift))] + [else (error "not an immediate value" v)])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + +(define (char-bits? v) + (= type-char (bitwise-and v mask-char))) + +(define (imm-bits? v) + (zero? (bitwise-and v imm-mask))) + +(define (cons-bits? v) + (= type-cons (bitwise-and v imm-mask))) + +(define (box-bits? v) + (= type-box (bitwise-and v imm-mask))) + +(define (vect-bits? v) + (= type-vect (bitwise-and v imm-mask))) + +(define (str-bits? v) + (= type-str (bitwise-and v imm-mask))) + diff --git a/iniquity/values.c b/iniquity/runtime/values.c similarity index 100% rename from iniquity/values.c rename to iniquity/runtime/values.c diff --git a/iniquity/values.h b/iniquity/runtime/values.h similarity index 100% rename from iniquity/values.h rename to iniquity/runtime/values.h diff --git a/iniquity/ast.rkt b/iniquity/syntax/ast.rkt similarity index 100% rename from iniquity/ast.rkt rename to iniquity/syntax/ast.rkt diff --git a/iniquity/parse.rkt b/iniquity/syntax/parse.rkt similarity index 98% rename from iniquity/parse.rkt rename to iniquity/syntax/parse.rkt index 02df181..da4f4a0 100644 --- a/iniquity/parse.rkt +++ b/iniquity/syntax/parse.rkt @@ -35,7 +35,7 @@ (define (rec ss fs) (match ss [(list s) fs] - [(cons (cons 'define sd) sr) + [(cons (cons (? (not-in fs) 'define) sd) sr) (match (parse-defn-name sd) [f (if (memq f fs) (error "duplicate definition" f) @@ -101,7 +101,7 @@ (list ys gs (Eof))] [(? datum?) (list ys gs (Lit s))] - [(list 'quote (list)) + [(list (and 'quote (? (not-in ns))) (list)) (list ys gs (Lit '()))] [(? symbol? (? (not-in fs))) (if (memq s xs) @@ -138,7 +138,7 @@ (list ys (cons g gs) (App g es))])])])] [(list-rest (? symbol? g) sr) (match (parse-es/acc sr fs xs ys gs) - [(list ys s es) + [(list ys gs es) (list ys (if (memq g fs) gs (cons g gs)) (App g es))])] [_ (error "parse error" s)])) diff --git a/iniquity/read-all.rkt b/iniquity/syntax/read-all.rkt similarity index 100% rename from iniquity/read-all.rkt rename to iniquity/syntax/read-all.rkt diff --git a/iniquity/test/all.rkt b/iniquity/test/all.rkt deleted file mode 100644 index f880d50..0000000 --- a/iniquity/test/all.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang racket - -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit "../../test-programs/get-progs.rkt") -(for-each test-prog (get-progs "iniquity")) diff --git a/iniquity/test/compile.rkt b/iniquity/test/compile.rkt deleted file mode 100644 index 2096b58..0000000 --- a/iniquity/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ p (exec (apply parse-closed p)))) -(test/io (λ (in . p) (exec/io (apply parse-closed p) in))) - diff --git a/iniquity/test/test-runner.rkt b/iniquity/test/define-tests.rkt similarity index 97% rename from iniquity/test/test-runner.rkt rename to iniquity/test/define-tests.rkt index d2e9383..9dd225d 100644 --- a/iniquity/test/test-runner.rkt +++ b/iniquity/test/define-tests.rkt @@ -93,7 +93,7 @@ (check-equal? (run '(= (add1 4) 5)) #t) (check-equal? (run '(< 5 5)) #f) (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (check-equal? (run '(< (add1 4) 5)) #f)) (begin ;; Hustle (check-equal? (run '(empty? (cons 1 2))) #f) @@ -201,6 +201,12 @@ '(2 3 4)) (check-equal? (run '(define (f x y) y) '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) 'err))) (define (test/io run) diff --git a/iniquity/test/interp.rkt b/iniquity/test/interp.rkt deleted file mode 100644 index 523685b..0000000 --- a/iniquity/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ p (interp (apply parse-closed p)))) -(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) - diff --git a/iniquity/test/run-compile-tests.rkt b/iniquity/test/run-compile-tests.rkt new file mode 100644 index 0000000..2cf66fd --- /dev/null +++ b/iniquity/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ p (run (compile (apply parse-closed p))))) +(test/io (λ (in . p) (run/io (compile (apply parse-closed p)) in))) + diff --git a/iniquity/test/run-interp-tests.rkt b/iniquity/test/run-interp-tests.rkt new file mode 100644 index 0000000..96137ef --- /dev/null +++ b/iniquity/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ p (interp (apply parse-closed p)))) +(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) + diff --git a/iniquity/test/parse.rkt b/iniquity/test/run-parse-tests.rkt similarity index 78% rename from iniquity/test/parse.rkt rename to iniquity/test/run-parse-tests.rkt index ea9197b..8648a5b 100644 --- a/iniquity/test/parse.rkt +++ b/iniquity/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) @@ -47,7 +47,7 @@ (check-equal? (parse "asdf") (p (Lit "asdf"))) (check-equal? (parse '(make-string 10 #\a)) (p (Prim2 'make-string (Lit 10) (Lit #\a))))) - + (begin ; Iniquity (check-equal? (parse '(define (f x) x) 1) (Prog (list (Defn 'f '(x) (Var 'x))) (Lit 1))) @@ -55,10 +55,20 @@ (Prog (list (Defn 'define '() (Lit 0))) (App 'define '()))) (check-exn exn:fail? (λ () (parse '(define (f y y) y) 1))) + (check-exn exn:fail? (λ () (parse '(define (f y) y) '(define (f x) x) 1))) (check-equal? (parse-closed '(define (f x) (g x)) '(define (g x) (f x)) '(f 0)) (Prog (list (Defn 'f '(x) (App 'g (list (Var 'x)))) (Defn 'g '(x) (App 'f (list (Var 'x))))) - (App 'f (list (Lit 0)))))) + (App 'f (list (Lit 0))))) + (check-equal? (parse '(define (define x) x) + '(define 1)) + (Prog (list (Defn 'define '(x) (Var 'x))) + (App 'define (list (Lit 1))))) + (check-exn exn:fail? (λ () (parse '(define (define x) x) + '(define (g x) x) + '(define (g 1))))) + (check-exn exn:fail? (λ () (parse-closed '(define (f x) 0) + '(f (g)))))) diff --git a/jig/build-runtime.rkt b/jig/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/jig/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/jig/assert.rkt b/jig/compiler/assert.rkt similarity index 97% rename from jig/assert.rkt rename to jig/compiler/assert.rkt index cfc110a..380fc8d 100644 --- a/jig/assert.rkt +++ b/jig/compiler/assert.rkt @@ -3,7 +3,7 @@ assert-box assert-cons assert-natural assert-vector assert-string) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") (define (assert-type mask type) (λ (r) diff --git a/hoax/compile-ops.rkt b/jig/compiler/compile-ops.rkt similarity index 97% rename from hoax/compile-ops.rkt rename to jig/compiler/compile-ops.rkt index 1bb76cb..1a58a86 100644 --- a/hoax/compile-ops.rkt +++ b/jig/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) @@ -222,8 +222,8 @@ (Mov r9 (Mem r8 (- type-vect))) (Cmp r10 r9) (Jge 'err) - (Sar r10 1) ; convert to byte offset - (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) (Mov rax (value->bits (void))))])) (define (type-pred mask type) diff --git a/jig/compile-stdin.rkt b/jig/compiler/compile-stdin.rkt similarity index 79% rename from jig/compile-stdin.rkt rename to jig/compiler/compile-stdin.rkt index ed18b5e..f25989a 100644 --- a/jig/compile-stdin.rkt +++ b/jig/compiler/compile-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") (require a86/printer) ;; -> Void diff --git a/jig/compile.rkt b/jig/compiler/compile.rkt similarity index 95% rename from jig/compile.rkt rename to jig/compiler/compile.rkt index 81d7ac5..680a0ec 100644 --- a/jig/compile.rkt +++ b/jig/compiler/compile.rkt @@ -4,9 +4,9 @@ compile-es compile-define) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Prog -> Asm @@ -16,11 +16,13 @@ (prog (Global 'entry) (Label 'entry) (Push rbx) ; save callee-saved register + (Push r15) (Mov rbx rdi) ; recv heap pointer (compile-e e '() #f) (Pop r15) ; restore callee-save register + (Pop rbx) (Ret) (compile-defines ds) @@ -45,6 +47,8 @@ (match d [(Defn f xs e) (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) ; arity check + (Jne 'err) (compile-e e (reverse xs) #t) (Add rsp (* 8 (length xs))) ; pop args (Ret))])) @@ -160,6 +164,7 @@ (seq (compile-es es c) (move-args (length es) (length c)) (Add rsp (* 8 (length c))) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)))) ;; Integer Integer -> Asm @@ -176,6 +181,7 @@ (seq (Lea rax r) (Push rax) (compile-es es (cons #f c)) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)) (Label r)))) diff --git a/jig/correct.rkt b/jig/correct.rkt index d286ba1..1a7846d 100644 --- a/jig/correct.rkt +++ b/jig/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/jig/exec-io.rkt b/jig/exec-io.rkt deleted file mode 100644 index fb1d306..0000000 --- a/jig/exec-io.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile p) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/jig/exec.rkt b/jig/exec.rkt deleted file mode 100644 index 59f36bf..0000000 --- a/jig/exec.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Prog -> Answer -(define (exec p) - (run (compile p))) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (run/io (compile p) in)) - diff --git a/jig/executor/decode.rkt b/jig/executor/decode.rkt new file mode 100644 index 0000000..6ee214f --- /dev/null +++ b/jig/executor/decode.rkt @@ -0,0 +1,45 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (mem-ref (- b type-box))))] + [(cons-bits? b) + (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) + (bits->value (mem-ref (+ 8 (- b type-cons)))))] + + [(vect-bits? b) + (let ((p (- b type-vect))) + (build-vector (bits->value (mem-ref p)) + (lambda (j) + (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] + [(str-bits? b) + (let ((p (- b type-str))) + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] + [else (error "invalid bits")])) + +(define (mem-ref i) + (ptr-ref (cast i _int64 _pointer) _int64)) + +(define (mem-ref32 i) + (ptr-ref (cast i _int64 _pointer) _int32)) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/jig/executor/exec.rkt b/jig/executor/exec.rkt new file mode 100644 index 0000000..cd5745e --- /dev/null +++ b/jig/executor/exec.rkt @@ -0,0 +1,55 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (exec/state prog) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/jig/executor/run-stdin.rkt b/jig/executor/run-stdin.rkt new file mode 100644 index 0000000..ac60d60 --- /dev/null +++ b/jig/executor/run-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + + (run (compile (parse (read))))) + diff --git a/jig/executor/run.rkt b/jig/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/jig/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/jig/env.rkt b/jig/interpreter/env.rkt similarity index 100% rename from jig/env.rkt rename to jig/interpreter/env.rkt diff --git a/jig/interp-io.rkt b/jig/interpreter/interp-io.rkt similarity index 100% rename from jig/interp-io.rkt rename to jig/interpreter/interp-io.rkt diff --git a/jig/interp-prim.rkt b/jig/interpreter/interp-prim.rkt similarity index 100% rename from jig/interp-prim.rkt rename to jig/interpreter/interp-prim.rkt diff --git a/jig/interp-stdin.rkt b/jig/interpreter/interp-stdin.rkt similarity index 78% rename from jig/interp-stdin.rkt rename to jig/interpreter/interp-stdin.rkt index df745af..7d85c32 100644 --- a/jig/interp-stdin.rkt +++ b/jig/interpreter/interp-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") ;; -> Void ;; Parse and interpret contents of stdin, diff --git a/iniquity/interp.rkt b/jig/interpreter/interp.rkt similarity index 98% rename from iniquity/interp.rkt rename to jig/interpreter/interp.rkt index 80f12e9..65a23b8 100644 --- a/iniquity/interp.rkt +++ b/jig/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-e) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/jig/io.c b/jig/io.c deleted file mode 100644 index 8a417c9..0000000 --- a/jig/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/jig/main.c b/jig/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/jig/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/jig/main.rkt b/jig/main.rkt index 50cf56e..f9851a3 100644 --- a/jig/main.rkt +++ b/jig/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/jig/run-stdin.rkt b/jig/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/jig/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/jig/run.rkt b/jig/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/jig/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/jig/runtime.h b/jig/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/jig/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/jig/runtime/Makefile b/jig/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/jig/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/jig/char.c b/jig/runtime/char.c similarity index 100% rename from jig/char.c rename to jig/runtime/char.c diff --git a/jig/runtime/error.c b/jig/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/jig/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/jig/heap.h b/jig/runtime/heap.h similarity index 100% rename from jig/heap.h rename to jig/runtime/heap.h diff --git a/jig/runtime/io.c b/jig/runtime/io.c new file mode 100644 index 0000000..139dccb --- /dev/null +++ b/jig/runtime/io.c @@ -0,0 +1,25 @@ +#include +#include +#include "types.h" +#include "values.h" +#include "runtime.h" + +val_t read_byte(void) +{ + char c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); +} + +val_t peek_byte(void) +{ + char c = getc(stdin); + ungetc(c, stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); + +} + +val_t write_byte(val_t c) +{ + putc((char) val_unwrap_int(c), stdout); + return val_wrap_void(); +} diff --git a/jig/runtime/main.c b/jig/runtime/main.c new file mode 100644 index 0000000..6fa3ab3 --- /dev/null +++ b/jig/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/jig/print.c b/jig/runtime/print.c similarity index 100% rename from jig/print.c rename to jig/runtime/print.c diff --git a/iniquity/print.h b/jig/runtime/print.h similarity index 100% rename from iniquity/print.h rename to jig/runtime/print.h diff --git a/jig/runtime/runtime.h b/jig/runtime/runtime.h new file mode 100644 index 0000000..ec422c7 --- /dev/null +++ b/jig/runtime/runtime.h @@ -0,0 +1,14 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +val_t entry(val_t *heap); + +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/iniquity/types.h b/jig/runtime/types.h similarity index 100% rename from iniquity/types.h rename to jig/runtime/types.h diff --git a/jig/runtime/types.rkt b/jig/runtime/types.rkt new file mode 100644 index 0000000..b9198f9 --- /dev/null +++ b/jig/runtime/types.rkt @@ -0,0 +1,52 @@ +#lang racket +(provide (all-defined-out)) + +(define imm-shift 3) +(define imm-mask #b111) +(define ptr-mask #b111) +(define type-box #b001) +(define type-cons #b010) +(define type-vect #b011) +(define type-str #b100) +(define int-shift (+ 1 imm-shift)) +(define mask-int #b1111) +(define char-shift (+ 2 imm-shift)) +(define type-int #b0000) +(define type-char #b01000) +(define mask-char #b11111) + +;; Value -> Integer +;; v must be an immediate +(define (value->bits v) + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eq? v eof) #b01011000] + [(eq? v (void)) #b01111000] + [(eq? v '()) #b10011000] + [(integer? v) (arithmetic-shift v int-shift)] + [(char? v) + (bitwise-ior type-char + (arithmetic-shift (char->integer v) char-shift))] + [else (error "not an immediate value" v)])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + +(define (char-bits? v) + (= type-char (bitwise-and v mask-char))) + +(define (imm-bits? v) + (zero? (bitwise-and v imm-mask))) + +(define (cons-bits? v) + (= type-cons (bitwise-and v imm-mask))) + +(define (box-bits? v) + (= type-box (bitwise-and v imm-mask))) + +(define (vect-bits? v) + (= type-vect (bitwise-and v imm-mask))) + +(define (str-bits? v) + (= type-str (bitwise-and v imm-mask))) + diff --git a/jig/values.c b/jig/runtime/values.c similarity index 100% rename from jig/values.c rename to jig/runtime/values.c diff --git a/jig/values.h b/jig/runtime/values.h similarity index 100% rename from jig/values.h rename to jig/runtime/values.h diff --git a/jig/ast.rkt b/jig/syntax/ast.rkt similarity index 100% rename from jig/ast.rkt rename to jig/syntax/ast.rkt diff --git a/jig/parse.rkt b/jig/syntax/parse.rkt similarity index 98% rename from jig/parse.rkt rename to jig/syntax/parse.rkt index 511e0bb..3930d04 100644 --- a/jig/parse.rkt +++ b/jig/syntax/parse.rkt @@ -35,7 +35,7 @@ (define (rec ss fs) (match ss [(list s) fs] - [(cons (cons 'define sd) sr) + [(cons (cons (? (not-in fs) 'define) sd) sr) (match (parse-defn-name sd) [f (if (memq f fs) (error "duplicate definition" f) @@ -102,7 +102,7 @@ (list ys gs (Eof))] [(? datum?) (list ys gs (Lit s))] - [(list 'quote (list)) + [(list (and 'quote (? (not-in ns))) (list)) (list ys gs (Lit '()))] [(? symbol? (? (not-in fs))) (if (memq s xs) @@ -139,7 +139,7 @@ (list ys (cons g gs) (App g es))])])])] [(list-rest (? symbol? g) sr) (match (parse-es/acc sr fs xs ys gs) - [(list ys s es) + [(list ys gs es) (list ys (if (memq g fs) gs (cons g gs)) (App g es))])] [_ (error "parse error" s)])) diff --git a/jig/read-all.rkt b/jig/syntax/read-all.rkt similarity index 100% rename from jig/read-all.rkt rename to jig/syntax/read-all.rkt diff --git a/jig/test/build-runtime.rkt b/jig/test/build-runtime.rkt deleted file mode 100644 index 7023ee0..0000000 --- a/jig/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/jig/test/compile.rkt b/jig/test/compile.rkt deleted file mode 100644 index 2096b58..0000000 --- a/jig/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ p (exec (apply parse-closed p)))) -(test/io (λ (in . p) (exec/io (apply parse-closed p) in))) - diff --git a/jig/test/test-runner.rkt b/jig/test/define-tests.rkt similarity index 97% rename from jig/test/test-runner.rkt rename to jig/test/define-tests.rkt index d2e9383..9dd225d 100644 --- a/jig/test/test-runner.rkt +++ b/jig/test/define-tests.rkt @@ -93,7 +93,7 @@ (check-equal? (run '(= (add1 4) 5)) #t) (check-equal? (run '(< 5 5)) #f) (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (check-equal? (run '(< (add1 4) 5)) #f)) (begin ;; Hustle (check-equal? (run '(empty? (cons 1 2))) #f) @@ -201,6 +201,12 @@ '(2 3 4)) (check-equal? (run '(define (f x y) y) '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) 'err))) (define (test/io run) diff --git a/jig/test/interp.rkt b/jig/test/interp.rkt deleted file mode 100644 index 523685b..0000000 --- a/jig/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ p (interp (apply parse-closed p)))) -(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) - diff --git a/jig/test/run-compile-tests.rkt b/jig/test/run-compile-tests.rkt new file mode 100644 index 0000000..2cf66fd --- /dev/null +++ b/jig/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ p (run (compile (apply parse-closed p))))) +(test/io (λ (in . p) (run/io (compile (apply parse-closed p)) in))) + diff --git a/jig/test/run-interp-tests.rkt b/jig/test/run-interp-tests.rkt new file mode 100644 index 0000000..96137ef --- /dev/null +++ b/jig/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ p (interp (apply parse-closed p)))) +(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) + diff --git a/jig/test/parse.rkt b/jig/test/run-parse-tests.rkt similarity index 97% rename from jig/test/parse.rkt rename to jig/test/run-parse-tests.rkt index fd413ee..80fd2e2 100644 --- a/jig/test/parse.rkt +++ b/jig/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) @@ -47,6 +47,7 @@ (check-equal? (parse "asdf") (p (Lit "asdf"))) (check-equal? (parse '(make-string 10 #\a)) (p (Prim2 'make-string (Lit 10) (Lit #\a))))) + (begin ; Iniquity (check-equal? (parse '(define (f x) x) 1) (Prog (list (Defn 'f '(x) (Var 'x))) (Lit 1))) diff --git a/jig/test/test-progs.rkt b/jig/test/test-progs.rkt deleted file mode 100644 index ec1d725..0000000 --- a/jig/test/test-progs.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang racket -;; run command line compiler and compare against Racket as refernece implementation -(require rackunit - "../../test-programs/get-progs.rkt" - "build-runtime.rkt") -(for-each test-prog (get-progs "jig")) diff --git a/knock/build-runtime.rkt b/knock/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/knock/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/knock/assert.rkt b/knock/compiler/assert.rkt similarity index 97% rename from knock/assert.rkt rename to knock/compiler/assert.rkt index cfc110a..380fc8d 100644 --- a/knock/assert.rkt +++ b/knock/compiler/assert.rkt @@ -3,7 +3,7 @@ assert-box assert-cons assert-natural assert-vector assert-string) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") (define (assert-type mask type) (λ (r) diff --git a/jig/compile-ops.rkt b/knock/compiler/compile-ops.rkt similarity index 97% rename from jig/compile-ops.rkt rename to knock/compiler/compile-ops.rkt index 1bb76cb..1a58a86 100644 --- a/jig/compile-ops.rkt +++ b/knock/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) @@ -222,8 +222,8 @@ (Mov r9 (Mem r8 (- type-vect))) (Cmp r10 r9) (Jge 'err) - (Sar r10 1) ; convert to byte offset - (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) (Mov rax (value->bits (void))))])) (define (type-pred mask type) diff --git a/knock/compile-stdin.rkt b/knock/compiler/compile-stdin.rkt similarity index 79% rename from knock/compile-stdin.rkt rename to knock/compiler/compile-stdin.rkt index ed18b5e..f25989a 100644 --- a/knock/compile-stdin.rkt +++ b/knock/compiler/compile-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") (require a86/printer) ;; -> Void diff --git a/knock/compile.rkt b/knock/compiler/compile.rkt similarity index 97% rename from knock/compile.rkt rename to knock/compiler/compile.rkt index 901a033..966e739 100644 --- a/knock/compile.rkt +++ b/knock/compiler/compile.rkt @@ -9,9 +9,9 @@ ; for notes (provide compile-pattern) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") +(require "../runtime/types.rkt") (require a86/ast a86/registers) ;; Prog -> Asm @@ -21,11 +21,13 @@ (prog (Global 'entry) (Label 'entry) (Push rbx) ; save callee-saved register + (Push r15) (Mov rbx rdi) ; recv heap pointer (compile-e e '() #f) (Pop r15) ; restore callee-save register + (Pop rbx) (Ret) (compile-defines ds) @@ -50,6 +52,8 @@ (match d [(Defn f xs e) (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) ; arity check + (Jne 'err) (compile-e e (reverse xs) #t) (Add rsp (* 8 (length xs))) ; pop args (Ret))])) @@ -166,6 +170,7 @@ (seq (compile-es es c) (move-args (length es) (length c)) (Add rsp (* 8 (length c))) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)))) ;; Integer Integer -> Asm @@ -182,6 +187,7 @@ (seq (Lea rax r) (Push rax) (compile-es es (cons #f c)) + (Mov r8 (length es)) ; pass arity info (Jmp (symbol->label f)) (Label r)))) diff --git a/knock/correct.rkt b/knock/correct.rkt index d286ba1..1a7846d 100644 --- a/knock/correct.rkt +++ b/knock/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/knock/exec-io.rkt b/knock/exec-io.rkt deleted file mode 100644 index fb1d306..0000000 --- a/knock/exec-io.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile p) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/knock/exec.rkt b/knock/exec.rkt deleted file mode 100644 index 59f36bf..0000000 --- a/knock/exec.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Prog -> Answer -(define (exec p) - (run (compile p))) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (run/io (compile p) in)) - diff --git a/knock/executor/decode.rkt b/knock/executor/decode.rkt new file mode 100644 index 0000000..6ee214f --- /dev/null +++ b/knock/executor/decode.rkt @@ -0,0 +1,45 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (mem-ref (- b type-box))))] + [(cons-bits? b) + (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) + (bits->value (mem-ref (+ 8 (- b type-cons)))))] + + [(vect-bits? b) + (let ((p (- b type-vect))) + (build-vector (bits->value (mem-ref p)) + (lambda (j) + (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] + [(str-bits? b) + (let ((p (- b type-str))) + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] + [else (error "invalid bits")])) + +(define (mem-ref i) + (ptr-ref (cast i _int64 _pointer) _int64)) + +(define (mem-ref32 i) + (ptr-ref (cast i _int64 _pointer) _int32)) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/knock/executor/exec.rkt b/knock/executor/exec.rkt new file mode 100644 index 0000000..cd5745e --- /dev/null +++ b/knock/executor/exec.rkt @@ -0,0 +1,55 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (exec/state prog) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/knock/executor/run-stdin.rkt b/knock/executor/run-stdin.rkt new file mode 100644 index 0000000..ac60d60 --- /dev/null +++ b/knock/executor/run-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + + (run (compile (parse (read))))) + diff --git a/knock/executor/run.rkt b/knock/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/knock/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/knock/env.rkt b/knock/interpreter/env.rkt similarity index 100% rename from knock/env.rkt rename to knock/interpreter/env.rkt diff --git a/knock/interp-io.rkt b/knock/interpreter/interp-io.rkt similarity index 100% rename from knock/interp-io.rkt rename to knock/interpreter/interp-io.rkt diff --git a/knock/interp-prim.rkt b/knock/interpreter/interp-prim.rkt similarity index 100% rename from knock/interp-prim.rkt rename to knock/interpreter/interp-prim.rkt diff --git a/knock/interp-stdin.rkt b/knock/interpreter/interp-stdin.rkt similarity index 78% rename from knock/interp-stdin.rkt rename to knock/interpreter/interp-stdin.rkt index df745af..7d85c32 100644 --- a/knock/interp-stdin.rkt +++ b/knock/interpreter/interp-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") ;; -> Void ;; Parse and interpret contents of stdin, diff --git a/knock/interp.rkt b/knock/interpreter/interp.rkt similarity index 99% rename from knock/interp.rkt rename to knock/interpreter/interp.rkt index 9b91055..44b91b5 100644 --- a/knock/interp.rkt +++ b/knock/interpreter/interp.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp interp-e) (provide interp-match-pat) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/knock/io.c b/knock/io.c deleted file mode 100644 index 8a417c9..0000000 --- a/knock/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/knock/main.c b/knock/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/knock/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/knock/main.rkt b/knock/main.rkt index 50cf56e..f9851a3 100644 --- a/knock/main.rkt +++ b/knock/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/knock/run-stdin.rkt b/knock/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/knock/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/knock/run.rkt b/knock/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/knock/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/knock/runtime.h b/knock/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/knock/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/knock/runtime/Makefile b/knock/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/knock/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/knock/char.c b/knock/runtime/char.c similarity index 100% rename from knock/char.c rename to knock/runtime/char.c diff --git a/knock/runtime/error.c b/knock/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/knock/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/knock/gc.c b/knock/runtime/gc.c similarity index 100% rename from knock/gc.c rename to knock/runtime/gc.c diff --git a/knock/heap.h b/knock/runtime/heap.h similarity index 100% rename from knock/heap.h rename to knock/runtime/heap.h diff --git a/knock/runtime/io.c b/knock/runtime/io.c new file mode 100644 index 0000000..139dccb --- /dev/null +++ b/knock/runtime/io.c @@ -0,0 +1,25 @@ +#include +#include +#include "types.h" +#include "values.h" +#include "runtime.h" + +val_t read_byte(void) +{ + char c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); +} + +val_t peek_byte(void) +{ + char c = getc(stdin); + ungetc(c, stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); + +} + +val_t write_byte(val_t c) +{ + putc((char) val_unwrap_int(c), stdout); + return val_wrap_void(); +} diff --git a/knock/runtime/main.c b/knock/runtime/main.c new file mode 100644 index 0000000..6fa3ab3 --- /dev/null +++ b/knock/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/knock/print.c b/knock/runtime/print.c similarity index 100% rename from knock/print.c rename to knock/runtime/print.c diff --git a/jig/print.h b/knock/runtime/print.h similarity index 100% rename from jig/print.h rename to knock/runtime/print.h diff --git a/hoax/runtime.h b/knock/runtime/runtime.h similarity index 100% rename from hoax/runtime.h rename to knock/runtime/runtime.h diff --git a/jig/types.h b/knock/runtime/types.h similarity index 100% rename from jig/types.h rename to knock/runtime/types.h diff --git a/knock/runtime/types.rkt b/knock/runtime/types.rkt new file mode 100644 index 0000000..b9198f9 --- /dev/null +++ b/knock/runtime/types.rkt @@ -0,0 +1,52 @@ +#lang racket +(provide (all-defined-out)) + +(define imm-shift 3) +(define imm-mask #b111) +(define ptr-mask #b111) +(define type-box #b001) +(define type-cons #b010) +(define type-vect #b011) +(define type-str #b100) +(define int-shift (+ 1 imm-shift)) +(define mask-int #b1111) +(define char-shift (+ 2 imm-shift)) +(define type-int #b0000) +(define type-char #b01000) +(define mask-char #b11111) + +;; Value -> Integer +;; v must be an immediate +(define (value->bits v) + (cond [(eq? v #t) #b00011000] + [(eq? v #f) #b00111000] + [(eq? v eof) #b01011000] + [(eq? v (void)) #b01111000] + [(eq? v '()) #b10011000] + [(integer? v) (arithmetic-shift v int-shift)] + [(char? v) + (bitwise-ior type-char + (arithmetic-shift (char->integer v) char-shift))] + [else (error "not an immediate value" v)])) + +(define (int-bits? v) + (= type-int (bitwise-and v mask-int))) + +(define (char-bits? v) + (= type-char (bitwise-and v mask-char))) + +(define (imm-bits? v) + (zero? (bitwise-and v imm-mask))) + +(define (cons-bits? v) + (= type-cons (bitwise-and v imm-mask))) + +(define (box-bits? v) + (= type-box (bitwise-and v imm-mask))) + +(define (vect-bits? v) + (= type-vect (bitwise-and v imm-mask))) + +(define (str-bits? v) + (= type-str (bitwise-and v imm-mask))) + diff --git a/knock/values.c b/knock/runtime/values.c similarity index 100% rename from knock/values.c rename to knock/runtime/values.c diff --git a/knock/values.h b/knock/runtime/values.h similarity index 100% rename from knock/values.h rename to knock/runtime/values.h diff --git a/knock/ast.rkt b/knock/syntax/ast.rkt similarity index 100% rename from knock/ast.rkt rename to knock/syntax/ast.rkt diff --git a/knock/parse.rkt b/knock/syntax/parse.rkt similarity index 93% rename from knock/parse.rkt rename to knock/syntax/parse.rkt index ecc5fb2..b36f651 100644 --- a/knock/parse.rkt +++ b/knock/syntax/parse.rkt @@ -41,7 +41,7 @@ (define (rec ss fs) (match ss [(list s) fs] - [(cons (cons 'define sd) sr) + [(cons (cons (? (not-in fs) 'define) sd) sr) (match (parse-defn-name sd) [f (if (memq f fs) (error "duplicate definition" f) @@ -108,7 +108,7 @@ (list ys gs (Eof))] [(? datum?) (list ys gs (Lit s))] - [(list 'quote (list)) + [(list (and 'quote (? (not-in ns))) (list)) (list ys gs (Lit '()))] [(? symbol? (? (not-in fs))) (if (memq s xs) @@ -126,14 +126,14 @@ (list ys gs (Let x e1 e2))])])] [_ (error "let: bad syntax" s)])] ['match - (match sr - [(cons s sr) - (match (rec s xs ys gs) - [(list ys gs e) - (match (parse-match-clauses/acc sr fs xs ys gs) - [(list ys gs ps es) - (list ys gs (Match e ps es))])])] - [_ (error "match: bad syntax" s)])] + (match sr + [(cons s sr) + (match (rec s xs ys gs) + [(list ys gs e) + (match (parse-match-clauses/acc sr fs xs ys gs) + [(list ys gs ps es) + (list ys gs (Match e ps es))])])] + [_ (error "match: bad syntax" s)])] [_ (match (parse-es/acc sr fs xs ys gs) [(list ys gs es) @@ -154,7 +154,7 @@ (list ys (cons g gs) (App g es))])])])] [(list-rest (? symbol? g) sr) (match (parse-es/acc sr fs xs ys gs) - [(list ys s es) + [(list ys gs es) (list ys (if (memq g fs) gs (cons g gs)) (App g es))])] [_ (error "parse error" s)])) @@ -207,11 +207,13 @@ (define (parse-match-pattern/acc s fs xs ys gs) (define (rec p xs ys gs) (match p - [(? datum?) (list ys xs gs (Lit p))] + [(? self-quoting-datum?) (list ys xs gs (Lit p))] ['_ (list ys xs gs (Var '_))] [(? symbol?) (list ys (cons p xs) gs (Var p))] [(list 'quote '()) (list ys xs gs (Lit '()))] + [(list 'quote (? datum? d)) + (list ys xs (Lit d))] [(list 'box s) (match (rec s xs ys gs) [(list ys xs gs p) diff --git a/knock/read-all.rkt b/knock/syntax/read-all.rkt similarity index 100% rename from knock/read-all.rkt rename to knock/syntax/read-all.rkt diff --git a/knock/test/build-runtime.rkt b/knock/test/build-runtime.rkt deleted file mode 100644 index 7023ee0..0000000 --- a/knock/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/knock/test/compile.rkt b/knock/test/compile.rkt deleted file mode 100644 index 2096b58..0000000 --- a/knock/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ p (exec (apply parse-closed p)))) -(test/io (λ (in . p) (exec/io (apply parse-closed p) in))) - diff --git a/knock/test/test-runner.rkt b/knock/test/define-tests.rkt similarity index 98% rename from knock/test/test-runner.rkt rename to knock/test/define-tests.rkt index 889ab7c..493ad77 100644 --- a/knock/test/test-runner.rkt +++ b/knock/test/define-tests.rkt @@ -93,7 +93,7 @@ (check-equal? (run '(= (add1 4) 5)) #t) (check-equal? (run '(< 5 5)) #f) (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (check-equal? (run '(< (add1 4) 5)) #f)) (begin ;; Hustle (check-equal? (run '(empty? (cons 1 2))) #f) @@ -201,6 +201,12 @@ '(2 3 4)) (check-equal? (run '(define (f x y) y) '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) 'err)) (begin ;; Knock diff --git a/knock/test/interp.rkt b/knock/test/interp.rkt deleted file mode 100644 index 523685b..0000000 --- a/knock/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ p (interp (apply parse-closed p)))) -(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) - diff --git a/knock/test/run-compile-tests.rkt b/knock/test/run-compile-tests.rkt new file mode 100644 index 0000000..2cf66fd --- /dev/null +++ b/knock/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ p (run (compile (apply parse-closed p))))) +(test/io (λ (in . p) (run/io (compile (apply parse-closed p)) in))) + diff --git a/knock/test/run-interp-tests.rkt b/knock/test/run-interp-tests.rkt new file mode 100644 index 0000000..96137ef --- /dev/null +++ b/knock/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ p (interp (apply parse-closed p)))) +(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) + diff --git a/knock/test/parse.rkt b/knock/test/run-parse-tests.rkt similarity index 98% rename from knock/test/parse.rkt rename to knock/test/run-parse-tests.rkt index 8f8494f..ef2d59c 100644 --- a/knock/test/parse.rkt +++ b/knock/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) @@ -47,6 +47,7 @@ (check-equal? (parse "asdf") (p (Lit "asdf"))) (check-equal? (parse '(make-string 10 #\a)) (p (Prim2 'make-string (Lit 10) (Lit #\a))))) + (begin ; Iniquity (check-equal? (parse '(define (f x) x) 1) (Prog (list (Defn 'f '(x) (Var 'x))) (Lit 1))) diff --git a/knock/types.h b/knock/types.h deleted file mode 100644 index b79f45b..0000000 --- a/knock/types.h +++ /dev/null @@ -1,40 +0,0 @@ -#ifndef TYPES_H -#define TYPES_H - -/* - Bit layout of values - - Values are either: - - Immediates: end in #b000 - - Pointers - - Immediates are either - - Integers: end in #b0 000 - - Characters: end in #b01 000 - - True: #b11 000 - - False: #b1 11 000 - - Eof: #b10 11 000 - - Void: #b11 11 000 - - Empty: #b100 11 000 -*/ -#define imm_shift 3 -#define ptr_type_mask ((1 << imm_shift) - 1) -#define box_type_tag 1 -#define cons_type_tag 2 -#define vect_type_tag 3 -#define str_type_tag 4 -#define int_shift (1 + imm_shift) -#define int_type_mask ((1 << int_shift) - 1) -#define int_type_tag (0 << (int_shift - 1)) -#define nonint_type_tag (1 << (int_shift - 1)) -#define char_shift (int_shift + 1) -#define char_type_mask ((1 << char_shift) - 1) -#define char_type_tag ((0 << (char_shift - 1)) | nonint_type_tag) -#define nonchar_type_tag ((1 << (char_shift - 1)) | nonint_type_tag) -#define val_true ((0 << char_shift) | nonchar_type_tag) -#define val_false ((1 << char_shift) | nonchar_type_tag) -#define val_eof ((2 << char_shift) | nonchar_type_tag) -#define val_void ((3 << char_shift) | nonchar_type_tag) -#define val_empty ((4 << char_shift) | nonchar_type_tag) - -#endif diff --git a/loot/build-runtime.rkt b/loot/build-runtime.rkt deleted file mode 100644 index 6699852..0000000 --- a/loot/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(provide runtime-path) - -(require racket/runtime-path) -(define-runtime-path here ".") - -(unless (system (string-append "make -C '" - (path->string (normalize-path here)) - "' --no-print-directory -s runtime.o")) - (error 'build-runtime "could not build runtime")) - -(define runtime-path - (normalize-path (build-path here "runtime.o"))) - diff --git a/loot/assert.rkt b/loot/compiler/assert.rkt similarity index 97% rename from loot/assert.rkt rename to loot/compiler/assert.rkt index 250f51c..e6698e9 100644 --- a/loot/assert.rkt +++ b/loot/compiler/assert.rkt @@ -4,7 +4,7 @@ assert-natural assert-vector assert-string assert-proc) (require a86/ast) -(require "types.rkt") +(require "../runtime/types.rkt") (define (assert-type mask type) (λ (r) diff --git a/loot/compile-ops.rkt b/loot/compiler/compile-ops.rkt similarity index 97% rename from loot/compile-ops.rkt rename to loot/compiler/compile-ops.rkt index a648695..295b687 100644 --- a/loot/compile-ops.rkt +++ b/loot/compiler/compile-ops.rkt @@ -1,7 +1,7 @@ #lang racket (provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack assert-proc) -(require "ast.rkt") -(require "types.rkt") +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") (require "assert.rkt") (require a86/ast a86/registers) @@ -222,8 +222,8 @@ (Mov r9 (Mem r8 (- type-vect))) (Cmp r10 r9) (Jge 'err) - (Sar r10 1) ; convert to byte offset - (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) (Mov rax (value->bits (void))))])) (define (type-pred mask type) diff --git a/loot/compile-stdin.rkt b/loot/compiler/compile-stdin.rkt similarity index 79% rename from loot/compile-stdin.rkt rename to loot/compiler/compile-stdin.rkt index ed18b5e..f25989a 100644 --- a/loot/compile-stdin.rkt +++ b/loot/compiler/compile-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "compile.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") (require a86/printer) ;; -> Void diff --git a/loot/compile.rkt b/loot/compiler/compile.rkt similarity index 97% rename from loot/compile.rkt rename to loot/compiler/compile.rkt index 430d1f5..26ab093 100644 --- a/loot/compile.rkt +++ b/loot/compiler/compile.rkt @@ -9,11 +9,11 @@ copy-env-to-stack free-vars-to-heap) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "compile-ops.rkt") -(require "types.rkt") -(require "lambdas.rkt") -(require "fv.rkt") +(require "../runtime/types.rkt") +(require "../syntax/lambdas.rkt") +(require "../syntax/fv.rkt") (require a86/ast a86/registers) ;; Prog -> Asm @@ -23,12 +23,15 @@ (prog (Global 'entry) (Label 'entry) (Push rbx) ; save callee-saved register + (Push r15) (Mov rbx rdi) ; recv heap pointer + (compile-defines-values ds) (compile-e e (reverse (define-ids ds)) #f) (Add rsp (* 8 (length ds))) ;; pop function definitions (Pop r15) ; restore callee-save register + (Pop rbx) (Ret) (compile-defines ds) @@ -77,6 +80,8 @@ [(Lam f xs e) (let ((env (append (reverse fvs) (reverse xs) (list #f)))) (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) + (Jne 'err) (Mov rax (Mem rsp (* 8 (length xs)))) (copy-env-to-stack fvs 8) (compile-e e env #t) @@ -210,6 +215,7 @@ (Mov rax (Mem rsp (* 8 (length es)))) (assert-proc rax) (Mov rax (Mem rax (- type-proc))) + (Mov r8 (length es)) ; pass arity info (Jmp rax))) ;; Integer Integer -> Asm @@ -233,6 +239,7 @@ (Mov rax (Mem rsp i)) (assert-proc rax) (Mov rax (Mem rax (- type-proc))) ; fetch the code label + (Mov r8 (length es)) ; pass arity info (Jmp rax) (Label r)))) diff --git a/loot/correct.rkt b/loot/correct.rkt index d286ba1..1a7846d 100644 --- a/loot/correct.rkt +++ b/loot/correct.rkt @@ -1,10 +1,11 @@ #lang racket (provide check-compiler) (require rackunit) -(require "interp-io.rkt") -(require "exec.rkt") +(require "interpreter/interp-io.rkt") +(require "executor/run.rkt") +(require "compiler/compile.rkt") ;; ClosedExpr String -> Void (define (check-compiler e i) (check-equal? (interp/io e i) - (exec/io e i))) + (run/io (compile e) i))) diff --git a/loot/exec-io.rkt b/loot/exec-io.rkt deleted file mode 100644 index fb1d306..0000000 --- a/loot/exec-io.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(require a86/interp) -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec/io) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io (compile p) in) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) - diff --git a/loot/exec.rkt b/loot/exec.rkt deleted file mode 100644 index 59f36bf..0000000 --- a/loot/exec.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require a86/interp) -(require "run.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "build-runtime.rkt") -(provide exec exec/io) -;; Prog -> Answer -(define (exec p) - (run (compile p))) -;; Prog String -> (cons Answer String) -(define (exec/io p in) - (run/io (compile p) in)) - diff --git a/loot/types.rkt b/loot/executor/decode.rkt similarity index 50% rename from loot/types.rkt rename to loot/executor/decode.rkt index 0bb1674..d81ea13 100644 --- a/loot/types.rkt +++ b/loot/executor/decode.rkt @@ -1,21 +1,9 @@ #lang racket -(provide (all-defined-out)) + +(require "../runtime/types.rkt") (require ffi/unsafe) -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define type-proc #b101) -(define int-shift (+ 1 imm-shift)) -(define mask-int #b1111) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define type-char #b01000) -(define mask-char #b11111) +(provide (all-defined-out)) ;; Integer -> Value (define (bits->value b) @@ -49,47 +37,12 @@ (error "This function is not callable."))] [else (error "invalid bits")])) -;; Value -> Integer -;; v must be an immediate -(define (value->bits v) - (cond [(eq? v #t) #b00011000] - [(eq? v #f) #b00111000] - [(eq? v eof) #b01011000] - [(eq? v (void)) #b01111000] - [(eq? v '()) #b10011000] - [(integer? v) (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [else (error "not an immediate value" v)])) - -(define (int-bits? v) - (= type-int (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (cons-bits? v) - (= type-cons (bitwise-and v imm-mask))) - -(define (box-bits? v) - (= type-box (bitwise-and v imm-mask))) - -(define (vect-bits? v) - (= type-vect (bitwise-and v imm-mask))) - -(define (str-bits? v) - (= type-str (bitwise-and v imm-mask))) - (define (mem-ref i) (ptr-ref (cast i _int64 _pointer) _int64)) (define (mem-ref32 i) (ptr-ref (cast i _int64 _pointer) _int32)) -(define (proc-bits? v) - (= type-proc (bitwise-and v imm-mask))) +(define _val + (make-ctype _int64 value->bits bits->value)) diff --git a/loot/executor/exec.rkt b/loot/executor/exec.rkt new file mode 100644 index 0000000..cd5745e --- /dev/null +++ b/loot/executor/exec.rkt @@ -0,0 +1,55 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (exec/state prog) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/loot/executor/run-stdin.rkt b/loot/executor/run-stdin.rkt new file mode 100644 index 0000000..ac60d60 --- /dev/null +++ b/loot/executor/run-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + + (run (compile (parse (read))))) + diff --git a/loot/executor/run.rkt b/loot/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/loot/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/loot/interp-prims.rkt b/loot/interp-prims.rkt deleted file mode 100644 index 15039f9..0000000 --- a/loot/interp-prims.rkt +++ /dev/null @@ -1,69 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [(list 'vector? v) (vector? v)] - [(list 'vector-length (? vector?)) (vector-length v)] - [(list 'string? v) (string? v)] - [(list 'string-length (? string?)) (string-length v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] - [(list 'make-vector (? integer?) _) - (if (<= 0 v1) - (make-vector v1 v2) - 'err)] - [(list 'vector-ref (? vector?) (? integer?)) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-ref v1 v2) - 'err)] - [(list 'make-string (? integer?) (? char?)) - (if (<= 0 v1) - (make-string v1 v2) - 'err)] - [(list 'string-ref (? string?) (? integer?)) - (if (<= 0 v2 (sub1 (string-length v1))) - (string-ref v1 v2) - 'err)] - [_ 'err])) - -;; Op3 Value Value Value -> Answer -(define (interp-prim3 p v1 v2 v3) - (match (list p v1 v2 v3) - [(list 'vector-set! (? vector?) (? integer?) _) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/loot/env.rkt b/loot/interpreter/env.rkt similarity index 100% rename from loot/env.rkt rename to loot/interpreter/env.rkt diff --git a/loot/interp-defun.rkt b/loot/interpreter/interp-defun.rkt similarity index 99% rename from loot/interp-defun.rkt rename to loot/interpreter/interp-defun.rkt index 54a55a3..0323f5f 100644 --- a/loot/interp-defun.rkt +++ b/loot/interpreter/interp-defun.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-env (struct-out Closure) zip) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") ;; type Answer = Value | 'err diff --git a/loot/interp-io.rkt b/loot/interpreter/interp-io.rkt similarity index 100% rename from loot/interp-io.rkt rename to loot/interpreter/interp-io.rkt diff --git a/loot/interp-prim.rkt b/loot/interpreter/interp-prim.rkt similarity index 100% rename from loot/interp-prim.rkt rename to loot/interpreter/interp-prim.rkt diff --git a/loot/interp-stdin.rkt b/loot/interpreter/interp-stdin.rkt similarity index 78% rename from loot/interp-stdin.rkt rename to loot/interpreter/interp-stdin.rkt index df745af..7d85c32 100644 --- a/loot/interp-stdin.rkt +++ b/loot/interpreter/interp-stdin.rkt @@ -1,8 +1,8 @@ #lang racket (provide main) -(require "parse.rkt") +(require "../syntax/parse.rkt") (require "interp.rkt") -(require "read-all.rkt") +(require "../syntax/read-all.rkt") ;; -> Void ;; Parse and interpret contents of stdin, diff --git a/loot/interp.rkt b/loot/interpreter/interp.rkt similarity index 99% rename from loot/interp.rkt rename to loot/interpreter/interp.rkt index 1964be3..46d5c35 100644 --- a/loot/interp.rkt +++ b/loot/interpreter/interp.rkt @@ -1,7 +1,7 @@ #lang racket (provide interp interp-e) (provide interp-match-pat) -(require "ast.rkt") +(require "../syntax/ast.rkt") (require "interp-prim.rkt") (require "env.rkt") diff --git a/loot/io.c b/loot/io.c deleted file mode 100644 index 8a417c9..0000000 --- a/loot/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/loot/main.c b/loot/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/loot/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/loot/main.rkt b/loot/main.rkt index 50cf56e..f9851a3 100644 --- a/loot/main.rkt +++ b/loot/main.rkt @@ -1,18 +1,18 @@ #lang racket -(require "ast.rkt") -(require "parse.rkt") -(require "interp.rkt") -(require "interp-io.rkt") -(require "compile.rkt") -(require "types.rkt") -(require "run.rkt") -(require "exec.rkt") -(provide (all-from-out "ast.rkt")) -(provide (all-from-out "parse.rkt")) -(provide (all-from-out "interp.rkt")) -(provide (all-from-out "interp-io.rkt")) -(provide (all-from-out "compile.rkt")) -(provide (all-from-out "types.rkt")) -(provide (all-from-out "run.rkt")) -(provide (all-from-out "exec.rkt")) +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) diff --git a/loot/parse-file.rkt b/loot/parse-file.rkt deleted file mode 100644 index a502132..0000000 --- a/loot/parse-file.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; String -> Void -;; Compile contents of given file name, -;; emit asm code on stdout -(define (main fn) - (let ((p (open-input-file fn))) - (begin - (read-line p) ; ignore #lang racket line - (displayln (parse (read-all p))) - (close-input-port p)))) diff --git a/loot/run-stdin.rkt b/loot/run-stdin.rkt deleted file mode 100644 index 16cf99e..0000000 --- a/loot/run-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt") -(require "compile.rkt") -(require "run.rkt") - -;; -> Void -;; Compile contents of stdin and use asm-interp to run -(define (main) - (read-line) ; ignore #lang racket line - (run (compile (parse (read))))) - diff --git a/loot/run.rkt b/loot/run.rkt deleted file mode 100644 index e707f3b..0000000 --- a/loot/run.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require a86/interp) -(require "types.rkt") -(require "build-runtime.rkt") -(provide run run/io) - -;; Run instructions with run-time system linked in - -;; Asm -> Answer -(define (run is) - (match (run/io is "") - [(cons r out) (begin (display out) r)])) - -;; Run instruction and feed input from string, -;; collection output as a string (useful for testing I/O programs) - -;; Asm String -> (cons Answer String) -(define (run/io is in) - (parameterize ((current-objs (list (path->string runtime-path)))) - (match (asm-interp/io is in) - [(cons 'err out) (cons 'err out)] - [(cons b out) - (cons (bits->value b) out)]))) - diff --git a/loot/runtime.h b/loot/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/loot/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/loot/runtime/Makefile b/loot/runtime/Makefile new file mode 100644 index 0000000..5582813 --- /dev/null +++ b/loot/runtime/Makefile @@ -0,0 +1,28 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + print.o \ + values.o \ + io.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/loot/char.c b/loot/runtime/char.c similarity index 100% rename from loot/char.c rename to loot/runtime/char.c diff --git a/loot/runtime/error.c b/loot/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/loot/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/loot/heap.h b/loot/runtime/heap.h similarity index 100% rename from loot/heap.h rename to loot/runtime/heap.h diff --git a/loot/runtime/io.c b/loot/runtime/io.c new file mode 100644 index 0000000..139dccb --- /dev/null +++ b/loot/runtime/io.c @@ -0,0 +1,25 @@ +#include +#include +#include "types.h" +#include "values.h" +#include "runtime.h" + +val_t read_byte(void) +{ + char c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); +} + +val_t peek_byte(void) +{ + char c = getc(stdin); + ungetc(c, stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_byte(c); + +} + +val_t write_byte(val_t c) +{ + putc((char) val_unwrap_int(c), stdout); + return val_wrap_void(); +} diff --git a/loot/runtime/main.c b/loot/runtime/main.c new file mode 100644 index 0000000..6fa3ab3 --- /dev/null +++ b/loot/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/loot/print.c b/loot/runtime/print.c similarity index 100% rename from loot/print.c rename to loot/runtime/print.c diff --git a/knock/print.h b/loot/runtime/print.h similarity index 100% rename from knock/print.h rename to loot/runtime/print.h diff --git a/hustle/runtime.h b/loot/runtime/runtime.h similarity index 100% rename from hustle/runtime.h rename to loot/runtime/runtime.h diff --git a/loot/types.h b/loot/runtime/types.h similarity index 100% rename from loot/types.h rename to loot/runtime/types.h diff --git a/iniquity/types.rkt b/loot/runtime/types.rkt similarity index 51% rename from iniquity/types.rkt rename to loot/runtime/types.rkt index c0c1d70..4385984 100644 --- a/iniquity/types.rkt +++ b/loot/runtime/types.rkt @@ -1,6 +1,5 @@ #lang racket (provide (all-defined-out)) -(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -9,6 +8,7 @@ (define type-cons #b010) (define type-vect #b011) (define type-str #b100) +(define type-proc #b101) (define int-shift (+ 1 imm-shift)) (define mask-int #b1111) (define char-shift (+ 2 imm-shift)) @@ -16,35 +16,6 @@ (define type-char #b01000) (define mask-char #b11111) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (mem-ref (- b type-box))))] - [(cons-bits? b) - (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) - (bits->value (mem-ref (+ 8 (- b type-cons)))))] - - [(vect-bits? b) - (let ((p (- b type-vect))) - (build-vector (bits->value (mem-ref p)) - (lambda (j) - (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] - [(str-bits? b) - (let ((p (- b type-str))) - (build-string (bits->value (mem-ref p)) - (lambda (j) - (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] - [else (error "invalid bits")])) - ;; Value -> Integer ;; v must be an immediate (define (value->bits v) @@ -80,9 +51,6 @@ (define (str-bits? v) (= type-str (bitwise-and v imm-mask))) -(define (mem-ref i) - (ptr-ref (cast i _int64 _pointer) _int64)) - -(define (mem-ref32 i) - (ptr-ref (cast i _int64 _pointer) _int32)) +(define (proc-bits? v) + (= type-proc (bitwise-and v imm-mask))) diff --git a/loot/values.c b/loot/runtime/values.c similarity index 100% rename from loot/values.c rename to loot/runtime/values.c diff --git a/loot/values.h b/loot/runtime/values.h similarity index 100% rename from loot/values.h rename to loot/runtime/values.h diff --git a/loot/ast.rkt b/loot/syntax/ast.rkt similarity index 100% rename from loot/ast.rkt rename to loot/syntax/ast.rkt diff --git a/loot/fv.rkt b/loot/syntax/fv.rkt similarity index 100% rename from loot/fv.rkt rename to loot/syntax/fv.rkt diff --git a/loot/lambdas.rkt b/loot/syntax/lambdas.rkt similarity index 100% rename from loot/lambdas.rkt rename to loot/syntax/lambdas.rkt diff --git a/loot/parse.rkt b/loot/syntax/parse.rkt similarity index 93% rename from loot/parse.rkt rename to loot/syntax/parse.rkt index a593571..30207c5 100644 --- a/loot/parse.rkt +++ b/loot/syntax/parse.rkt @@ -41,7 +41,7 @@ (define (rec ss fs) (match ss [(list s) fs] - [(cons (cons 'define sd) sr) + [(cons (cons (? (not-in fs) 'define) sd) sr) (match (parse-defn-name sd) [f (if (memq f fs) (error "duplicate definition" f) @@ -98,7 +98,7 @@ (list ys (Eof))] [(? datum?) (list ys (Lit s))] - [(list 'quote (list)) + [(list (and 'quote (? (not-in ns))) (list)) (list ys (Lit '()))] [(? symbol? f) (if (memq s xs) @@ -116,14 +116,14 @@ (list ys (Let x e1 e2))])])] [_ (error "let: bad syntax" s)])] ['match - (match sr - [(cons s sr) - (match (rec s xs ys) - [(list ys e) - (match (parse-match-clauses/acc sr xs ys) - [(list ys ps es) - (list ys (Match e ps es))])])] - [_ (error "match: bad syntax" s)])] + (match sr + [(cons s sr) + (match (rec s xs ys) + [(list ys e) + (match (parse-match-clauses/acc sr xs ys) + [(list ys ps es) + (list ys (Match e ps es))])])] + [_ (error "match: bad syntax" s)])] [(or 'λ 'lambda) (match sr @@ -198,11 +198,13 @@ (define (parse-match-pattern/acc s xs ys) (define (rec p xs ys) (match p - [(? datum?) (list ys xs (Lit p))] + [(? self-quoting-datum?) (list ys xs (Lit p))] ['_ (list ys xs (Var '_))] [(? symbol?) (list ys (cons p xs) (Var p))] [(list 'quote '()) (list ys xs (Lit '()))] + [(list 'quote (? datum? d)) + (list ys xs (Lit d))] [(list 'box s) (match (rec s xs ys) [(list ys xs p) diff --git a/loot/read-all.rkt b/loot/syntax/read-all.rkt similarity index 100% rename from loot/read-all.rkt rename to loot/syntax/read-all.rkt diff --git a/loot/test/build-runtime.rkt b/loot/test/build-runtime.rkt deleted file mode 100644 index 7023ee0..0000000 --- a/loot/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/loot/test/compile.rkt b/loot/test/compile.rkt deleted file mode 100644 index 2096b58..0000000 --- a/loot/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../compile.rkt") -(require "../parse.rkt") -(require "../exec.rkt") -(require "test-runner.rkt") -(test (λ p (exec (apply parse-closed p)))) -(test/io (λ (in . p) (exec/io (apply parse-closed p) in))) - diff --git a/loot/test/test-runner.rkt b/loot/test/define-tests.rkt similarity index 98% rename from loot/test/test-runner.rkt rename to loot/test/define-tests.rkt index 37b2c6f..a9833ad 100644 --- a/loot/test/test-runner.rkt +++ b/loot/test/define-tests.rkt @@ -93,7 +93,7 @@ (check-equal? (run '(= (add1 4) 5)) #t) (check-equal? (run '(< 5 5)) #f) (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f)) + (check-equal? (run '(< (add1 4) 5)) #f)) (begin ;; Hustle (check-equal? (run '(empty? (cons 1 2))) #f) @@ -201,6 +201,12 @@ '(2 3 4)) (check-equal? (run '(define (f x y) y) '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) 'err)) (begin ;; Knock diff --git a/loot/test/interp.rkt b/loot/test/interp.rkt deleted file mode 100644 index 523685b..0000000 --- a/loot/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "../interp.rkt") -(require "../interp-io.rkt") -(require "../parse.rkt") -(require "test-runner.rkt") -(test (λ p (interp (apply parse-closed p)))) -(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) - diff --git a/loot/test/run-compile-tests.rkt b/loot/test/run-compile-tests.rkt new file mode 100644 index 0000000..2cf66fd --- /dev/null +++ b/loot/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ p (run (compile (apply parse-closed p))))) +(test/io (λ (in . p) (run/io (compile (apply parse-closed p)) in))) + diff --git a/loot/test/run-interp-tests.rkt b/loot/test/run-interp-tests.rkt new file mode 100644 index 0000000..96137ef --- /dev/null +++ b/loot/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ p (interp (apply parse-closed p)))) +(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) + diff --git a/loot/test/parse.rkt b/loot/test/run-parse-tests.rkt similarity index 98% rename from loot/test/parse.rkt rename to loot/test/run-parse-tests.rkt index 839f472..e5f05ff 100644 --- a/loot/test/parse.rkt +++ b/loot/test/run-parse-tests.rkt @@ -1,6 +1,6 @@ #lang racket -(require "../parse.rkt") -(require "../ast.rkt") +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") (require rackunit) (define (p e) @@ -47,6 +47,7 @@ (check-equal? (parse "asdf") (p (Lit "asdf"))) (check-equal? (parse '(make-string 10 #\a)) (p (Prim2 'make-string (Lit 10) (Lit #\a))))) + (begin ; Iniquity (check-equal? (parse '(define (f x) x) 1) (Prog (list (Defn 'f '(x) (Var 'x))) (Lit 1))) @@ -74,6 +75,7 @@ (check-equal? (parse '(match x ['() 1])) (p (Match (Var 'x) (list (Lit '())) (list (Lit 1))))) (check-exn exn:fail? (λ () (parse-closed '(match 1 [x y]))))) + (begin ; Loot (check-equal? (parse '(f x)) (p (App (Var 'f) (list (Var 'x)))))) diff --git a/mountebank/Makefile b/mountebank/Makefile index 3fc9599..d88e2b9 100644 --- a/mountebank/Makefile +++ b/mountebank/Makefile @@ -10,8 +10,7 @@ objs = \ main.o \ print.o \ values.o \ - io.o \ - symbol.o + io.o default: runtime.o diff --git a/mountebank/ast.rkt b/mountebank/ast.rkt deleted file mode 100644 index a946759..0000000 --- a/mountebank/ast.rkt +++ /dev/null @@ -1,81 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = (Prog (Listof Defn) Expr) -(struct Prog (ds e) #:prefab) - -;; type Defn = (Defn Id (Listof Id) Expr) -(struct Defn (f xs e) #:prefab) - -;; type Expr = (Eof) -;; | (Quote Datum) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; | (Match Expr (Listof Pat) (Listof Expr)) -;; | (App Expr (Listof Expr)) -;; | (Lam Id (Listof Id) Expr) -;; type Datum = Integer -;; | Char -;; | Boolean -;; | String -;; | Symbol -;; | (Boxof Datum) -;; | (Listof Datum) -;; | (Vectorof Datum) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | 'vector-length -;; | 'string? | 'string-length -;; | 'symbol? | 'string->symbol -;; | 'string->symbol | 'string->uninterned-symbol -;; type Op2 = '+ | '- | '< | '= -;; | 'cons | 'eq? -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -;; type Pat = (PVar Id) -;; | (PWild) -;; | (PLit Lit) -;; | (PBox Pat) -;; | (PCons Pat Pat) -;; | (PAnd Pat Pat) -;; | (PSymb Symbol) -;; | (PStr String) -;; type Lit = Boolean -;; | Character -;; | Integer -;; | '() - -(struct Eof () #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) -(struct App (e es) #:prefab) -(struct Lam (f xs e) #:prefab) -(struct Quote (d) #:prefab) -(struct Match (e ps es) #:prefab) - -(struct PVar (x) #:prefab) -(struct PWild () #:prefab) -(struct PLit (x) #:prefab) -(struct PBox (p) #:prefab) -(struct PCons (p1 p2) #:prefab) -(struct PAnd (p1 p2) #:prefab) -(struct PSymb (s) #:prefab) -(struct PStr (s) #:prefab) diff --git a/mountebank/build-runtime.rkt b/mountebank/build-runtime.rkt deleted file mode 100644 index 66aad89..0000000 --- a/mountebank/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require racket/runtime-path) -(provide runtime-path) - -(define-runtime-path here ".") - -(void - (system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o"))) - -(define runtime-path - (path->string - (normalize-path (build-path here "runtime.o")))) diff --git a/mountebank/compile-ops.rkt b/mountebank/compile-ops.rkt deleted file mode 100644 index 79fe367..0000000 --- a/mountebank/compile-ops.rkt +++ /dev/null @@ -1,397 +0,0 @@ -#lang racket -(provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack unpad-stack assert-proc) -(require "ast.rkt" "types.rkt" "utils.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg1 -(define rsi 'rsi) ; arg2 -(define rdx 'rdx) ; arg3 -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r12 'r12) ; save across call to memcpy -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-imm 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-imm eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Mem rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Mem rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Mem rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Mem rax 0)))] - ['empty? (eq-imm '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['symbol? - (type-pred ptr-mask type-symb)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Mem rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Mem rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string->symbol - (seq (assert-string rax) - (Xor rax type-str) - (Mov rdi rax) - pad-stack - (Call 'intern_symbol) - unpad-stack - (Or rax type-symb))] - ['symbol->string - (seq (assert-symbol rax) - (Xor rax type-symb) - char-array-copy - (Or rax type-str))] - ['string->uninterned-symbol - (seq (assert-string rax) - (Xor rax type-str) - char-array-copy - (Or rax type-symb))])) - -;; Asm -;; Copy sized array of characters pointed to by rax -(define char-array-copy - (seq (Mov rdi rbx) ; dst - (Mov rsi rax) ; src - (Mov rdx (Mem rax 0)) ; len - (Add rdx 1) ; #words = 1 + (len+1)/2 - (Sar rdx 1) - (Add rdx 1) - (Sal rdx 3) ; #bytes = 8*#words - (Mov r12 rdx) ; save rdx before destroyed - pad-stack - (Call 'memcpy) - unpad-stack - ; rbx should be preserved by memcpy - ;(Mov rbx rax) ; dst is returned, install as heap pointer - (Add rbx r12))) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (Mov rax (value->bits #t)) - (let ((true (gensym))) - (seq (Jl true) - (Mov rax (value->bits #f)) - (Label true))))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (Mov rax (value->bits #t)) - (let ((true (gensym))) - (seq (Je true) - (Mov rax (value->bits #f)) - (Label true))))] - ['cons - (seq (Mov (Mem rbx 0) rax) - (Pop rax) - (Mov (Mem rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (eq r8 rax))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Mem rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Mem rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp r8 type-vect) - (Je 'raise_error_align) ; special case for empty vector - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Mem r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Mem rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Mem rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp r8 type-str) - (Je 'raise_error_align) ; special case for empty string - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Mem r8 8)) - (Sal rax char-shift) - (Or rax type-char))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Mem r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (value->bits #t)) - (Je l) - (Mov rax (value->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) -(define assert-symbol - (assert-type ptr-mask type-symb)) -(define assert-proc - (assert-type ptr-mask type-proc)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; Value -> Asm -(define (eq-imm imm) - (let ((l1 (gensym))) - (seq (Cmp rax (value->bits imm)) - (Mov rax (value->bits #t)) - (Je l1) - (Mov rax (value->bits #f)) - (Label l1)))) - -(define (eq ir1 ir2) - (let ((l1 (gensym))) - (seq (Cmp ir1 ir2) - (Mov rax (value->bits #t)) - (Je l1) - (Mov rax (value->bits #f)) - (Label l1)))) diff --git a/mountebank/compile-stdin.rkt b/mountebank/compile-stdin.rkt deleted file mode 100644 index cfa1510..0000000 --- a/mountebank/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read-all))))) diff --git a/mountebank/compile.rkt b/mountebank/compile.rkt deleted file mode 100644 index 6d0028b..0000000 --- a/mountebank/compile.rkt +++ /dev/null @@ -1,53 +0,0 @@ -#lang racket -(provide compile compile-e) -(require "ast.rkt" - "types.rkt" - "lambdas.rkt" - "fv.rkt" - "utils.rkt" - "compile-define.rkt" - "compile-expr.rkt" - "compile-literals.rkt" - a86/ast) - -;; Registers used -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Prog -> Asm -(define (compile p) - (match p - [(Prog ds e) - (prog (externs) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (init-symbol-table p) - (compile-defines-values ds) - (compile-e e (reverse (define-ids ds)) #f) - (Add rsp (* 8 (length ds))) ;; pop function definitions - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (compile-defines ds) - (compile-lambda-defines (lambdas p)) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error) - (Data) - (compile-literals p))])) - -(define (externs) - (seq (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error) - (Extern 'intern_symbol) - (Extern 'symb_cmp) - (Extern 'memcpy))) diff --git a/mountebank/compiler/assert.rkt b/mountebank/compiler/assert.rkt new file mode 100644 index 0000000..0d97df1 --- /dev/null +++ b/mountebank/compiler/assert.rkt @@ -0,0 +1,68 @@ +#lang racket +(provide assert-integer assert-char assert-byte assert-codepoint + assert-box assert-cons + assert-natural assert-vector assert-string + assert-proc assert-symbol) +(require a86/ast) +(require "../runtime/types.rkt") + +(define (assert-type mask type) + (λ (r) + (seq (Push r) + (And r mask) + (Cmp r type) + (Pop r) + (Jne 'err)))) + +;; Register -> Asm + + +(define assert-integer + (assert-type mask-int type-int)) + +;; Register -> Asm + +(define assert-char + (assert-type mask-char type-char)) +(define assert-box + (assert-type ptr-mask type-box)) +(define assert-cons + (assert-type ptr-mask type-cons)) +(define assert-vector + (assert-type ptr-mask type-vect)) +(define assert-string + (assert-type ptr-mask type-str)) +(define assert-proc + (assert-type ptr-mask type-proc)) +(define assert-symbol + (assert-type ptr-mask type-symb)) + +;; Register -> Asm +(define (assert-codepoint r) + (let ((ok (gensym))) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err) + (Cmp r (value->bits 1114111)) + (Jg 'err) + (Cmp r (value->bits 55295)) + (Jl ok) + (Cmp r (value->bits 57344)) + (Jg ok) + (Jmp 'err) + (Label ok)))) + +;; Register -> Asm +(define (assert-byte r) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err) + (Cmp r (value->bits 255)) + (Jg 'err))) + +;; Register -> Asm +(define (assert-natural r) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err))) + diff --git a/neerdowell/compile-datum.rkt b/mountebank/compiler/compile-datum.rkt similarity index 91% rename from neerdowell/compile-datum.rkt rename to mountebank/compiler/compile-datum.rkt index 9fe2720..1fe497f 100644 --- a/neerdowell/compile-datum.rkt +++ b/mountebank/compiler/compile-datum.rkt @@ -1,11 +1,9 @@ #lang racket (provide compile-datum) -(require "types.rkt" - "utils.rkt" - a86/ast) - -;; Registers used -(define rax 'rax) ; return +(require "../runtime/types.rkt") +(require "compile-literals.rkt") +(require a86/ast + a86/registers) ;; Datum -> Asm (define (compile-datum d) @@ -69,20 +67,21 @@ (let ((l (gensym 'cons))) (cons (Mem l type-cons) (seq (Label l) - (Dq l2) (Dq l1) + (Dq l2) is1 is2)))])])) ;; [Listof Datum] -> (cons AsmExpr Asm) (define (compile-datum-vector ds) (match ds - ['() (cons type-vect '())] + ['() (cons (Mem 'empty type-vect) '())] [_ (let ((l (gensym 'vector)) (cds (map compile-quoted ds))) (cons (Mem l type-vect) (seq (Label l) - (Dq (length ds)) + (Dq (value->bits (length ds))) (map (λ (cd) (Dq (car cd))) cds) (append-map cdr cds))))])) + diff --git a/mountebank/compiler/compile-literals.rkt b/mountebank/compiler/compile-literals.rkt new file mode 100644 index 0000000..c0321d4 --- /dev/null +++ b/mountebank/compiler/compile-literals.rkt @@ -0,0 +1,48 @@ +#lang racket +(provide compile-literals init-symbol-table compile-string-chars symbol->data-label) +(require "../syntax/ast.rkt") +(require "../syntax/literals.rkt") +(require "../runtime/types.rkt") +(require a86/ast a86/registers) + +;; Prog -> Asm +(define (compile-literals p) + (append-map compile-literal (literals p))) + +;; Symbol -> Asm +(define (compile-literal s) + (let ((str (symbol->string s))) + (seq (Label (symbol->data-label s)) + (Dq (value->bits (string-length str))) + (compile-string-chars (string->list str)) + (if (odd? (string-length str)) + (seq (Dd 0)) + (seq))))) + +;; Prog -> Asm +;; Call intern_symbol on every symbol in the program +(define (init-symbol-table p) + (match (symbols p) + ['() (seq)] + [ss (seq (Sub 'rsp 8) + (append-map init-symbol ss) + (Add 'rsp 8))])) + +;; Symbol -> Asm +(define (init-symbol s) + (seq (Lea rdi (symbol->data-label s)) + (Extern 'intern_symbol) + (Call 'intern_symbol))) + +;; [Listof Char] -> Asm +(define (compile-string-chars cs) + (match cs + ['() (seq)] + [(cons c cs) + (seq (Dd (char->integer c)) + (compile-string-chars cs))])) + +(define (symbol->data-label s) + (symbol->label + (string->symbol (string-append "data_" (symbol->string s))))) + diff --git a/mountebank/compiler/compile-ops.rkt b/mountebank/compiler/compile-ops.rkt new file mode 100644 index 0000000..bf35a6a --- /dev/null +++ b/mountebank/compiler/compile-ops.rkt @@ -0,0 +1,298 @@ +#lang racket +(provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack assert-proc) +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") +(require "assert.rkt") +(require a86/ast a86/registers) + +;; Op0 -> Asm +(define (compile-op0 p) + (match p + ['void (seq (Mov rax (value->bits (void))))] + ['read-byte (seq (Extern 'read_byte) pad-stack (Call 'read_byte) unpad-stack)] + ['peek-byte (seq (Extern 'peek_byte) pad-stack (Call 'peek_byte) unpad-stack)])) + +;; Op1 -> Asm +(define (compile-op1 p) + (match p + ['add1 + (seq (assert-integer rax) + (Add rax (value->bits 1)))] + ['sub1 + (seq (assert-integer rax) + (Sub rax (value->bits 1)))] + ['zero? + (seq (assert-integer rax) + (Cmp rax 0) + if-equal)] + ['char? + (seq (And rax mask-char) + (Cmp rax type-char) + if-equal)] + ['char->integer + (seq (assert-char rax) + (Sar rax char-shift) + (Sal rax int-shift))] + ['integer->char + (seq (assert-codepoint rax) + (Sar rax int-shift) + (Sal rax char-shift) + (Xor rax type-char))] + ['eof-object? + (seq (Cmp rax (value->bits eof)) + if-equal)] + ['write-byte + (seq (Extern 'write_byte) + (assert-byte rax) + pad-stack + (Mov rdi rax) + (Call 'write_byte) + unpad-stack)] + ['box + (seq (Mov (Mem rbx) rax) ; memory write + (Mov rax rbx) ; put box in rax + (Xor rax type-box) ; tag as a box + (Add rbx 8))] + ['unbox + (seq (assert-box rax) + (Mov rax (Mem rax (- type-box))))] + ['car + (seq (assert-cons rax) + (Mov rax (Mem rax (- 0 type-cons))))] + ['cdr + (seq (assert-cons rax) + (Mov rax (Mem rax (- 8 type-cons))))] + + ['empty? (seq (Cmp rax (value->bits '())) if-equal)] + ['cons? (type-pred ptr-mask type-cons)] + ['box? (type-pred ptr-mask type-box)] + ['vector? (type-pred ptr-mask type-vect)] + ['string? (type-pred ptr-mask type-str)] + ['symbol? (type-pred ptr-mask type-symb)] + ['vector-length + (seq (assert-vector rax) + (Mov rax (Mem rax (- type-vect))))] + ['string-length + (seq (assert-string rax) + (Mov rax (Mem rax (- type-str))))] + ['string->symbol + (seq (assert-string rax) + (Xor rax type-str) + (Mov rdi rax) + pad-stack + (Extern 'intern_symbol) + (Call 'intern_symbol) + unpad-stack + (Or rax type-symb))] + ['symbol->string + (seq (assert-symbol rax) + (Xor rax type-symb) + char-array-copy + (Or rax type-str))] + ['string->uninterned-symbol + (seq (assert-string rax) + (Xor rax type-str) + char-array-copy + (Or rax type-symb))])) + +;; Op2 -> Asm +(define (compile-op2 p) + (match p + ['+ + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Add rax r8))] + ['- + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Sub r8 rax) + (Mov rax r8))] + ['< + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Cmp r8 rax) + if-lt)] + ['= + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Cmp r8 rax) + if-equal)] + ['cons + (seq (Mov (Mem rbx 8) rax) + (Pop rax) + (Mov (Mem rbx 0) rax) + (Mov rax rbx) + (Xor rax type-cons) + (Add rbx 16))] + ['eq? + (seq (Pop r8) + (Cmp rax r8) + if-equal)] + ['make-vector + (let ((nonzero (gensym 'nz)) + (loop (gensym 'loop)) + (theend (gensym 'theend))) + + (seq (Pop r8) + (assert-natural r8) + + ; special case for length = 0 + (Cmp r8 0) + (Jne nonzero) + ; return canonical representation + (Lea rax (Mem 'empty type-vect)) + (Jmp theend) + + ; Code for nonzero case + (Label nonzero) + (Mov (Mem rbx 0) r8) ; write length + (Sar r8 1) ; convert to bytes + (Mov r9 r8) ; save for heap adjustment + + ; start initialization + (Label loop) + (Mov (Mem rbx r8) rax) + (Sub r8 8) + (Cmp r8 0) + (Jne loop) + ; end initialization + + (Mov rax rbx) + (Xor rax type-vect) ; create tagged pointer + (Add rbx r9) ; acct for elements and stored length + (Add rbx 8) + (Label theend)))] + + ['vector-ref + (seq (Pop r8) + (assert-vector r8) + (assert-natural rax) + (Mov r9 (Mem r8 (- type-vect))) + (Cmp rax r9) + (Jge 'err) + (Sar rax 1) + (Mov rax (Mem r8 rax (- 8 type-vect))))] + ['make-string + (let ((nonzero (gensym 'nz)) + (loop (gensym 'loop)) + (theend (gensym 'theend))) + (seq (Pop r8) + (assert-natural r8) + (assert-char rax) + + ; special case for length = 0 + (Cmp r8 0) + (Jne nonzero) + ; return canonical representation + (Lea rax (Mem 'empty type-str)) + (Jmp theend) + + ; Code for nonzero case + (Label nonzero) + + (Mov (Mem rbx 0) r8) ; write length + (Sar r8 2) ; convert to bytes + (Mov r9 r8) ; save for heap adjustment + + (Sar rax char-shift) ; convert to codepoint + + ; start initialization + (Label loop) + (Mov (Mem rbx r8 4) eax) + (Sub r8 4) + (Cmp r8 0) + (Jne loop) + ; end initialization + + (Mov rax rbx) + (Xor rax type-str) ; create tagged pointer + (Add rbx r9) ; acct for elements and stored length + (Add rbx 8) + ; Pad to 8-byte alignment + (Add rbx 4) + (Sar rbx 3) + (Sal rbx 3) + (Label theend)))] + + ['string-ref + (seq (Pop r8) + (assert-natural rax) + (assert-string r8) + (Mov r9 (Mem r8 (- type-str))) + (Cmp rax r9) + (Jge 'err) + (Sar rax 2) + (Mov eax (Mem r8 rax (- 8 type-str))) + (Sal rax char-shift) + (Xor rax type-char))])) + + +;; Op3 -> Asm +(define (compile-op3 p) + (match p + ['vector-set! + (seq (Pop r10) + (Pop r8) + (assert-vector r8) + (assert-natural r10) + (Mov r9 (Mem r8 (- type-vect))) + (Cmp r10 r9) + (Jge 'err) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Mov rax (value->bits (void))))])) + +(define (type-pred mask type) + (seq (And rax mask) + (Cmp rax type) + if-equal)) + +;; Asm +;; set rax to #t or #f if comparison flag is equal +(define if-equal + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmove rax r9))) + +;; Asm +;; set rax to #t or #f if comparison flag is less than +(define if-lt + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmovl rax r9))) + + +;; Asm +;; Dynamically pad the stack to be aligned for a call +(define pad-stack + (seq (Mov r15 rsp) + (And r15 #b1000) + (Sub rsp r15))) + +;; Asm +;; Undo the stack alignment after a call +(define unpad-stack + (seq (Add rsp r15))) + +;; Asm +;; Copy sized array of characters pointed to by rax +(define char-array-copy + (seq (Mov rdi rbx) ; dst + (Mov rsi rax) ; src + (Mov rdx (Mem rax 0)) ; len + (Add rdx 1) ; #words = 1 + (len+1)/2 + (Sar rdx 1) + (Add rdx 1) + (Sal rdx 3) ; #bytes = 8*#words + (Mov r12 rdx) ; save rdx before destroyed + pad-stack + (Extern 'memcpy) + (Call 'memcpy) + unpad-stack + ; rbx should be preserved by memcpy + (Add rbx r12))) + diff --git a/mountebank/compiler/compile-stdin.rkt b/mountebank/compiler/compile-stdin.rkt new file mode 100644 index 0000000..f25989a --- /dev/null +++ b/mountebank/compiler/compile-stdin.rkt @@ -0,0 +1,14 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "compile.rkt") +(require "../syntax/read-all.rkt") +(require a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (asm-display (compile (apply parse-closed (read-all))))) + diff --git a/mug/compile-expr.rkt b/mountebank/compiler/compile.rkt similarity index 56% rename from mug/compile-expr.rkt rename to mountebank/compiler/compile.rkt index 1921741..1dc6d01 100644 --- a/mug/compile-expr.rkt +++ b/mountebank/compiler/compile.rkt @@ -1,69 +1,136 @@ #lang racket -(provide compile-e compile-lambda-defines compile-lambda-define free-vars-to-heap - ; for notes - compile-string compile-symbol) -(require "ast.rkt" - "types.rkt" - "lambdas.rkt" - "fv.rkt" - "utils.rkt" - "compile-ops.rkt" - a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r8 'r8) -(define r9 'r9) -(define rsi 'rsi) - -;; Expr CEnv Bool -> Asm +(provide compile + compile-e + compile-es + compile-define + compile-match + compile-match-clause + compile-lambda-define + copy-env-to-stack + free-vars-to-heap) + +(require "../syntax/ast.rkt") +(require "compile-ops.rkt") +(require "compile-literals.rkt") +(require "compile-datum.rkt") +(require "../runtime/types.rkt") +(require "../syntax/lambdas.rkt") +(require "../syntax/fv.rkt") +(require a86/ast a86/registers) + +;; Prog -> Asm +(define (compile p) + (match p + [(Prog ds e) + (prog (Global 'entry) + (Label 'entry) + (Push rbx) ; save callee-saved register + (Push r12) + (Push r15) + (Mov rbx rdi) ; recv heap pointer + (init-symbol-table p) + (compile-defines-values ds) + (compile-e e (reverse (define-ids ds)) #f) + (Add rsp (* 8 (length ds))) ;; pop function definitions + (Pop r15) ; restore callee-save register + (Pop r12) + (Pop rbx) + (Ret) + (compile-defines ds) + (compile-lambda-defines (lambdas p)) + (Label 'err) + pad-stack + (Extern 'raise_error) + (Call 'raise_error) + (Data) + (Label 'empty) + (Dq 0) + (compile-literals p))])) + +;; [Listof Defn] -> [Listof Id] +(define (define-ids ds) + (match ds + ['() '()] + [(cons (Defn f xs e) ds) + (cons f (define-ids ds))])) + +;; [Listof Defn] -> Asm +(define (compile-defines ds) + (match ds + ['() (seq)] + [(cons d ds) + (seq (compile-define d) + (compile-defines ds))])) + +;; Defn -> Asm +(define (compile-define d) + (match d + [(Defn f xs e) + (compile-lambda-define (Lam f xs e))])) + +;; [Listof Lam] -> Asm +(define (compile-lambda-defines ls) + (match ls + ['() (seq)] + [(cons l ls) + (seq (compile-lambda-define l) + (compile-lambda-defines ls))])) + +;; Lam -> Asm +(define (compile-lambda-define l) + (let ((fvs (fv l))) + (match l + [(Lam f xs e) + (let ((env (append (reverse fvs) (reverse xs) (list #f)))) + (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) + (Jne 'err) + (Mov rax (Mem rsp (* 8 (length xs)))) + (copy-env-to-stack fvs 8) + (compile-e e env #t) + (Add rsp (* 8 (length env))) ; pop env + (Ret)))]))) + +;; [Listof Id] Int -> Asm +;; Copy the closure environment at given offset to stack +(define (copy-env-to-stack fvs off) + (match fvs + ['() (seq)] + [(cons _ fvs) + (seq (Mov r9 (Mem rax (- off type-proc))) + (Push r9) + (copy-env-to-stack fvs (+ 8 off)))])) + +;; type CEnv = (Listof [Maybe Id]) +;; Expr CEnv Boolean -> Asm (define (compile-e e c t?) (match e - [(Int i) (compile-value i)] - [(Bool b) (compile-value b)] - [(Char c) (compile-value c)] - [(Eof) (compile-value eof)] - [(Empty) (compile-value '())] - [(Str s) (compile-string s)] - [(Symb s) (compile-symbol s)] - [(Var x) (compile-variable x c)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] + [(Lit d) (compile-datum d)] + [(Eof) (seq (Mov rax (value->bits eof)))] + [(Var x) (compile-variable x c)] + [(Prim0 p) (compile-prim0 p)] + [(Prim1 p e) (compile-prim1 p e c)] + [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c t?)] - [(Begin e1 e2) (compile-begin e1 e2 c t?)] - [(Let x e1 e2) (compile-let x e1 e2 c t?)] - [(App e es) (compile-app e es c t?)] - [(Lam f xs e) (compile-lam f xs e c)] - [(Match e ps es) (compile-match e ps es c t?)])) + [(If e1 e2 e3) (compile-if e1 e2 e3 c t?)] + [(Begin e1 e2) (compile-begin e1 e2 c t?)] + [(Let x e1 e2) (compile-let x e1 e2 c t?)] + [(App e es) + (compile-app e es c t?)] + [(Lam f xs e) + (compile-lam f xs e c)] + [(Match e ps es) (compile-match e ps es c t?)])) -;; Symbol -> Asm -(define (compile-symbol s) - (seq (Lea rax (Mem (symbol->data-label s) type-symb)))) - -;; String -> Asm -(define (compile-string s) - (seq (Lea rax (Mem (symbol->data-label (string->symbol s)) type-str)))) - -;; Value -> Asm -(define (compile-value v) - (seq (Mov rax (value->bits v)))) ;; Id CEnv -> Asm (define (compile-variable x c) - (match (lookup x c) - [#f (error "unbound variable")] ;(seq (Lea rax (symbol->label x)))] - [i (seq (Mov rax (Mem rsp i)))])) + (let ((i (lookup x c))) + (seq (Mov rax (Mem rsp i))))) -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) +;; Op0 -> Asm +(define (compile-prim0 p) (compile-op0 p)) -;; Op1 Expr CEnv -> Asm (define (compile-prim1 p e c) (seq (compile-e e c #f) (compile-op1 p))) @@ -83,8 +150,7 @@ (Push rax) (compile-e e3 (cons #f (cons #f c)) #f) (compile-op3 p))) - -;; Expr Expr Expr CEnv Bool -> Asm +;; Expr Expr Expr CEnv Boolean -> Asm (define (compile-if e1 e2 e3 c t?) (let ((l1 (gensym 'if)) (l2 (gensym 'if))) @@ -96,25 +162,25 @@ (Label l1) (compile-e e3 c t?) (Label l2)))) - -;; Expr Expr CEnv Bool -> Asm +;; Expr Expr CEnv Boolean -> Asm (define (compile-begin e1 e2 c t?) (seq (compile-e e1 c #f) (compile-e e2 c t?))) - -;; Id Expr Expr CEnv Bool -> Asm +;; Id Expr Expr CEnv Boolean -> Asm (define (compile-let x e1 e2 c t?) (seq (compile-e e1 c #f) (Push rax) (compile-e e2 (cons x c) t?) (Add rsp 8))) -;; Id [Listof Expr] CEnv Bool -> Asm -(define (compile-app f es c t?) - ;(compile-app-nontail f es c) +;; Id [Listof Expr] CEnv -> Asm +;; The return address is placed above the arguments, so callee pops +;; arguments and return address is next frame +;; Expr [Listof Expr] CEnv Boolean -> Asm +(define (compile-app e es c t?) (if t? - (compile-app-tail f es c) - (compile-app-nontail f es c))) + (compile-app-tail e es c) + (compile-app-nontail e es c))) ;; Expr [Listof Expr] CEnv -> Asm (define (compile-app-tail e es c) @@ -123,8 +189,8 @@ (Add rsp (* 8 (length c))) (Mov rax (Mem rsp (* 8 (length es)))) (assert-proc rax) - (Xor rax type-proc) - (Mov rax (Mem rax 0)) + (Mov rax (Mem rax (- type-proc))) + (Mov r8 (length es)) ; pass arity info (Jmp rax))) ;; Integer Integer -> Asm @@ -147,19 +213,59 @@ (compile-es (cons e es) (cons #f c)) (Mov rax (Mem rsp i)) (assert-proc rax) - (Xor rax type-proc) - (Mov rax (Mem rax 0)) ; fetch the code label + (Mov rax (Mem rax (- type-proc))) ; fetch the code label + (Mov r8 (length es)) ; pass arity info (Jmp rax) (Label r)))) +;; Defns -> Asm +;; Compile the closures for ds and push them on the stack +(define (compile-defines-values ds) + (seq (alloc-defines ds 0) + (init-defines ds (reverse (define-ids ds)) 8) + (add-rbx-defines ds 0))) + +;; Defns Int -> Asm +;; Allocate closures for ds at given offset, but don't write environment yet +(define (alloc-defines ds off) + (match ds + ['() (seq)] + [(cons (Defn f xs e) ds) + (let ((fvs (fv (Lam f xs e)))) + (seq (Lea rax (symbol->label f)) + (Mov (Mem rbx off) rax) + (Mov rax rbx) + (Add rax off) + (Xor rax type-proc) + (Push rax) + (alloc-defines ds (+ off (* 8 (add1 (length fvs)))))))])) + +;; Defns CEnv Int -> Asm +;; Initialize the environment for each closure for ds at given offset +(define (init-defines ds c off) + (match ds + ['() (seq)] + [(cons (Defn f xs e) ds) + (let ((fvs (fv (Lam f xs e)))) + (seq (free-vars-to-heap fvs c off) + (init-defines ds c (+ off (* 8 (add1 (length fvs)))))))])) + +;; Defns Int -> Asm +;; Compute adjustment to rbx for allocation of all ds +(define (add-rbx-defines ds n) + (match ds + ['() (seq (Add rbx (* n 8)))] + [(cons (Defn f xs e) ds) + (add-rbx-defines ds (+ n (add1 (length (fv (Lam f xs e))))))])) + ;; Id [Listof Id] Expr CEnv -> Asm (define (compile-lam f xs e c) (let ((fvs (fv (Lam f xs e)))) (seq (Lea rax (symbol->label f)) - (Mov (Mem rbx 0) rax) + (Mov (Mem rbx) rax) (free-vars-to-heap fvs c 8) (Mov rax rbx) ; return value - (Or rax type-proc) + (Xor rax type-proc) (Add rbx (* 8 (add1 (length fvs))))))) ;; [Listof Id] CEnv Int -> Asm @@ -172,38 +278,6 @@ (Mov (Mem rbx off) r8) (free-vars-to-heap fvs c (+ off 8)))])) -;; [Listof Lam] -> Asm -(define (compile-lambda-defines ls) - (match ls - ['() (seq)] - [(cons l ls) - (seq (compile-lambda-define l) - (compile-lambda-defines ls))])) - -;; Lam -> Asm -(define (compile-lambda-define l) - (let ((fvs (fv l))) - (match l - [(Lam f xs e) - (let ((env (append (reverse fvs) (reverse xs) (list #f)))) - (seq (Label (symbol->label f)) - (Mov rax (Mem rsp (* 8 (length xs)))) - (Xor rax type-proc) - (copy-env-to-stack fvs 8) - (compile-e e env #t) - (Add rsp (* 8 (length env))) ; pop env - (Ret)))]))) - -;; [Listof Id] Int -> Asm -;; Copy the closure environment at given offset to stack -(define (copy-env-to-stack fvs off) - (match fvs - ['() (seq)] - [(cons _ fvs) - (seq (Mov r9 (Mem rax off)) - (Push r9) - (copy-env-to-stack fvs (+ 8 off)))])) - ;; [Listof Expr] CEnv -> Asm (define (compile-es es c) (match es @@ -219,7 +293,7 @@ (seq (compile-e e c #f) (Push rax) ; save away to be restored by each clause (compile-match-clauses ps es (cons #f c) done t?) - (Jmp 'raise_error_align) + (Jmp 'err) (Label done) (Add rsp 8)))) ; pop the saved value being matched @@ -236,7 +310,7 @@ (let ((next (gensym))) (match (compile-pattern p '() next) [(list i cm) - (seq (Mov rax (Mem rsp 0)) ; restore value being matched + (seq (Mov rax (Mem rsp)) ; restore value being matched i (compile-e e (append cm c) t?) (Add rsp (* 8 (length cm))) @@ -246,48 +320,21 @@ ;; Pat CEnv Symbol -> (list Asm CEnv) (define (compile-pattern p cm next) (match p - [(PWild) + [(Var '_) (list (seq) cm)] - [(PVar x) + [(Var x) (list (seq (Push rax)) (cons x cm))] - [(PStr s) - (let ((ok (gensym)) - (fail (gensym))) - (list (seq (Lea rdi (symbol->data-label (string->symbol s))) - (Mov r8 rax) - (And r8 ptr-mask) - (Cmp r8 type-str) - (Je ok) - (Label fail) - (Add rsp (* 8 (length cm))) - (Jmp next) - (Label ok) - (Xor rax type-str) - (Mov rsi rax) - pad-stack - (Call 'symb_cmp) - unpad-stack - (Cmp rax 0) - (Jne fail)) - cm))] - [(PSymb s) - (let ((ok (gensym))) - (list (seq (Lea r9 (Mem (symbol->data-label s) type-symb)) - (Cmp rax r9) - (Je ok) - (Add rsp (* 8 (length cm))) - (Jmp next) - (Label ok)) - cm))] - [(PLit l) + [(Lit l) (let ((ok (gensym))) - (list (seq (Cmp rax (value->bits l)) + (list (seq (Mov r8 rax) + (compile-datum l) + (Cmp rax r8) (Je ok) (Add rsp (* 8 (length cm))) (Jmp next) (Label ok)) cm))] - [(PAnd p1 p2) + [(Conj p1 p2) (match (compile-pattern p1 (cons #f cm) next) [(list i1 cm1) (match (compile-pattern p2 cm1 next) @@ -298,7 +345,7 @@ (Mov rax (Mem rsp (* 8 (- (sub1 (length cm1)) (length cm))))) i2) cm2)])])] - [(PBox p) + [(Box p) (match (compile-pattern p cm next) [(list i1 cm1) (let ((ok (gensym))) @@ -310,11 +357,10 @@ (Add rsp (* 8 (length cm))) ; haven't pushed anything yet (Jmp next) (Label ok) - (Xor rax type-box) - (Mov rax (Mem rax 0)) + (Mov rax (Mem rax (- type-box))) i1) cm1))])] - [(PCons p1 p2) + [(Cons p1 p2) (match (compile-pattern p1 (cons #f cm) next) [(list i1 cm1) (match (compile-pattern p2 cm1 next) @@ -329,10 +375,20 @@ (Jmp next) (Label ok) (Xor rax type-cons) - (Mov r8 (Mem rax 0)) + (Mov r8 (Mem rax 8)) (Push r8) ; push cdr - (Mov rax (Mem rax 8)) ; mov rax car + (Mov rax (Mem rax 0)) ; mov rax car i1 (Mov rax (Mem rsp (* 8 (- (sub1 (length cm1)) (length cm))))) i2) cm2))])])])) + +;; Id CEnv -> Integer +(define (lookup x cenv) + (match cenv + ['() (error "undefined variable:" x)] + [(cons y rest) + (match (eq? x y) + [#t 0] + [#f (+ 8 (lookup x rest))])])) + diff --git a/mountebank/executor/decode.rkt b/mountebank/executor/decode.rkt new file mode 100644 index 0000000..4ba7f96 --- /dev/null +++ b/mountebank/executor/decode.rkt @@ -0,0 +1,54 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (mem-ref (- b type-box))))] + [(cons-bits? b) + (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) + (bits->value (mem-ref (+ 8 (- b type-cons)))))] + + [(vect-bits? b) + (let ((p (- b type-vect))) + (build-vector (bits->value (mem-ref p)) + (lambda (j) + (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] + [(str-bits? b) + (let ((p (- b type-str))) + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] + [(symb-bits? b) + (let ((p (- b type-symb))) + (string->symbol + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j))))))))] + [else (error "invalid bits")])) + +(define (mem-ref i) + (ptr-ref (cast i _int64 _pointer) _int64)) + +(define (mem-ref32 i) + (ptr-ref (cast i _int64 _pointer) _int32)) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/mountebank/executor/exec.rkt b/mountebank/executor/exec.rkt new file mode 100644 index 0000000..9217a1d --- /dev/null +++ b/mountebank/executor/exec.rkt @@ -0,0 +1,70 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (symb-ptr->string p) + (define len (bits->value (ptr-ref p _uint64 0))) + (define cp-base (ptr-add p 8 _byte)) + (build-string + len + (λ (i) + (integer->char (ptr-ref cp-base _uint32 i))))) + +(define (exec/state prog) + (define intern-table (make-hash)) + (define (intern-symbol/cb p) + (define s (symb-ptr->string p)) + (hash-ref! intern-table s (λ () p))) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)) + (extern 'intern_symbol + intern-symbol/cb + (_fun _pointer -> _pointer)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/mountebank/executor/run.rkt b/mountebank/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/mountebank/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/mountebank/interp-defun.rkt b/mountebank/interp-defun.rkt deleted file mode 100644 index c4bcc05..0000000 --- a/mountebank/interp-defun.rkt +++ /dev/null @@ -1,156 +0,0 @@ -#lang racket -(provide interp interp-env (struct-out Closure) zip) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Datum -;; | Eof -;; | Void -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) -;; | (Closure [Listof Id] Expr Env) -(struct Closure (xs e r) #:prefab) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Quote d) d] - [(Eof) eof] - [(Var x) (interp-var x r ds)] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(Lam _ xs e) - (Closure xs e r)] - [(App e es) - (match (interp-env e r ds) - ['err 'err] - [f - (match (interp-env* es r ds) - ['err 'err] - [vs - (match f - [(Closure xs e r) - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (append (zip xs vs) r) ds) - 'err)] - [_ 'err])])])] - [(Match e ps es) - (match (interp-env e r ds) - ['err 'err] - [v - (interp-match v ps es r ds)])])) - -;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer -(define (interp-match v ps es r ds) - (match* (ps es) - [('() '()) 'err] - [((cons p ps) (cons e es)) - (match (interp-match-pat p v r) - [#f (interp-match v ps es r ds)] - [r (interp-env e r ds)])])) - -;; Pat Value Env -> [Maybe Env] -(define (interp-match-pat p v r) - (match p - [(PWild) r] - [(PVar x) (ext r x v)] - [(PSymb s) (and (eq? s v) r)] - [(PStr s) (and (string? v) (string=? s v) r)] - [(PLit l) (and (eqv? l v) r)] - [(PBox p) - (match v - [(box v) - (interp-match-pat p v r)] - [_ #f])] - [(PCons p1 p2) - (match v - [(cons v1 v2) - (match (interp-match-pat p1 v1 r) - [#f #f] - [r1 (interp-match-pat p2 v2 r1)])] - [_ #f])] - [(PAnd p1 p2) - (match (interp-match-pat p1 v r) - [#f #f] - [r1 (interp-match-pat p2 v r1)])])) - -;; Id Env [Listof Defn] -> Answer -(define (interp-var x r ds) - (match (lookup r x) - ['err (match (defns-lookup ds x) - [(Defn f xs e) (interp-env (Lam f xs e) '() ds)] - [#f 'err])] - [v v])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> [Maybe Defn] -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/mountebank/interp-prims.rkt b/mountebank/interp-prims.rkt deleted file mode 100644 index 7797de6..0000000 --- a/mountebank/interp-prims.rkt +++ /dev/null @@ -1,74 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [(list 'vector? v) (vector? v)] - [(list 'vector-length (? vector?)) (vector-length v)] - [(list 'string? v) (string? v)] - [(list 'string-length (? string?)) (string-length v)] - [(list 'symbol? v) (symbol? v)] - [(list 'symbol->string (? symbol?)) (symbol->string v)] - [(list 'string->symbol (? string?)) (string->symbol v)] - [(list 'string->uninterned-symbol (? string?)) - (string->uninterned-symbol v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] - [(list 'make-vector (? integer?) _) - (if (<= 0 v1) - (make-vector v1 v2) - 'err)] - [(list 'vector-ref (? vector?) (? integer?)) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-ref v1 v2) - 'err)] - [(list 'make-string (? integer?) (? char?)) - (if (<= 0 v1) - (make-string v1 v2) - 'err)] - [(list 'string-ref (? string?) (? integer?)) - (if (<= 0 v2 (sub1 (string-length v1))) - (string-ref v1 v2) - 'err)] - [_ 'err])) - -;; Op3 Value Value Value -> Answer -(define (interp-prim3 p v1 v2 v3) - (match (list p v1 v2 v3) - [(list 'vector-set! (? vector?) (? integer?) _) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/mountebank/interp-stdin.rkt b/mountebank/interp-stdin.rkt deleted file mode 100644 index 965b9cc..0000000 --- a/mountebank/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read-all))))) - (unless (void? r) - (println r)))) diff --git a/mountebank/interp.rkt b/mountebank/interp.rkt deleted file mode 100644 index 3accf29..0000000 --- a/mountebank/interp.rkt +++ /dev/null @@ -1,155 +0,0 @@ -#lang racket -(provide interp interp-env) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Datum -;; | Eof -;; | Void -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) -;; | (Value ... -> Answer) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Quote d) d] - [(Eof) eof] - [(Var x) (interp-var x r ds)] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(Lam _ xs e) - (λ vs - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (append (zip xs vs) r) ds) - 'err))] - [(App e es) - (match (interp-env e r ds) - ['err 'err] - [f - (match (interp-env* es r ds) - ['err 'err] - [vs - (if (procedure? f) - (apply f vs) - 'err)])])] - [(Match e ps es) - (match (interp-env e r ds) - ['err 'err] - [v - (interp-match v ps es r ds)])])) - -;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer -(define (interp-match v ps es r ds) - (match* (ps es) - [('() '()) 'err] - [((cons p ps) (cons e es)) - (match (interp-match-pat p v r) - [#f (interp-match v ps es r ds)] - [r (interp-env e r ds)])])) - -;; Pat Value Env -> [Maybe Env] -(define (interp-match-pat p v r) - (match p - [(PWild) r] - [(PVar x) (ext r x v)] - [(PSymb s) (and (eq? s v) r)] - [(PStr s) (and (string? v) (string=? s v) r)] - [(PLit l) (and (eqv? l v) r)] - [(PBox p) - (match v - [(box v) - (interp-match-pat p v r)] - [_ #f])] - [(PCons p1 p2) - (match v - [(cons v1 v2) - (match (interp-match-pat p1 v1 r) - [#f #f] - [r1 (interp-match-pat p2 v2 r1)])] - [_ #f])] - [(PAnd p1 p2) - (match (interp-match-pat p1 v r) - [#f #f] - [r1 (interp-match-pat p2 v r1)])])) - -;; Id Env [Listof Defn] -> Answer -(define (interp-var x r ds) - (match (lookup r x) - ['err (match (defns-lookup ds x) - [(Defn f xs e) (interp-env (Lam f xs e) '() ds)] - [#f 'err])] - [v v])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> [Maybe Defn] -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/mountebank/env.rkt b/mountebank/interpreter/env.rkt similarity index 91% rename from mountebank/env.rkt rename to mountebank/interpreter/env.rkt index c43be9c..5c2ab01 100644 --- a/mountebank/env.rkt +++ b/mountebank/interpreter/env.rkt @@ -12,4 +12,5 @@ ;; Env Variable Value -> Value (define (ext r x i) - (cons (list x i) r)) \ No newline at end of file + (cons (list x i) r)) + diff --git a/evildoer/interp-io.rkt b/mountebank/interpreter/interp-io.rkt similarity index 52% rename from evildoer/interp-io.rkt rename to mountebank/interpreter/interp-io.rkt index 0550189..f0bb535 100644 --- a/evildoer/interp-io.rkt +++ b/mountebank/interpreter/interp-io.rkt @@ -1,17 +1,16 @@ #lang racket (provide interp/io) (require "interp.rkt") - -;; String Expr -> (Cons Value String) -;; Interpret e with given string as input, -;; return value and collected output as string -(define (interp/io e input) +;; String Prog -> (Cons Answer String) +;; Interpret p with given string as input, +;; return answer and collected output as string +(define (interp/io p input) (define result (box #f)) (define output (with-input-from-string input (λ () (with-output-to-string (λ () - (set-box! result (interp e))))))) + (set-box! result (interp p))))))) (cons (unbox result) output)) diff --git a/jig/interp-prims.rkt b/mountebank/interpreter/interp-prim.rkt similarity index 61% rename from jig/interp-prims.rkt rename to mountebank/interpreter/interp-prim.rkt index c7afbb4..ea46c7f 100644 --- a/jig/interp-prims.rkt +++ b/mountebank/interpreter/interp-prim.rkt @@ -1,18 +1,24 @@ #lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) +(provide interp-prim0 interp-prim1 interp-prim2 interp-prim3) -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) +;; Op0 -> Value +(define (interp-prim0 op) + (match op + ['read-byte (read-byte)] + ['peek-byte (peek-byte)] + ['void (void)])) + +;; Op1 Value -> Value { raises 'err } +(define (interp-prim1 op v) + (match (list op v) [(list 'add1 (? integer?)) (add1 v)] [(list 'sub1 (? integer?)) (sub1 v)] [(list 'zero? (? integer?)) (zero? v)] [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] [(list 'integer->char (? codepoint?)) (integer->char v)] + [(list 'char->integer (? char?)) (char->integer v)] + [(list 'write-byte (? byte?)) (write-byte v)] [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] [(list 'box v) (box v)] [(list 'unbox (? box?)) (unbox v)] [(list 'car (? pair?)) (car v)] @@ -24,46 +30,52 @@ [(list 'vector-length (? vector?)) (vector-length v)] [(list 'string? v) (string? v)] [(list 'string-length (? string?)) (string-length v)] - [_ 'err])) + [(list 'symbol? v) (symbol? v)] + [(list 'symbol->string (? symbol? v)) (symbol->string v)] + [(list 'string->symbol (? string? v)) (string->symbol v)] + [(list 'string->uninterned-symbol (? string? v)) + (string->uninterned-symbol v)] + [_ (raise 'err)])) -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] +;; Op2 Value Value -> Value { raises 'err } +(define (interp-prim2 op v1 v2) + (match (list op v1 v2) + [(list '+ (? integer?) (? integer?)) (+ v1 v2)] + [(list '- (? integer?) (? integer?)) (- v1 v2)] + [(list '< (? integer?) (? integer?)) (< v1 v2)] + [(list '= (? integer?) (? integer?)) (= v1 v2)] [(list 'eq? v1 v2) (eq? v1 v2)] + [(list 'cons v1 v2) (cons v1 v2)] [(list 'make-vector (? integer?) _) (if (<= 0 v1) (make-vector v1 v2) - 'err)] + (raise 'err))] [(list 'vector-ref (? vector?) (? integer?)) (if (<= 0 v2 (sub1 (vector-length v1))) (vector-ref v1 v2) - 'err)] + (raise 'err))] [(list 'make-string (? integer?) (? char?)) (if (<= 0 v1) (make-string v1 v2) - 'err)] + (raise 'err))] [(list 'string-ref (? string?) (? integer?)) (if (<= 0 v2 (sub1 (string-length v1))) (string-ref v1 v2) - 'err)] - [_ 'err])) + (raise 'err))] + [_ (raise 'err)])) -;; Op3 Value Value Value -> Answer +;; Op3 Value Value Value -> Value { raises 'err } (define (interp-prim3 p v1 v2 v3) (match (list p v1 v2 v3) [(list 'vector-set! (? vector?) (? integer?) _) (if (<= 0 v2 (sub1 (vector-length v1))) (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) + (raise 'err))] + [_ (raise 'err)])) ;; Any -> Boolean (define (codepoint? v) (and (integer? v) (or (<= 0 v 55295) (<= 57344 v 1114111)))) + diff --git a/mountebank/interpreter/interp-stdin.rkt b/mountebank/interpreter/interp-stdin.rkt new file mode 100644 index 0000000..7d85c32 --- /dev/null +++ b/mountebank/interpreter/interp-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "interp.rkt") +(require "../syntax/read-all.rkt") + +;; -> Void +;; Parse and interpret contents of stdin, +;; print result on stdout +(define (main) + (read-line) ; ignore #lang racket line + (println (interp (apply parse-closed (read-all))))) + diff --git a/mountebank/interpreter/interp.rkt b/mountebank/interpreter/interp.rkt new file mode 100644 index 0000000..46d5c35 --- /dev/null +++ b/mountebank/interpreter/interp.rkt @@ -0,0 +1,136 @@ +#lang racket +(provide interp interp-e) +(provide interp-match-pat) +(require "../syntax/ast.rkt") +(require "interp-prim.rkt") +(require "env.rkt") + +;; type Value = +;; | Integer +;; | Boolean +;; | Character +;; | Eof +;; | Void +;; | '() +;; | (cons Value Value) +;; | (box Value) +;; | (string Character ...) +;; | (vector Value ...) +;; | (Value ... -> Answer) + +;; type Answer = Value | 'err + +;; type Env = (Listof (List Id Value)) + +(define (err? x) (eq? x 'err)) +;; ClosedExpr -> Answer +;; Prog -> Answer +(define (interp p) + (with-handlers ([err? identity]) + (match p + [(Prog ds e) + (interp-e e '() ds)]))) +;l Expr Env Defns -> Value { raises 'err } +(define (interp-e e r ds) ;; where r closes e + (match e + [(Var x) (interp-var x r ds)] + [(Lit d) d] + [(Eof) eof] + [(Prim0 p) + (interp-prim0 p)] + [(Prim1 p e) + (interp-prim1 p (interp-e e r ds))] + [(Prim2 p e1 e2) + (interp-prim2 p + (interp-e e1 r ds) + (interp-e e2 r ds))] + [(Prim3 p e1 e2 e3) + (interp-prim3 p + (interp-e e1 r ds) + (interp-e e2 r ds) + (interp-e e3 r ds))] + [(If e1 e2 e3) + (if (interp-e e1 r ds) + (interp-e e2 r ds) + (interp-e e3 r ds))] + [(Begin e1 e2) + (begin (interp-e e1 r ds) + (interp-e e2 r ds))] + [(Let x e1 e2) + (let ((v (interp-e e1 r ds))) + (interp-e e2 (ext r x v) ds))] + [(App e es) + (let ((f (interp-e e r ds)) + (vs (interp-e* es r ds))) + (if (procedure? f) + (apply f vs) + (raise 'err)))] + [(Match e ps es) + (let ((v (interp-e e r ds))) + (interp-match v ps es r ds))] + [(Lam f xs e) + (λ vs + ; check arity matches + (if (= (length xs) (length vs)) + (interp-e e (append (zip xs vs) r) ds) + (raise 'err)))])) + +;; (Listof Expr) REnv Defns -> (Listof Value) { raises 'err } +(define (interp-e* es r ds) + (match es + ['() '()] + [(cons e es) + (cons (interp-e e r ds) + (interp-e* es r ds))])) + +;; Id Env [Listof Defn] -> Answer +(define (interp-var x r ds) + (match (lookup r x) + ['err (match (defns-lookup ds x) + [(Defn f xs e) (interp-e (Lam f xs e) '() ds)] + [#f 'err])] + [v v])) + +;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer +(define (interp-match v ps es r ds) + (match* (ps es) + [('() '()) 'err] + [((cons p ps) (cons e es)) + (match (interp-match-pat p v r) + [#f (interp-match v ps es r ds)] + [r (interp-e e r ds)])])) +;; Pat Value Env -> [Maybe Env] +(define (interp-match-pat p v r) + (match p + [(Var '_) r] + [(Var x) (ext r x v)] + [(Lit l) (and (eqv? l v) r)] + [(Box p) + (match v + [(box v) + (interp-match-pat p v r)] + [_ #f])] + [(Cons p1 p2) + (match v + [(cons v1 v2) + (match (interp-match-pat p1 v1 r) + [#f #f] + [r1 (interp-match-pat p2 v2 r1)])] + [_ #f])] + [(Conj p1 p2) + (match (interp-match-pat p1 v r) + [#f #f] + [r1 (interp-match-pat p2 v r1)])])) + +;; Defns Symbol -> Defn +(define (defns-lookup ds f) + (findf (match-lambda [(Defn g _ _) (eq? f g)]) + ds)) + +(define (zip xs ys) + (match* (xs ys) + [('() '()) '()] + [((cons x xs) (cons y ys)) + (cons (list x y) + (zip xs ys))])) + diff --git a/mountebank/main.c b/mountebank/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/mountebank/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/mountebank/main.rkt b/mountebank/main.rkt new file mode 100644 index 0000000..f9851a3 --- /dev/null +++ b/mountebank/main.rkt @@ -0,0 +1,18 @@ +#lang racket +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) + diff --git a/mountebank/parse-file.rkt b/mountebank/parse-file.rkt deleted file mode 100644 index a502132..0000000 --- a/mountebank/parse-file.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; String -> Void -;; Compile contents of given file name, -;; emit asm code on stdout -(define (main fn) - (let ((p (open-input-file fn))) - (begin - (read-line p) ; ignore #lang racket line - (displayln (parse (read-all p))) - (close-input-port p)))) diff --git a/mountebank/parse.rkt b/mountebank/parse.rkt deleted file mode 100644 index 29d4db4..0000000 --- a/mountebank/parse.rkt +++ /dev/null @@ -1,112 +0,0 @@ -#lang racket -(provide parse parse-define parse-e) -(require "ast.rkt") - -;; [Listof S-Expr] -> Prog -(define (parse s) - (match s - [(cons (and (cons 'define _) d) s) - (match (parse s) - [(Prog ds e) - (Prog (cons (parse-define d) ds) e)])] - [(cons e '()) (Prog '() (parse-e e))] - [_ (error "program parse error")])) - -;; S-Expr -> Defn -(define (parse-define s) - (match s - [(list 'define (list-rest (? symbol? f) xs) e) - (if (andmap symbol? xs) - (Defn f xs (parse-e e)) - (error "parse definition error"))] - [_ (error "Parse defn error" s)])) - -;; S-Expr -> Expr -(define (parse-e s) - (match s - [(? self-quoting?) (Quote s)] - [(list 'quote d) (Quote d)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse-e e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'begin e1 e2) - (Begin (parse-e e1) (parse-e e2))] - [(list 'if e1 e2 e3) - (If (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse-e e1) (parse-e e2))] - [(cons 'match (cons e ms)) - (parse-match (parse-e e) ms)] - [(list (or 'lambda 'λ) xs e) - (if (and (list? xs) - (andmap symbol? xs)) - (Lam (gensym 'lambda) xs (parse-e e)) - (error "parse lambda error"))] - [(cons e es) - (App (parse-e e) (map parse-e es))] - [_ (error "Parse error" s)])) - -(define (parse-match e ms) - (match ms - ['() (Match e '() '())] - [(cons (list p r) ms) - (match (parse-match e ms) - [(Match e ps es) - (Match e - (cons (parse-pat p) ps) - (cons (parse-e r) es))])])) - -(define (parse-pat p) - (match p - [(? boolean?) (PLit p)] - [(? exact-integer?) (PLit p)] - [(? char?) (PLit p)] - ['_ (PWild)] - [(? symbol?) (PVar p)] - [(? string?) (PStr p)] - [(list 'quote (? symbol? s)) - (PSymb s)] - [(list 'quote (list)) - (PLit '())] - [(list 'box p) - (PBox (parse-pat p))] - [(list 'cons p1 p2) - (PCons (parse-pat p1) (parse-pat p2))] - [(list 'and p1 p2) - (PAnd (parse-pat p1) (parse-pat p2))] - [(cons 'list '()) - (PLit '())] - [(cons 'list (cons p1 ps)) - (PCons (parse-pat p1) - (parse-pat (cons 'list ps)))])) - -(define (self-quoting? x) - (or (integer? x) - (boolean? x) - (char? x) - (string? x) - (box? x) - (vector? x))) - -(define op0 - '(read-byte peek-byte void)) - -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length - symbol? symbol->string string->symbol string->uninterned-symbol)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/mountebank/run.rkt b/mountebank/run.rkt deleted file mode 100644 index eaa53eb..0000000 --- a/mountebank/run.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide run run/io) -(require "types.rkt" "build-runtime.rkt" - a86/interp) - -;; Asm -> Answer -(define (run is) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp is) - ['err 'err] - [b (bits->value b)]))) - -;; Asm String -> (cons Answer String) -(define (run/io is s) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp/io is s) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) diff --git a/mountebank/runtime.h b/mountebank/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/mountebank/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/mountebank/runtime/Makefile b/mountebank/runtime/Makefile new file mode 100644 index 0000000..ee8ff93 --- /dev/null +++ b/mountebank/runtime/Makefile @@ -0,0 +1,29 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + values.o \ + print.o \ + io.o \ + symbol.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/mountebank/char.c b/mountebank/runtime/char.c similarity index 100% rename from mountebank/char.c rename to mountebank/runtime/char.c diff --git a/mountebank/runtime/error.c b/mountebank/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/mountebank/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/mountebank/heap.h b/mountebank/runtime/heap.h similarity index 100% rename from mountebank/heap.h rename to mountebank/runtime/heap.h diff --git a/iniquity-gc/io.c b/mountebank/runtime/io.c similarity index 50% rename from iniquity-gc/io.c rename to mountebank/runtime/io.c index 7ef8228..9f1fc45 100644 --- a/iniquity-gc/io.c +++ b/mountebank/runtime/io.c @@ -1,25 +1,25 @@ #include -#include -#include "types.h" +#include #include "values.h" #include "runtime.h" val_t read_byte(void) { - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + int c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + int c = getc(stdin); + if (c != EOF) + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); - } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + int b = val_unwrap_int(c); + putc((unsigned char)b, stdout); return val_wrap_void(); } diff --git a/mountebank/runtime/main.c b/mountebank/runtime/main.c new file mode 100644 index 0000000..610b2bf --- /dev/null +++ b/mountebank/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/neerdowell/print.c b/mountebank/runtime/print.c similarity index 100% rename from neerdowell/print.c rename to mountebank/runtime/print.c diff --git a/loot/print.h b/mountebank/runtime/print.h similarity index 100% rename from loot/print.h rename to mountebank/runtime/print.h diff --git a/mountebank/runtime/runtime.h b/mountebank/runtime/runtime.h new file mode 100644 index 0000000..2ec5ef1 --- /dev/null +++ b/mountebank/runtime/runtime.h @@ -0,0 +1,27 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +/* + * Entry point for compiled programs. + * + * The caller supplies the heap pointer. Compiled code may use this as its + * initial allocation pointer / runtime heap base according to the language's + * calling convention. + */ +val_t entry(val_t *heap); + +/* + * Language-facing runtime operations used by compiled code. + * + * These are implemented by the runtime core, typically in terms of lower-level + * host hooks declared in host.h. + */ +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/mountebank/symbol.c b/mountebank/runtime/symbol.c similarity index 100% rename from mountebank/symbol.c rename to mountebank/runtime/symbol.c diff --git a/neerdowell/types.h b/mountebank/runtime/types.h similarity index 67% rename from neerdowell/types.h rename to mountebank/runtime/types.h index ec7db8b..084310e 100644 --- a/neerdowell/types.h +++ b/mountebank/runtime/types.h @@ -2,23 +2,26 @@ #define TYPES_H /* - Bit layout of values + * Bit layout of runtime values + * + * Values are either: + * - immediates, tagged with low bits ending in #b000 + * - pointers, tagged with one of the pointer tags below + * + * Immediates include: + * - integers + * - characters + * - booleans + * - eof + * - void + * - empty list + */ - Values are either: - - Immediates: end in #b000 - - Pointers - - Immediates are either - - Integers: end in #b0 000 - - Characters: end in #b01 000 - - True: #b11 000 - - False: #b1 11 000 - - Eof: #b10 11 000 - - Void: #b11 11 000 - - Empty: #b100 11 000 -*/ +/* low bits reserved for pointer/immediate discrimination */ #define imm_shift 3 #define ptr_type_mask ((1 << imm_shift) - 1) + +/* pointer tags */ #define box_type_tag 1 #define cons_type_tag 2 #define vect_type_tag 3 @@ -26,18 +29,24 @@ #define proc_type_tag 5 #define symb_type_tag 6 #define struct_type_tag 7 + +/* integer immediates */ #define int_shift (1 + imm_shift) #define int_type_mask ((1 << int_shift) - 1) #define int_type_tag (0 << (int_shift - 1)) #define nonint_type_tag (1 << (int_shift - 1)) + +/* character immediates */ #define char_shift (int_shift + 1) #define char_type_mask ((1 << char_shift) - 1) #define char_type_tag ((0 << (char_shift - 1)) | nonint_type_tag) #define nonchar_type_tag ((1 << (char_shift - 1)) | nonint_type_tag) + +/* distinguished immediate constants */ #define val_true ((0 << char_shift) | nonchar_type_tag) #define val_false ((1 << char_shift) | nonchar_type_tag) #define val_eof ((2 << char_shift) | nonchar_type_tag) #define val_void ((3 << char_shift) | nonchar_type_tag) #define val_empty ((4 << char_shift) | nonchar_type_tag) -#endif +#endif /* TYPES_H */ diff --git a/hoax/types.rkt b/mountebank/runtime/types.rkt similarity index 51% rename from hoax/types.rkt rename to mountebank/runtime/types.rkt index c0c1d70..79c8486 100644 --- a/hoax/types.rkt +++ b/mountebank/runtime/types.rkt @@ -1,6 +1,5 @@ #lang racket (provide (all-defined-out)) -(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -9,6 +8,9 @@ (define type-cons #b010) (define type-vect #b011) (define type-str #b100) +(define type-proc #b101) +(define type-symb #b110) +(define type-bint #b110) (define int-shift (+ 1 imm-shift)) (define mask-int #b1111) (define char-shift (+ 2 imm-shift)) @@ -16,35 +18,6 @@ (define type-char #b01000) (define mask-char #b11111) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (mem-ref (- b type-box))))] - [(cons-bits? b) - (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) - (bits->value (mem-ref (+ 8 (- b type-cons)))))] - - [(vect-bits? b) - (let ((p (- b type-vect))) - (build-vector (bits->value (mem-ref p)) - (lambda (j) - (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] - [(str-bits? b) - (let ((p (- b type-str))) - (build-string (bits->value (mem-ref p)) - (lambda (j) - (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] - [else (error "invalid bits")])) - ;; Value -> Integer ;; v must be an immediate (define (value->bits v) @@ -80,9 +53,12 @@ (define (str-bits? v) (= type-str (bitwise-and v imm-mask))) -(define (mem-ref i) - (ptr-ref (cast i _int64 _pointer) _int64)) +(define (bignum-bits? v) + (= type-bint (bitwise-and v imm-mask))) + +(define (proc-bits? v) + (= type-proc (bitwise-and v imm-mask))) -(define (mem-ref32 i) - (ptr-ref (cast i _int64 _pointer) _int32)) +(define (symb-bits? v) + (= type-symb (bitwise-and v imm-mask))) diff --git a/neerdowell/values.c b/mountebank/runtime/values.c similarity index 100% rename from neerdowell/values.c rename to mountebank/runtime/values.c diff --git a/mountebank/runtime/values.h b/mountebank/runtime/values.h new file mode 100644 index 0000000..5c41275 --- /dev/null +++ b/mountebank/runtime/values.h @@ -0,0 +1,119 @@ +#ifndef VALUES_H +#define VALUES_H + +#include + +/* + * Abstract runtime value. + * + * All language values are represented as a tagged 64-bit word. + */ +typedef int64_t val_t; + +/* + * Dynamic type tags used by the runtime and printing code. + */ +typedef enum type_t { + T_INVALID = -1, + + /* immediates */ + T_INT, + T_BOOL, + T_CHAR, + T_EOF, + T_VOID, + T_EMPTY, + + /* heap objects */ + T_BOX, + T_CONS, + T_VECT, + T_STR, + T_SYMB, + T_PROC, + T_STRUCT, +} type_t; + +typedef uint32_t val_char_t; + +/* + * Heap object layouts. + * + * These layouts correspond to the pointer-tagged representations in types.h. + */ +typedef struct val_box_t { + val_t val; +} val_box_t; + +typedef struct val_cons_t { + val_t snd; + val_t fst; +} val_cons_t; + +typedef struct val_vect_t { + uint64_t len; + val_t elems[]; +} val_vect_t; + +typedef struct val_str_t { + uint64_t len; + val_char_t codepoints[]; +} val_str_t; + +typedef struct val_symb_t { + uint64_t len; + val_char_t codepoints[]; +} val_symb_t; + +typedef struct val_struct_t { + val_t name; + val_t *vals; +} val_struct_t; + +/* + * Classify a runtime value. + */ +type_t val_typeof(val_t x); + +/* + * Wrap/unwrap operations. + * + * The behavior of unwrap functions is undefined on type mismatch. + */ + +/* integers */ +int64_t val_unwrap_int(val_t x); +val_t val_wrap_int(int64_t i); + +/* booleans */ +int val_unwrap_bool(val_t x); +val_t val_wrap_bool(int b); + +/* characters */ +val_char_t val_unwrap_char(val_t x); +val_t val_wrap_char(val_char_t c); + +/* special values */ +val_t val_wrap_eof(void); +val_t val_wrap_void(void); + +/* heap objects */ +val_box_t *val_unwrap_box(val_t x); +val_t val_wrap_box(val_box_t *b); + +val_cons_t *val_unwrap_cons(val_t x); +val_t val_wrap_cons(val_cons_t *c); + +val_vect_t *val_unwrap_vect(val_t x); +val_t val_wrap_vect(val_vect_t *v); + +val_str_t *val_unwrap_str(val_t x); +val_t val_wrap_str(val_str_t *v); + +val_symb_t *val_unwrap_symb(val_t x); +val_t val_wrap_symb(val_symb_t *v); + +val_struct_t *val_unwrap_struct(val_t x); +val_t val_wrap_struct(val_struct_t *v); + +#endif /* VALUES_H */ diff --git a/mountebank/simple-interp.rkt b/mountebank/simple-interp.rkt deleted file mode 100644 index e2eb2b6..0000000 --- a/mountebank/simple-interp.rkt +++ /dev/null @@ -1,59 +0,0 @@ -#lang racket - -;; type Expr = Number -;; | Boolean -;; | (list Op1 Expr) -;; | (list Op2 Expr) -;; | (list 'if Expr Expr Expr) -;; | (list Expr Expr) -;; | (list 'λ (list Id) Expr) -;; | Id - -;; type Id = Symbol -;; type Op1 = 'sub1 | 'zero? -;; type Op2 = '+ - -;; type Value = Number -;; | Boolean -;; | (Value -> Value) - -;; Expr Env -> Value -(define (interp e r) - (match e - [(list '+ e1 e2) - (+ (interp e1 r) (interp e2 r))] - [(list 'sub1 e1) - (sub1 (interp e1 r))] - [(list 'zero? e1) - (zero? (interp e1 r))] - [(list 'if e1 e2 e3) - (if (interp e1 r) - (interp e2 r) - (interp e3 r))] - [(list 'λ (list x) e1) - (λ (v) (interp e1 (cons (cons x v) r)))] - [(list e1 e2) - ((interp e1 r) (interp e2 r))] - [_ - (if (symbol? e) - (lookup e r) - e)])) - -;; Id Env -> Value -(define (lookup x r) - (match r - [(cons (cons y v) r) - (if (eq? x y) - v - (lookup x r))])) - -(interp '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36) - '()) diff --git a/mountebank/syntax/ast.rkt b/mountebank/syntax/ast.rkt new file mode 100644 index 0000000..8330791 --- /dev/null +++ b/mountebank/syntax/ast.rkt @@ -0,0 +1,75 @@ +#lang racket +(provide Lit Prim0 Prim1 Prim2 Prim3 If + Eof Begin + Let Var Prog Defn App + Match Box Cons Conj + Lam) + +;; type Prog = (Prog (Listof Defn) Expr) +(struct Prog (ds e) #:prefab) + +;; type Defn = (Defn Id (Listof Id) Expr) +(struct Defn (f xs e) #:prefab) +;; type Expr = (Lit Datum) +;; | (Eof) +;; | (Prim0 Op0) +;; | (Prim1 Op1 Expr) +;; | (Prim2 Op2 Expr Expr) +;; | (Prim3 Op3 Expr Expr Expr) +;; | (If Expr Expr Expr) +;; | (Begin Expr Expr) +;; | (Let Id Expr Expr) +;; | (Var Id) +;; | (App Expr (Listof Expr)) +;; | (Match Expr (Listof Pat) (Listof Expr)) +;; | (Lam Id (Listof Id) Expr) + +;; type ClosedExpr = { e ∈ Expr | e contains no free variables } + +;; type Id = Symbol +;; type Datum = Integer +;; | Boolean +;; | Character +;; | '() +;; | String +;; | Symbol +;; type Op0 = 'read-byte | 'peek-byte | 'void +;; type Op1 = 'add1 | 'sub1 +;; | 'zero? +;; | 'char? | 'integer->char | 'char->integer +;; | 'write-byte | 'eof-object? +;; | 'car | 'cdr | 'unbox +;; | 'empty? | 'cons? | 'box? +;; | 'box +;; | 'vector? | 'vector-length +;; | 'string? | 'string-length +;; | 'symbol? | 'symbol->string | 'string->symbol | 'string->uninterned-symbol +;; type Op2 = '+ | '- | '< | '= +;; | 'eq? | 'cons +;; | 'make-vector | 'vector-ref +;; | 'make-string | 'string-ref +;; type Op3 = 'vector-set! +;; type Pat = (Var Id) +;; | (Lit Datum) +;; | (Box Pat) +;; | (Cons Pat Pat) +;; | (Conj Pat Pat) + +(struct Eof () #:prefab) +(struct Lit (d) #:prefab) +(struct Prim0 (p) #:prefab) +(struct Prim1 (p e) #:prefab) +(struct Prim2 (p e1 e2) #:prefab) +(struct Prim3 (p e1 e2 e3) #:prefab) +(struct If (e1 e2 e3) #:prefab) +(struct Begin (e1 e2) #:prefab) +(struct Let (x e1 e2) #:prefab) +(struct Var (x) #:prefab) +(struct App (f es) #:prefab) +(struct Lam (f xs e) #:prefab) +(struct Match (e ps es) #:prefab) + +(struct Box (p) #:prefab) +(struct Cons (p1 p2) #:prefab) +(struct Conj (p1 p2) #:prefab) + diff --git a/mountebank/fv.rkt b/mountebank/syntax/fv.rkt similarity index 83% rename from mountebank/fv.rkt rename to mountebank/syntax/fv.rkt index 2377b7e..1cec0d9 100644 --- a/mountebank/fv.rkt +++ b/mountebank/syntax/fv.rkt @@ -28,8 +28,9 @@ ;; Pat -> [Listof Id] (define (bv-pat* p) (match p - [(PVar x) (list x)] - [(PCons p1 p2) (append (bv-pat* p1) (bv-pat* p2))] - [(PAnd p1 p2) (append (bv-pat* p1) (bv-pat* p2))] - [(PBox p) (bv-pat* p)] - [_ '()])) + [(Var x) (list x)] + [(Lit d) '()] + [(Box p) (bv-pat* p)] + [(Cons p1 p2) (append (bv-pat* p1) (bv-pat* p2))] + [(Conj p1 p2) (append (bv-pat* p1) (bv-pat* p2))])) + diff --git a/mountebank/lambdas.rkt b/mountebank/syntax/lambdas.rkt similarity index 100% rename from mountebank/lambdas.rkt rename to mountebank/syntax/lambdas.rkt index 0a24640..83c5aa8 100644 --- a/mountebank/lambdas.rkt +++ b/mountebank/syntax/lambdas.rkt @@ -2,7 +2,6 @@ (require "ast.rkt") (provide lambdas) - ;; Prog -> [Listof Lam] ;; List all of the lambda expressions in p (define (lambdas p) @@ -33,3 +32,4 @@ [(Lam f xs e1) (cons e (lambdas-e e1))] [(Match e ps es) (append (lambdas-e e) (append-map lambdas-e es))] [_ '()])) + diff --git a/mountebank/compile-literals.rkt b/mountebank/syntax/literals.rkt similarity index 58% rename from mountebank/compile-literals.rkt rename to mountebank/syntax/literals.rkt index e2484e1..f3f4fc7 100644 --- a/mountebank/compile-literals.rkt +++ b/mountebank/syntax/literals.rkt @@ -1,38 +1,8 @@ #lang racket -(provide compile-literals init-symbol-table literals) -(require "ast.rkt" - "utils.rkt" - a86/ast) +(provide literals symbols) -(define rdi 'rdi) +(require "ast.rkt") -;; Prog -> Asm -(define (compile-literals p) - (append-map compile-literal (literals p))) - -;; Symbol -> Asm -(define (compile-literal s) - (let ((str (symbol->string s))) - (seq (Label (symbol->data-label s)) - (Dq (string-length str)) - (compile-string-chars (string->list str)) - (if (odd? (string-length str)) - (seq (Dd 0)) - (seq))))) - -;; Prog -> Asm -;; Call intern_symbol on every symbol in the program -(define (init-symbol-table p) - (match (symbols p) - ['() (seq)] - [ss (seq (Sub 'rsp 8) - (append-map init-symbol ss) - (Add 'rsp 8))])) - -;; Symbol -> Asm -(define (init-symbol s) - (seq (Lea rdi (symbol->data-label s)) - (Call 'intern_symbol))) ;; Prog -> [Listof Symbol] (define (literals p) @@ -64,7 +34,7 @@ ;; Expr -> [Listof (U Symbol String)] (define (literals-e e) (match e - [(Quote d) (literals-datum d)] + [(Lit d) (literals-datum d)] [(Prim1 p e) (literals-e e)] [(Prim2 p e1 e2) @@ -85,20 +55,6 @@ (append (literals-e e) (append-map literals-match-clause ps es))] [_ '()])) -;; Pat Expr -> [Listof Symbol] -(define (literals-match-clause p e) - (append (literals-pat p) (literals-e e))) - -;; Pat -> [Listof (U Symbol String)] -(define (literals-pat p) - (match p - [(PSymb s) (list s)] - [(PStr s) (list s)] - [(PBox p) (literals-pat p)] - [(PCons p1 p2) (append (literals-pat p1) (literals-pat p2))] - [(PAnd p1 p2) (append (literals-pat p1) (literals-pat p2))] - [_ '()])) - ;; Datum -> [Listof (U Symbol String)] (define (literals-datum d) (cond @@ -113,10 +69,16 @@ (append-map literals-datum (vector->list d))] [else '()])) -;; [Listof Char] -> Asm -(define (compile-string-chars cs) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Dd (char->integer c)) - (compile-string-chars cs))])) +;; Pat Expr -> [Listof (U Symbol String)] +(define (literals-match-clause p e) + (append (literals-pat p) (literals-e e))) + +;; Pat -> [Listof (U Symbol String)] +(define (literals-pat p) + (match p + [(Lit d) (literals-datum d)] + [(Box p) (literals-pat p)] + [(Cons p1 p2) (append (literals-pat p1) (literals-pat p2))] + [(Conj p1 p2) (append (literals-pat p1) (literals-pat p2))] + [_ '()])) + diff --git a/mountebank/syntax/parse.rkt b/mountebank/syntax/parse.rkt new file mode 100644 index 0000000..067e7c9 --- /dev/null +++ b/mountebank/syntax/parse.rkt @@ -0,0 +1,276 @@ +#lang racket +(provide parse parse-closed parse-e parse-define parse-pattern) +(require "ast.rkt") + +;; [Listof S-Expr] -> Prog +(define (parse . ss) + (match (parse-prog ss (parse-defn-names ss) '()) + [(list _ p) p])) + +;; [Listof S-Expr] -> ClosedProg +(define (parse-closed . ss) + (match (parse-prog ss (parse-defn-names ss) '()) + [(list '() p) p] + [(list ys p) (error "undefined identifiers" ys)])) + +;; S-Expr -> Expr +;; Parse a (potentially open) expression +(define (parse-e s) + (match (parse-e/acc s '() '()) + [(list _ e) e])) + +;; S-Expr -> Expr +;; Parse a (potentially open) definition +(define (parse-define s) + (match (parse-define/acc s '() '()) + [(list _ d) d])) + +;; S-Expr -> Pat +;; Parse a (potentially open) pattern +(define (parse-pattern s) + (match (parse-match-pattern/acc s '() '()) + [(list _ _ p) p])) + +;; S-Expr -> r:[Listof Id] +;; where: (distinct? r) +;; Extracts defined function names from given program-like s-expr +;; Does not fully parse definition +;; Example: +;; (parse-defn-names '((define (f x) x) (define (g y) y) 1) -> '(f g) +(define (parse-defn-names ss) + (define (rec ss fs) + (match ss + [(list s) fs] + [(cons (cons (? (not-in fs) 'define) sd) sr) + (match (parse-defn-name sd) + [f (if (memq f fs) + (error "duplicate definition" f) + (rec sr (cons f fs)))])] + [_ (error "parse error")])) + (rec ss '())) + +(define (parse-defn-name s) + (match s + [(cons (cons (? symbol? f) _) _) f] + [_ (error "parse error")])) +;; S-Expr [Listof Id] [Listof Id] -> (list [Listof Id] Prog) +;; s: program shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of program +(define (parse-prog s xs ys) + (match s + [(list s) + (match (parse-e/acc s xs ys) + [(list ys e) + (list ys (Prog '() e))])] + [(cons s ss) + (match (parse-define/acc s xs ys) + [(list ys (and d (Defn f _ _))) + (match (parse-prog ss xs ys) + [(list ys (Prog ds e)) + (list ys (Prog (cons d ds) e))])])])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] Defn) +;; s: definition shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of definition +(define (parse-define/acc s xs ys) + (match s + [(cons 'define sr) + (match sr + [(list (cons (? symbol? g) (and (list (? symbol? zs) ...) (? distinct?))) s) + (match (parse-e/acc s (cons g (append zs xs)) ys) + [(list ys e) + (list ys (Defn g zs e))])] + [_ (error "parse error")])] + [_ (error "parse error")])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] Expr) +;; s: expression shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of expression +(define (parse-e/acc s xs ys) + (define (rec s xs ys) + (define ns xs) + (match s + [(and 'eof (? (not-in ns))) + (list ys (Eof))] + [(? self-quoting-datum?) + (list ys (Lit s))] + [(list (and 'quote (? (not-in ns))) (list)) + (list ys (Lit '()))] + [(list (and 'quote (? (not-in ns))) (? datum? d)) + (list ys (Lit d))] + [(? symbol? f) + (if (memq s xs) + (list ys (Var s)) + (list (cons s ys) (Var s)))] + [(list-rest (? symbol? (? (not-in ns) k)) sr) + (match k + ['let + (match sr + [(list (list (list (? symbol? x) s1)) s2) + (match (rec s1 xs ys) + [(list ys e1) + (match (rec s2 (cons x xs) ys) + [(list ys e2) + (list ys (Let x e1 e2))])])] + [_ (error "let: bad syntax" s)])] + ['match + (match sr + [(cons s sr) + (match (rec s xs ys) + [(list ys e) + (match (parse-match-clauses/acc sr xs ys) + [(list ys ps es) + (list ys (Match e ps es))])])] + [_ (error "match: bad syntax" s)])] + + [(or 'λ 'lambda) + (match sr + [(list (and (list (? symbol? zs) ...) (? distinct?)) s) + (match (rec s (append zs xs) ys) + [(list ys e) + (list ys (Lam (gensym 'lambda) zs e))])] + [_ (error "lambda: bad syntax" s)])] + [_ + (match (parse-es/acc sr xs ys) + [(list ys es) + (match (cons k es) + [(list (? op0? o)) + (list ys (Prim0 o))] + [(list (? op1? o) e1) + (list ys (Prim1 o e1))] + [(list (? op2? o) e1 e2) + (list ys (Prim2 o e1 e2))] + [(list (? op3? o) e1 e2 e3) + (list ys (Prim3 o e1 e2 e3))] + [(list 'begin e1 e2) + (list ys (Begin e1 e2))] + [(list 'if e1 e2 e3) + (list ys (If e1 e2 e3))] + [(list-rest g es) + (list (cons g ys) (App (Var g) es))])])])] + [(cons s sr) + (match (parse-e/acc s xs ys) + [(list ys e) + (match (parse-es/acc sr xs ys) + [(list ys es) + (list ys (App e es))])])] + [_ + (error "parse error" s)])) + (rec s xs ys)) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Expr]) +;; s: list of expressions shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of expressions +(define (parse-es/acc s xs ys) + (match s + ['() (list ys '())] + [(cons s ss) + (match (parse-e/acc s xs ys) + [(list ys e) + (match (parse-es/acc ss xs ys) + [(list ys es) + (list ys (cons e es))])])] + [_ (error "parse error")])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Expr]) +;; s: list of match clauses shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and list of parsed clause patterns and clause expressions +(define (parse-match-clauses/acc sr xs ys) + (match sr + ['() (list ys '() '())] + [(cons (list sp se) sr) + (match (parse-match-pattern/acc sp xs ys) + [(list ys xs p) + (match (parse-e/acc se xs ys) + [(list ys e) + (match (parse-match-clauses/acc sr xs ys) + [(list ys ps es) + (list ys (cons p ps) (cons e es))])])])])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Pat) +;; s: list of patterns shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables, bound variables, and parse of pattern +(define (parse-match-pattern/acc s xs ys) + (define (rec p xs ys) + (match p + [(? self-quoting-datum?) (list ys xs (Lit p))] + ['_ (list ys xs (Var '_))] + [(? symbol?) (list ys (cons p xs) (Var p))] + [(list 'quote (? datum? d)) + (list ys xs (Lit d))] + [(list 'box s) + (match (rec s xs ys) + [(list ys xs p) + (list ys xs (Box p))])] + [(list 'cons s1 s2) + (match (rec s1 xs ys) + [(list ys xs p1) + (match (rec s2 xs ys) + [(list ys xs p2) + (list ys xs (Cons p1 p2))])])] + [(list 'and s1 s2) + (match (rec s1 xs ys) + [(list ys xs p1) + (match (rec s2 xs ys) + [(list ys xs p2) + (list ys xs (Conj p1 p2))])])] + [_ (error "parse pattern error")])) + (rec s xs ys)) + +;; [Listof Any] -> Boolean +(define (distinct? xs) + (not (check-duplicates xs))) + +;; xs:[Listof Any] -> p:(x:Any -> Boolean) +;; Produce a predicate p for things not in xs +(define (not-in xs) + (λ (x) (not (memq x xs)))) +(define (in m) + (λ (x) (memq x m))) + +;; Any -> Boolean +(define (self-quoting-datum? x) + (or (exact-integer? x) + (boolean? x) + (char? x) + (string? x) + (and (box? x) + (datum? (unbox x))) + (and (vector? x) + (andmap datum? (vector->list x))))) + +;; Any -> Boolean +(define (datum? x) + (or (self-quoting-datum? x) + (empty? x) + (symbol? x) + (and (pair? x) + (datum? (car x)) + (datum? (cdr x))))) + +;; Any -> Boolean +(define (op0? x) + (memq x '(read-byte peek-byte void))) + +(define (op1? x) + (memq x '(add1 sub1 zero? + char? integer->char char->integer + write-byte eof-object? + box unbox empty? cons? box? car cdr + vector? vector-length string? string-length + symbol? symbol->string string->symbol string->uninterned-symbol))) + +(define (op2? x) + (memq x '(+ - < = eq? cons + make-vector vector-ref make-string string-ref))) + +(define (op3? x) + (memq x '(vector-set!))) + diff --git a/mountebank/read-all.rkt b/mountebank/syntax/read-all.rkt similarity index 99% rename from mountebank/read-all.rkt rename to mountebank/syntax/read-all.rkt index 8a3289a..a83fe69 100644 --- a/mountebank/read-all.rkt +++ b/mountebank/syntax/read-all.rkt @@ -6,3 +6,4 @@ (if (eof-object? r) '() (cons r (read-all))))) + diff --git a/mountebank/test/build-runtime.rkt b/mountebank/test/build-runtime.rkt deleted file mode 100644 index 7023ee0..0000000 --- a/mountebank/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/mountebank/test/compile.rkt b/mountebank/test/compile.rkt deleted file mode 100644 index ee289de..0000000 --- a/mountebank/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../run.rkt") - -(test-runner (λ p (run (compile (parse p))))) -(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/mountebank/test/define-tests.rkt b/mountebank/test/define-tests.rkt new file mode 100644 index 0000000..880309b --- /dev/null +++ b/mountebank/test/define-tests.rkt @@ -0,0 +1,483 @@ +#lang racket +(provide test test/io) +(require rackunit) + +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) + + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7)) + + (begin ;; Con + (check-equal? (run '(if (zero? 0) 1 2)) 1) + (check-equal? (run '(if (zero? 1) 1 2)) 2) + (check-equal? (run '(if (zero? -7) 1 2)) 2) + (check-equal? (run '(if (zero? 0) + (if (zero? 1) 1 2) + 7)) + 2) + (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) + (if (zero? 1) 1 2) + 7)) + 7)) + + (begin ;; Dupe + (check-equal? (run #t) #t) + (check-equal? (run #f) #f) + (check-equal? (run '(if #t 1 2)) 1) + (check-equal? (run '(if #f 1 2)) 2) + (check-equal? (run '(if 0 1 2)) 1) + (check-equal? (run '(if #t 3 4)) 3) + (check-equal? (run '(if #f 3 4)) 4) + (check-equal? (run '(if 0 3 4)) 3) + (check-equal? (run '(zero? 4)) #f) + (check-equal? (run '(zero? 0)) #t)) + + (begin ;; Dodger + (check-equal? (run #\a) #\a) + (check-equal? (run #\b) #\b) + (check-equal? (run '(char? #\a)) #t) + (check-equal? (run '(char? #t)) #f) + (check-equal? (run '(char? 8)) #f) + (check-equal? (run '(char->integer #\a)) (char->integer #\a)) + (check-equal? (run '(integer->char 955)) #\λ)) + + (begin ;; Evildoer + (check-equal? (run '(void)) (void)) + (check-equal? (run '(begin 1 2)) 2) + (check-equal? (run '(eof-object? (void))) #f)) + + (begin ;; Extort + (check-equal? (run '(add1 #f)) 'err) + (check-equal? (run '(sub1 #f)) 'err) + (check-equal? (run '(zero? #f)) 'err) + (check-equal? (run '(char->integer #f)) 'err) + (check-equal? (run '(integer->char #f)) 'err) + (check-equal? (run '(integer->char -1)) 'err) + (check-equal? (run '(write-byte #f)) 'err) + (check-equal? (run '(write-byte -1)) 'err) + (check-equal? (run '(write-byte 256)) 'err) + (check-equal? (run '(begin (integer->char 97) + (integer->char 98))) + #\b)) + + (begin ;; Fraud + (check-equal? (run '(let ((x 7)) x)) 7) + (check-equal? (run '(let ((x 7)) 2)) 2) + (check-equal? (run '(let ((x 7)) (add1 x))) 8) + (check-equal? (run '(let ((x (add1 7))) x)) 8) + (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) + (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) + (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) + + (check-equal? (run '(let ((x 0)) + (if (zero? x) 7 8))) + 7) + (check-equal? (run '(let ((x 1)) + (add1 (if (zero? x) 7 8)))) + 9) + (check-equal? (run '(+ 3 4)) 7) + (check-equal? (run '(- 3 4)) -1) + (check-equal? (run '(+ (+ 2 1) 4)) 7) + (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) + (check-equal? (run '(let ((x (+ 1 2))) + (let ((z (- 4 x))) + (+ (+ x x) z)))) + 7) + + (check-equal? (run '(= 5 5)) #t) + (check-equal? (run '(= 4 5)) #f) + (check-equal? (run '(= (add1 4) 5)) #t) + (check-equal? (run '(< 5 5)) #f) + (check-equal? (run '(< 4 5)) #t) + (check-equal? (run '(< (add1 4) 5)) #f)) + + (begin ;; Hustle + (check-equal? (run '(empty? (cons 1 2))) #f) + (check-equal? (run '(box 1)) (box 1)) + (check-equal? (run '(box -1)) (box -1)) + (check-equal? (run '(cons 1 2)) (cons 1 2)) + (check-equal? (run '(unbox (box 1))) 1) + (check-equal? (run '(car (cons 1 2))) 1) + (check-equal? (run '(cdr (cons 1 2))) 2) + (check-equal? (run '(cons 1 '())) (list 1)) + (check-equal? (run '(let ((x (cons 1 2))) + (begin (cdr x) + (car x)))) + 1) + (check-equal? (run '(let ((x (cons 1 2))) + (let ((y (box 3))) + (unbox y)))) + 3) + (check-equal? (run '(eq? 1 1)) #t) + (check-equal? (run '(eq? 1 2)) #f) + (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) + (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t)) + + (begin ;; Hoax + (check-equal? (run '(make-vector 0 0)) #()) + (check-equal? (run '(make-vector 1 0)) #(0)) + (check-equal? (run '(make-vector 3 0)) #(0 0 0)) + (check-equal? (run '(make-vector 3 5)) #(5 5 5)) + (check-equal? (run '(vector? (make-vector 0 0))) #t) + (check-equal? (run '(vector? (cons 0 0))) #f) + (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) + (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) + (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 0 4) + x))) + #(4 5 5)) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 1 4) + x))) + #(5 4 5)) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 3 4) + x))) + 'err) + (check-equal? (run '(vector-length (make-vector 3 #f))) 3) + (check-equal? (run '(vector-length (make-vector 0 #f))) 0) + (check-equal? (run '"") "") + (check-equal? (run '"fred") "fred") + (check-equal? (run '"wilma") "wilma") + (check-equal? (run '(make-string 0 #t)) 'err) + (check-equal? (run '(make-string 0 #\f)) "") + (check-equal? (run '(make-string 3 #\f)) "fff") + (check-equal? (run '(make-string 3 #\g)) "ggg") + (check-equal? (run '(string-length "")) 0) + (check-equal? (run '(string-length "fred")) 4) + (check-equal? (run '(string-ref "" 0)) 'err) + (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) + (check-equal? (run '(string-ref "fred" 0)) #\f) + (check-equal? (run '(string-ref "fred" 1)) #\r) + (check-equal? (run '(string-ref "fred" 2)) #\e) + (check-equal? (run '(string-ref "fred" 4)) 'err) + (check-equal? (run '(string? "fred")) #t) + (check-equal? (run '(string? (cons 1 2))) #f) + (check-equal? (run '(begin (make-string 3 #\f) + (make-string 3 #\f))) + "fff") + (check-equal? (run '(vector-set! (make-vector 0 #f) 0 #t)) 'err)) + + (begin ;; Iniquity + (check-equal? (run + '(define (f x) x) + '(f 5)) + 5) + (check-equal? (run + '(define (tri x) + (if (zero? x) + 0 + (+ x (tri (sub1 x))))) + '(tri 9)) + 45) + + (check-equal? (run + '(define (even? x) + (if (zero? x) + #t + (odd? (sub1 x)))) + '(define (odd? x) + (if (zero? x) + #f + (even? (sub1 x)))) + '(even? 101)) + #f) + + (check-equal? (run + '(define (map-add1 xs) + (if (empty? xs) + '() + (cons (add1 (car xs)) + (map-add1 (cdr xs))))) + '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) + '(2 3 4)) + (check-equal? (run '(define (f x y) y) + '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) + 'err)) + + (begin ;; Knock + (check-equal? (run '(match 1)) 'err) + (check-equal? (run '(match 1 [1 2])) + 2) + (check-equal? (run '(match 1 [2 1] [1 2])) + 2) + (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) + 2) + (check-equal? (run '(match 1 [2 1] [0 3])) + 'err) + (check-equal? (run '(match 1 [_ 2] [_ 3])) + 2) + (check-equal? (run '(match 1 [x 2] [_ 3])) + 2) + (check-equal? (run '(match 1 [x x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) + (cons 1 2)) + (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) + 3) + (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) + 3) + (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) + 2) + (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) + 0) + (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) + 1) + (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) + 1) + (check-equal? (run '(match 1 [8589934592 1] [_ 2])) 2) + (check-equal? (run '(match 8589934592 [8589934592 1] [_ 2])) 1)) + + (begin ;; Loot + (check-true (procedure? (run '(λ (x) x)))) + (check-equal? (run '((λ (x) x) 5)) + 5) + + (check-equal? (run '(let ((f (λ (x) x))) (f 5))) + 5) + (check-equal? (run '(let ((f (λ (x y) x))) (f 5 7))) + 5) + (check-equal? (run '(let ((f (λ (x y) y))) (f 5 7))) + 7) + (check-equal? (run '((let ((x 1)) + (let ((y 2)) + (lambda (z) (cons x (cons y (cons z '())))))) + 3)) + '(1 2 3)) + (check-equal? (run '(define (adder n) + (λ (x) (+ x n))) + '((adder 5) 10)) + 15) + (check-equal? (run '(((λ (t) + ((λ (f) (t (λ (z) ((f f) z)))) + (λ (f) (t (λ (z) ((f f) z)))))) + (λ (tri) + (λ (n) + (if (zero? n) + 0 + (+ n (tri (sub1 n))))))) + 36)) + 666) + (check-equal? (run '(define (tri n) + (if (zero? n) + 0 + (+ n (tri (sub1 n))))) + '(tri 36)) + 666) + (check-equal? (run '(define (tri n) + (match n + [0 0] + [m (+ m (tri (sub1 m)))])) + '(tri 36)) + 666) + (check-equal? (run '((match 8 [8 (lambda (x) x)]) 12)) + 12)) + + (begin ;; Mug + (check-equal? (run '(symbol? 'foo)) #t) + (check-equal? (run '(symbol? (string->symbol "foo"))) #t) + (check-equal? (run '(eq? 'foo 'foo)) #t) + (check-equal? (run '(eq? (string->symbol "foo") + (string->symbol "foo"))) + #t) + (check-equal? (run '(eq? 'foo (string->symbol "foo"))) + #t) + (check-equal? (run '(eq? 'fff (string->symbol (make-string 3 #\f)))) + #t) + (check-equal? (run '(symbol? 'g0)) #t) + (check-equal? (run '(symbol? "g0")) #f) + (check-equal? (run '(symbol? (string->symbol "g0"))) #t) + (check-equal? (run '(symbol? (string->uninterned-symbol "g0"))) #t) + (check-equal? (run '(eq? 'g0 (string->symbol "g0"))) #t) + (check-equal? (run '(eq? 'g0 (string->uninterned-symbol "g0"))) #f) + (check-equal? (run '(eq? (string->uninterned-symbol "g0") (string->uninterned-symbol "g0"))) + #f) + (check-equal? (run '(eq? (symbol->string 'foo) (symbol->string 'foo))) #f) + (check-equal? (run '(string? (symbol->string 'foo))) #t) + (check-equal? (run '(eq? (symbol->string 'foo) "foo")) #f) + (check-equal? (run ''foo) 'foo) + (check-equal? (run '(eq? (match #t [_ "foo"]) "bar")) #f) + (check-equal? (run '(eq? (match #t [_ 'foo]) 'bar)) #f) + (check-equal? (run '(match 'foo ['bar #t] [_ #f])) #f) + (check-equal? (run '(match 'foo ['foo #t] [_ #f])) #t) + (check-equal? (run '(match "foo" ["foo" #t] [_ #f])) #t) + (check-equal? (run '(match "foo" ["bar" #t] [_ #f])) #f) + (check-equal? (run '(match (cons '+ (cons 1 (cons 2 '()))) + [(cons '+ (cons x (cons y '()))) + (+ x y)])) + 3)) + + (begin ;; Mountebank + (check-equal? (run '#()) + #()) + (check-equal? (run ''#()) + #()) + (check-equal? (run ''#t) + #t) + (check-equal? (run ''7) + 7) + (check-equal? (run ''(1 2 3)) + '(1 2 3)) + (check-equal? (run ''(1 . 2)) + '(1 . 2)) + (check-equal? (run ''(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) + '(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) + (check-equal? (run '(define (f) (cons 1 2)) + '(eq? (f) (f))) + #f) + (check-equal? (run '(define (f) '(1 . 2)) + '(eq? (f) (f))) + #t) + (check-equal? (run '(let ((x '(foo . foo))) + (eq? (car x) (cdr x)))) + #t) + (check-equal? + (run '(define (eval e r) + (match e + [(cons 'zero? (cons e '())) + (zero? (eval e r))] + [(cons 'sub1 (cons e '())) + (sub1 (eval e r))] + [(cons '+ (cons e1 (cons e2 '()))) + (+ (eval e1 r) (eval e2 r))] + [(cons 'if (cons e1 (cons e2 (cons e3 '())))) + (if (eval e1 r) + (eval e2 r) + (eval e3 r))] + [(cons 'λ (cons (cons x '()) (cons e '()))) + (lambda (v) (eval e (cons (cons x v) r)))] + [(cons e1 (cons e2 '())) + ((eval e1 r) (eval e2 r))] + [_ + (if (symbol? e) + (lookup r e) + e)])) + '(define (lookup r x) + (match r + [(cons (cons y v) r) + (if (eq? x y) + v + (lookup r x))])) + '(eval '(((λ (t) + ((λ (f) (t (λ (z) ((f f) z)))) + (λ (f) (t (λ (z) ((f f) z)))))) + (λ (tri) + (λ (n) + (if (zero? n) + 0 + (+ n (tri (sub1 n))))))) + 36) + '())) + 666))) + +(define (test/io run) + (begin ;; Evildoer + (check-equal? (run "" 7) (cons 7 "")) + (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) + (check-equal? (run "a" '(read-byte)) (cons 97 "")) + (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) + (cons 98 "a")) + (check-equal? (run "" '(read-byte)) (cons eof "")) + (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) + (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) + (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) + (cons (void) "ab")) + + (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) + (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) + (check-equal? (run "†" '(read-byte)) (cons 226 "")) + (check-equal? (run "†" '(peek-byte)) (cons 226 ""))) + + (begin ;; Extort + (check-equal? (run "" '(write-byte #t)) (cons 'err ""))) + + (begin ;; Fraud + (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) + (check-equal? (run "" + '(let ((x 97)) + (begin (write-byte x) + x))) + (cons 97 "a")) + (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) + (cons 97 "")) + (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) + (cons 97 ""))) + + (begin ;; Iniquity + (check-equal? (run "" + '(define (print-alphabet i) + (if (zero? i) + (void) + (begin (write-byte (- 123 i)) + (print-alphabet (sub1 i))))) + '(print-alphabet 26)) + (cons (void) "abcdefghijklmnopqrstuvwxyz")) + + (check-equal? (run "" + '(define (f x) + (write-byte x)) + '(f 97)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (write-byte x)) + '(f 97 98)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x) + (let ((y x)) + (write-byte y))) + '(f 97)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (let ((y x)) + (write-byte y))) + '(f 97 98)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x) + (write-byte x)) + '(let ((z 97)) + (f z))) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (write-byte x)) + '(let ((z 97)) + (f z 98))) + (cons (void) "a"))) + + (begin ;; Knock + (check-equal? (run "" + '(match (write-byte 97) + [_ 1])) + (cons 1 "a"))) + + (begin ;; Loot + (check-equal? (run "" + '((begin (write-byte 97) + (λ (x) + (begin (write-byte x) + (write-byte 99)))) + 98)) + (cons (void) "abc")))) + diff --git a/mountebank/test/interp-defun.rkt b/mountebank/test/interp-defun.rkt deleted file mode 100644 index 68ef419..0000000 --- a/mountebank/test/interp-defun.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp-defun.rkt" - "../interp-io.rkt") - -(define (closure->proc xs e r) - ;; Could make this better by calling the interpreter, - ;; but it's only used in tests where all we care about - ;; is that you get a procedure. - (lambda _ - (error "This function is not callable."))) - -(test-runner - (λ p - (match (interp (parse p)) - [(Closure xs e r) (closure->proc xs e r)] - [v v]))) -(test-runner-io - (λ (s . p) - (match (interp/io (parse p) s) - [(cons (Closure xs e r) o) - (cons (closure->proc xs e r) o)] - [r r]))) diff --git a/mountebank/test/interp.rkt b/mountebank/test/interp.rkt deleted file mode 100644 index cd7b654..0000000 --- a/mountebank/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/mountebank/test/run-compile-tests.rkt b/mountebank/test/run-compile-tests.rkt new file mode 100644 index 0000000..2cf66fd --- /dev/null +++ b/mountebank/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ p (run (compile (apply parse-closed p))))) +(test/io (λ (in . p) (run/io (compile (apply parse-closed p)) in))) + diff --git a/mountebank/test/run-interp-tests.rkt b/mountebank/test/run-interp-tests.rkt new file mode 100644 index 0000000..96137ef --- /dev/null +++ b/mountebank/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ p (interp (apply parse-closed p)))) +(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) + diff --git a/mountebank/test/run-parse-tests.rkt b/mountebank/test/run-parse-tests.rkt new file mode 100644 index 0000000..e03cb56 --- /dev/null +++ b/mountebank/test/run-parse-tests.rkt @@ -0,0 +1,89 @@ +#lang racket +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") +(require rackunit) + +(define (p e) + (Prog '() e)) + +(begin ; Abscond + (check-equal? (parse 42) (p (Lit 42))) + (check-equal? (parse -1) (p (Lit -1)))) +(begin ; Blackmail + (check-equal? (parse '(add1 42)) (p (Prim1 'add1 (Lit 42))))) +(begin ; Dupe + (check-equal? (parse '(if (zero? 1) 2 3)) + (p (If (Prim1 'zero? (Lit 1)) (Lit 2) (Lit 3)))) + (check-equal? (parse '(if #t 2 3)) + (p (If (Lit #t) (Lit 2) (Lit 3))))) +(begin ; Dodger + (check-equal? (parse #\a) (p (Lit #\a))) + (check-equal? (parse '(char->integer #\a)) + (p (Prim1 'char->integer (Lit #\a))))) +(begin ; Evildoer + (check-equal? (parse 'eof) (p (Eof))) + (check-equal? (parse '(void)) (p (Prim0 'void))) + (check-equal? (parse '(read-byte)) (p (Prim0 'read-byte)))) +(begin ; Fraud + (check-equal? (parse 'x) (p (Var 'x))) + (check-exn exn:fail? (λ () (parse-closed 'x))) + (check-equal? (parse '(+ 1 2)) + (p (Prim2 '+ (Lit 1) (Lit 2)))) + (check-equal? (parse '(let ((x 1)) x)) + (p (Let 'x (Lit 1) (Var 'x)))) + (check-equal? (parse-closed '(let ((x 1)) x)) + (p (Let 'x (Lit 1) (Var 'x)))) + (check-equal? (parse 'add1) (p (Var 'add1))) + (check-exn exn:fail? (λ () (parse-closed 'add1))) + (check-equal? (parse '(let ((let 1)) let)) + (p (Let 'let (Lit 1) (Var 'let)))) + (check-equal? (parse '(let ((if 1)) if)) + (p (Let 'if (Lit 1) (Var 'if))))) +(begin ; Hustle + (check-equal? (parse ''()) (p (Lit '()))) + (check-equal? (parse '(box 1)) (p (Prim1 'box (Lit 1)))) + (check-equal? (parse '(cons 1 2)) (p (Prim2 'cons (Lit 1) (Lit 2))))) +(begin ; Hoax + (check-equal? (parse "asdf") (p (Lit "asdf"))) + (check-equal? (parse '(make-string 10 #\a)) + (p (Prim2 'make-string (Lit 10) (Lit #\a))))) + +(begin ; Iniquity + (check-equal? (parse '(define (f x) x) 1) + (Prog (list (Defn 'f '(x) (Var 'x))) (Lit 1))) + (check-equal? (parse '(define (define) 0) '(define)) + (Prog (list (Defn 'define '() (Lit 0))) + (App (Var 'define) '()))) + (check-exn exn:fail? (λ () (parse '(define (f y y) y) 1))) + (check-equal? (parse-closed '(define (f x) (g x)) + '(define (g x) (f x)) + '(f 0)) + (Prog (list (Defn 'f '(x) (App (Var 'g) (list (Var 'x)))) + (Defn 'g '(x) (App (Var 'f) (list (Var 'x))))) + (App (Var 'f) (list (Lit 0)))))) +(begin ; Knock + (check-equal? (parse '(match 1)) + (p (Match (Lit 1) '() '()))) + (check-equal? (parse '(match 1 [_ #t])) + (p (Match (Lit 1) (list (Var '_)) (list (Lit #t))))) + (check-equal? (parse '(match 1 [x x])) + (p (Match (Lit 1) (list (Var 'x)) (list (Var 'x))))) + (check-equal? (parse-closed '(match 1 [x x])) + (p (Match (Lit 1) (list (Var 'x)) (list (Var 'x))))) + (check-equal? (parse '(match 1 [x y])) + (p (Match (Lit 1) (list (Var 'x)) (list (Var 'y))))) + (check-equal? (parse '(match x ['() 1])) + (p (Match (Var 'x) (list (Lit '())) (list (Lit 1))))) + (check-exn exn:fail? (λ () (parse-closed '(match 1 [x y]))))) + +(begin ; Loot + (check-equal? (parse '(f x)) + (p (App (Var 'f) (list (Var 'x)))))) + +(begin ; Mug + (check-equal? (parse ''x) + (p (Lit 'x))) + (check-equal? (parse '(let ((quote 1)) + 'x)) + (p (Let 'quote (Lit 1) (App (Var 'quote) (list (Var 'x))))))) + diff --git a/mountebank/test/test-runner.rkt b/mountebank/test/test-runner.rkt deleted file mode 100644 index d4cb5b2..0000000 --- a/mountebank/test/test-runner.rkt +++ /dev/null @@ -1,452 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (f x) x) - '(define (g x) (f x)) - '(g 5)) - 5) - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run - '(define (f x) - 10) - '(f 1)) - 10) - (check-equal? (run - '(define (f x) - 10) - '(let ((x 2)) (f 1))) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(f 1 2)) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(let ((z 2)) (f 1 2))) - 10) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err) - - ;; Knock examples - (check-equal? (run '(match 1)) 'err) - (check-equal? (run '(match 1 [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) - 2) - (check-equal? (run '(match 1 [2 1] [0 3])) - 'err) - (check-equal? (run '(match 1 [_ 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) - (cons 1 2)) - (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) - 3) - (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) - 3) - (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) - 2) - (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) - 0) - (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) - 1) - (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) - 1) - - ;; Loot examples - (check-true (procedure? (run '(λ (x) x)))) - (check-equal? (run '((λ (x) x) 5)) - 5) - - (check-equal? (run '(let ((f (λ (x) x))) (f 5))) - 5) - (check-equal? (run '(let ((f (λ (x y) x))) (f 5 7))) - 5) - (check-equal? (run '(let ((f (λ (x y) y))) (f 5 7))) - 7) - (check-equal? (run '((let ((x 1)) - (let ((y 2)) - (lambda (z) (cons x (cons y (cons z '())))))) - 3)) - '(1 2 3)) - (check-equal? (run '(define (adder n) - (λ (x) (+ x n))) - '((adder 5) 10)) - 15) - (check-equal? (run '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36)) - 666) - (check-equal? (run '(define (tri n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))) - '(tri 36)) - 666) - (check-equal? (run '(define (tri n) - (match n - [0 0] - [m (+ m (tri (sub1 m)))])) - '(tri 36)) - 666) - (check-equal? (run '((match 8 [8 (lambda (x) x)]) 12)) - 12) - - ;; Mug examples - (check-equal? (run '(symbol? 'foo)) #t) - (check-equal? (run '(symbol? (string->symbol "foo"))) #t) - (check-equal? (run '(eq? 'foo 'foo)) #t) - (check-equal? (run '(eq? (string->symbol "foo") - (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'foo (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'fff (string->symbol (make-string 3 #\f)))) - #t) - (check-equal? (run '(symbol? 'g0)) #t) - (check-equal? (run '(symbol? "g0")) #f) - (check-equal? (run '(symbol? (string->symbol "g0"))) #t) - (check-equal? (run '(symbol? (string->uninterned-symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->uninterned-symbol "g0"))) #f) - (check-equal? (run '(eq? (string->uninterned-symbol "g0") (string->uninterned-symbol "g0"))) - #f) - (check-equal? (run '(eq? (symbol->string 'foo) (symbol->string 'foo))) #f) - (check-equal? (run '(string? (symbol->string 'foo))) #t) - (check-equal? (run '(eq? (symbol->string 'foo) "foo")) #f) - (check-equal? (run ''foo) 'foo) - (check-equal? (run '(eq? (match #t [_ "foo"]) "bar")) #f) - (check-equal? (run '(eq? (match #t [_ 'foo]) 'bar)) #f) - (check-equal? (run '(match 'foo ['bar #t] [_ #f])) #f) - (check-equal? (run '(match 'foo ['foo #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["foo" #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["bar" #t] [_ #f])) #f) - (check-equal? (run '(match (cons '+ (cons 1 (cons 2 '()))) - [(cons '+ (cons x (cons y '()))) - (+ x y)])) - 3) - - ;; Mountebank examples - (check-equal? (run '#()) - #()) - (check-equal? (run ''#()) - #()) - (check-equal? (run ''#t) - #t) - (check-equal? (run ''7) - 7) - (check-equal? (run ''(1 2 3)) - '(1 2 3)) - (check-equal? (run ''(1 . 2)) - '(1 . 2)) - (check-equal? (run ''(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) - '(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) - (check-equal? (run '(define (f) (cons 1 2)) - '(eq? (f) (f))) - #f) - (check-equal? (run '(define (f) '(1 . 2)) - '(eq? (f) (f))) - #t) - (check-equal? (run '(let ((x '(foo . foo))) - (eq? (car x) (cdr x)))) - #t) - (check-equal? - (run '(define (eval e r) - (match e - [(list 'zero? e) - (zero? (eval e r))] - [(list 'sub1 e) - (sub1 (eval e r))] - [(list '+ e1 e2) - (+ (eval e1 r) (eval e2 r))] - [(list 'if e1 e2 e3) - (if (eval e1 r) - (eval e2 r) - (eval e3 r))] - [(list 'λ (list x) e) - (lambda (v) (eval e (cons (cons x v) r)))] - [(list e1 e2) - ((eval e1 r) (eval e2 r))] - [_ - (if (symbol? e) - (lookup r e) - e)])) - '(define (lookup r x) - (match r - [(cons (cons y v) r) - (if (eq? x y) - v - (lookup r x))])) - '(eval '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36) - '())) - 666)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - #| - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz")) -|#) diff --git a/mountebank/types.rkt b/mountebank/types.rkt deleted file mode 100644 index f4cbf7d..0000000 --- a/mountebank/types.rkt +++ /dev/null @@ -1,109 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require ffi/unsafe) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define type-proc #b101) -(define type-symb #b110) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) - -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (heap-ref b)))] - [(cons-bits? b) - (cons (bits->value (heap-ref (+ b 8))) - (bits->value (heap-ref b)))] - [(vect-bits? b) - (if (zero? (untag b)) - (vector) - (build-vector (heap-ref b) - (lambda (j) - (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] - [(str-bits? b) - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j))))] - [(symb-bits? b) - (string->symbol - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j)))))] - [(proc-bits? b) - (lambda _ - (error "This function is not callable."))] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eq? v #t) #b00011000] - [(eq? v #f) #b00111000] - [(eof-object? v) #b01011000] - [(void? v) #b01111000] - [(empty? v) #b10011000] - [(integer? v) - (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [else (error "not an immediate value")])) - - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (= type-int (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (= type-cons (bitwise-and v imm-mask))) - -(define (box-bits? v) - (= type-box (bitwise-and v imm-mask))) - -(define (vect-bits? v) - (= type-vect (bitwise-and v imm-mask))) - -(define (str-bits? v) - (= type-str (bitwise-and v imm-mask))) - -(define (proc-bits? v) - (= type-proc (bitwise-and v imm-mask))) - -(define (symb-bits? v) - (= type-symb (bitwise-and v imm-mask))) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/mountebank/values.h b/mountebank/values.h deleted file mode 100644 index c1de09d..0000000 --- a/mountebank/values.h +++ /dev/null @@ -1,84 +0,0 @@ -#ifndef VALUES_H -#define VALUES_H - -#include - -/* any abstract value */ -typedef int64_t val_t; - -typedef enum type_t { - T_INVALID = -1, - /* immediates */ - T_INT, - T_BOOL, - T_CHAR, - T_EOF, - T_VOID, - T_EMPTY, - /* pointers */ - T_BOX, - T_CONS, - T_VECT, - T_STR, - T_SYMB, - T_PROC, -} type_t; - -typedef uint32_t val_char_t; -typedef struct val_box_t { - val_t val; -} val_box_t; -typedef struct val_cons_t { - val_t snd; - val_t fst; -} val_cons_t; -typedef struct val_vect_t { - uint64_t len; - val_t elems[]; -} val_vect_t; -typedef struct val_str_t { - uint64_t len; - val_char_t codepoints[]; -} val_str_t; -typedef struct val_symb_t { - uint64_t len; - val_char_t codepoints[]; -} val_symb_t; - -/* return the type of x */ -type_t val_typeof(val_t x); - -/** - * Wrap/unwrap values - * - * The behavior of unwrap functions are undefined on type mismatch. - */ -int64_t val_unwrap_int(val_t x); -val_t val_wrap_int(int64_t i); - -int val_unwrap_bool(val_t x); -val_t val_wrap_bool(int b); - -val_char_t val_unwrap_char(val_t x); -val_t val_wrap_char(val_char_t b); - -val_t val_wrap_eof(); - -val_t val_wrap_void(); - -val_box_t* val_unwrap_box(val_t x); -val_t val_wrap_box(val_box_t* b); - -val_cons_t* val_unwrap_cons(val_t x); -val_t val_wrap_cons(val_cons_t* c); - -val_vect_t* val_unwrap_vect(val_t x); -val_t val_wrap_vect(val_vect_t* c); - -val_str_t* val_unwrap_str(val_t x); -val_t val_wrap_str(val_str_t* c); - -val_symb_t* val_unwrap_symb(val_t x); -val_t val_wrap_symb(val_symb_t* c); - -#endif diff --git a/mug/Makefile b/mug/Makefile index 3fc9599..d88e2b9 100644 --- a/mug/Makefile +++ b/mug/Makefile @@ -10,8 +10,7 @@ objs = \ main.o \ print.o \ values.o \ - io.o \ - symbol.o + io.o default: runtime.o diff --git a/mug/ast.rkt b/mug/ast.rkt deleted file mode 100644 index 537deed..0000000 --- a/mug/ast.rkt +++ /dev/null @@ -1,83 +0,0 @@ -#lang racket -(provide (all-defined-out)) - -;; type Prog = (Prog (Listof Defn) Expr) -(struct Prog (ds e) #:prefab) - -;; type Defn = (Defn Id (Listof Id) Expr) -(struct Defn (f xs e) #:prefab) - -;; type Expr = (Eof) -;; | (Empty) -;; | (Int Integer) -;; | (Bool Boolean) -;; | (Char Character) -;; | (Str String) -;; | (Symb Symbol) -;; | (Prim0 Op0) -;; | (Prim1 Op1 Expr) -;; | (Prim2 Op2 Expr Expr) -;; | (Prim3 Op3 Expr Expr Expr) -;; | (If Expr Expr Expr) -;; | (Begin Expr Expr) -;; | (Let Id Expr Expr) -;; | (Var Id) -;; | (Match Expr (Listof Pat) (Listof Expr)) -;; | (App Expr (Listof Expr)) -;; | (Lam Id (Listof Id) Expr) -;; type Id = Symbol -;; type Op0 = 'read-byte -;; type Op1 = 'add1 | 'sub1 | 'zero? -;; | 'char? | 'integer->char | 'char->integer -;; | 'write-byte | 'eof-object? -;; | 'box | 'car | 'cdr | 'unbox -;; | 'empty? | 'cons? | 'box? -;; | 'vector? | 'vector-length -;; | 'string? | 'string-length -;; | 'symbol? | 'symbol->string -;; | 'string->symbol | 'string->uninterned-symbol -;; type Op2 = '+ | '- | '< | '= -;; | 'cons -;; | 'make-vector | 'vector-ref -;; | 'make-string | 'string-ref -;; type Op3 = 'vector-set! -;; type Pat = (PVar Id) -;; | (PWild) -;; | (PLit Lit) -;; | (PBox Pat) -;; | (PCons Pat Pat) -;; | (PAnd Pat Pat) -;; | (PSymb Symbol) -;; | (PStr String) -;; type Lit = Boolean -;; | Character -;; | Integer -;; | '() - -(struct Eof () #:prefab) -(struct Empty () #:prefab) -(struct Int (i) #:prefab) -(struct Bool (b) #:prefab) -(struct Char (c) #:prefab) -(struct Str (s) #:prefab) -(struct Symb (s) #:prefab) -(struct Prim0 (p) #:prefab) -(struct Prim1 (p e) #:prefab) -(struct Prim2 (p e1 e2) #:prefab) -(struct Prim3 (p e1 e2 e3) #:prefab) -(struct If (e1 e2 e3) #:prefab) -(struct Begin (e1 e2) #:prefab) -(struct Let (x e1 e2) #:prefab) -(struct Var (x) #:prefab) -(struct App (e es) #:prefab) -(struct Lam (f xs e) #:prefab) -(struct Match (e ps es) #:prefab) - -(struct PVar (x) #:prefab) -(struct PWild () #:prefab) -(struct PLit (x) #:prefab) -(struct PBox (p) #:prefab) -(struct PCons (p1 p2) #:prefab) -(struct PAnd (p1 p2) #:prefab) -(struct PSymb (s) #:prefab) -(struct PStr (s) #:prefab) diff --git a/mug/build-runtime.rkt b/mug/build-runtime.rkt deleted file mode 100644 index 66aad89..0000000 --- a/mug/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require racket/runtime-path) -(provide runtime-path) - -(define-runtime-path here ".") - -(void - (system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o"))) - -(define runtime-path - (path->string - (normalize-path (build-path here "runtime.o")))) diff --git a/mug/compile-define.rkt b/mug/compile-define.rkt deleted file mode 100644 index a8a6992..0000000 --- a/mug/compile-define.rkt +++ /dev/null @@ -1,72 +0,0 @@ -#lang racket -(provide compile-define compile-defines-values define-ids compile-defines) -(require "ast.rkt" - "types.rkt" - "fv.rkt" - "utils.rkt" - "compile-expr.rkt" - a86/ast) - -(define rax 'rax) -(define rbx 'rbx) - -;; [Listof Defn] -> [Listof Id] -(define (define-ids ds) - (match ds - ['() '()] - [(cons (Defn f xs e) ds) - (cons f (define-ids ds))])) - -;; [Listof Defn] -> Asm -(define (compile-defines ds) - (match ds - ['() (seq)] - [(cons d ds) - (seq (compile-define d) - (compile-defines ds))])) - -;; Defn -> Asm -(define (compile-define d) - (match d - [(Defn f xs e) - (compile-lambda-define (Lam f xs e))])) - -;; Defns -> Asm -;; Compile the closures for ds and push them on the stack -(define (compile-defines-values ds) - (seq (alloc-defines ds 0) - (init-defines ds (reverse (define-ids ds)) 8) - (add-rbx-defines ds 0))) - -;; Defns Int -> Asm -;; Allocate closures for ds at given offset, but don't write environment yet -(define (alloc-defines ds off) - (match ds - ['() (seq)] - [(cons (Defn f xs e) ds) - (let ((fvs (fv (Lam f xs e)))) - (seq (Lea rax (symbol->label f)) - (Mov (Mem rbx off) rax) - (Mov rax rbx) - (Add rax off) - (Or rax type-proc) - (Push rax) - (alloc-defines ds (+ off (* 8 (add1 (length fvs)))))))])) - -;; Defns CEnv Int -> Asm -;; Initialize the environment for each closure for ds at given offset -(define (init-defines ds c off) - (match ds - ['() (seq)] - [(cons (Defn f xs e) ds) - (let ((fvs (fv (Lam f xs e)))) - (seq (free-vars-to-heap fvs c off) - (init-defines ds c (+ off (* 8 (add1 (length fvs)))))))])) - -;; Defns Int -> Asm -;; Compute adjustment to rbx for allocation of all ds -(define (add-rbx-defines ds n) - (match ds - ['() (seq (Add rbx (* n 8)))] - [(cons (Defn f xs e) ds) - (add-rbx-defines ds (+ n (add1 (length (fv (Lam f xs e))))))])) diff --git a/mug/compile-ops.rkt b/mug/compile-ops.rkt deleted file mode 100644 index 79fe367..0000000 --- a/mug/compile-ops.rkt +++ /dev/null @@ -1,397 +0,0 @@ -#lang racket -(provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack unpad-stack assert-proc) -(require "ast.rkt" "types.rkt" "utils.rkt" a86/ast) - -(define rax 'rax) ; return -(define eax 'eax) ; 32-bit load/store -(define rbx 'rbx) ; heap -(define rdi 'rdi) ; arg1 -(define rsi 'rsi) ; arg2 -(define rdx 'rdx) ; arg3 -(define r8 'r8) ; scratch -(define r9 'r9) ; scratch -(define r10 'r10) ; scratch -(define r12 'r12) ; save across call to memcpy -(define r15 'r15) ; stack pad (non-volatile) -(define rsp 'rsp) ; stack - -;; Op0 -> Asm -(define (compile-op0 p) - (match p - ['void (seq (Mov rax (value->bits (void))))] - ['read-byte (seq pad-stack - (Call 'read_byte) - unpad-stack)] - ['peek-byte (seq pad-stack - (Call 'peek_byte) - unpad-stack)])) - -;; Op1 -> Asm -(define (compile-op1 p) - (match p - ['add1 - (seq (assert-integer rax) - (Add rax (value->bits 1)))] - ['sub1 - (seq (assert-integer rax) - (Sub rax (value->bits 1)))] - ['zero? - (seq (assert-integer rax) - (eq-imm 0))] - ['char? - (type-pred mask-char type-char)] - ['char->integer - (seq (assert-char rax) - (Sar rax char-shift) - (Sal rax int-shift))] - ['integer->char - (seq (assert-codepoint rax) - (Sar rax int-shift) - (Sal rax char-shift) - (Xor rax type-char))] - ['eof-object? (eq-imm eof)] - ['write-byte - (seq (assert-byte rax) - pad-stack - (Mov rdi rax) - (Call 'write_byte) - unpad-stack)] - ['box - (seq (Mov (Mem rbx 0) rax) - (Mov rax rbx) - (Or rax type-box) - (Add rbx 8))] - ['unbox - (seq (assert-box rax) - (Xor rax type-box) - (Mov rax (Mem rax 0)))] - ['car - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Mem rax 8)))] - ['cdr - (seq (assert-cons rax) - (Xor rax type-cons) - (Mov rax (Mem rax 0)))] - ['empty? (eq-imm '())] - ['box? - (type-pred ptr-mask type-box)] - ['cons? - (type-pred ptr-mask type-cons)] - ['vector? - (type-pred ptr-mask type-vect)] - ['string? - (type-pred ptr-mask type-str)] - ['symbol? - (type-pred ptr-mask type-symb)] - ['vector-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-vector rax) - (Xor rax type-vect) - (Cmp rax 0) - (Je zero) - (Mov rax (Mem rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string-length - (let ((zero (gensym)) - (done (gensym))) - (seq (assert-string rax) - (Xor rax type-str) - (Cmp rax 0) - (Je zero) - (Mov rax (Mem rax 0)) - (Sal rax int-shift) - (Jmp done) - (Label zero) - (Mov rax 0) - (Label done)))] - ['string->symbol - (seq (assert-string rax) - (Xor rax type-str) - (Mov rdi rax) - pad-stack - (Call 'intern_symbol) - unpad-stack - (Or rax type-symb))] - ['symbol->string - (seq (assert-symbol rax) - (Xor rax type-symb) - char-array-copy - (Or rax type-str))] - ['string->uninterned-symbol - (seq (assert-string rax) - (Xor rax type-str) - char-array-copy - (Or rax type-symb))])) - -;; Asm -;; Copy sized array of characters pointed to by rax -(define char-array-copy - (seq (Mov rdi rbx) ; dst - (Mov rsi rax) ; src - (Mov rdx (Mem rax 0)) ; len - (Add rdx 1) ; #words = 1 + (len+1)/2 - (Sar rdx 1) - (Add rdx 1) - (Sal rdx 3) ; #bytes = 8*#words - (Mov r12 rdx) ; save rdx before destroyed - pad-stack - (Call 'memcpy) - unpad-stack - ; rbx should be preserved by memcpy - ;(Mov rbx rax) ; dst is returned, install as heap pointer - (Add rbx r12))) - -;; Op2 -> Asm -(define (compile-op2 p) - (match p - ['+ - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Add rax r8))] - ['- - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Sub r8 rax) - (Mov rax r8))] - ['< - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (Mov rax (value->bits #t)) - (let ((true (gensym))) - (seq (Jl true) - (Mov rax (value->bits #f)) - (Label true))))] - ['= - (seq (Pop r8) - (assert-integer r8) - (assert-integer rax) - (Cmp r8 rax) - (Mov rax (value->bits #t)) - (let ((true (gensym))) - (seq (Je true) - (Mov rax (value->bits #f)) - (Label true))))] - ['cons - (seq (Mov (Mem rbx 0) rax) - (Pop rax) - (Mov (Mem rbx 8) rax) - (Mov rax rbx) - (Or rax type-cons) - (Add rbx 16))] - ['eq? - (seq (Pop r8) - (eq r8 rax))] - ['make-vector - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (Cmp r8 0) ; special case empty vector - (Je empty) - - (Mov r9 rbx) - (Or r9 type-vect) - - (Sar r8 int-shift) - (Mov (Mem rbx 0) r8) - (Add rbx 8) - - (Label loop) - (Mov (Mem rbx 0) rax) - (Add rbx 8) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-vect) - (Label done)))] - - ['vector-ref - (seq (Pop r8) - (assert-vector r8) - (assert-integer rax) - (Cmp r8 type-vect) - (Je 'raise_error_align) ; special case for empty vector - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 3) - (Add r8 rax) - (Mov rax (Mem r8 8)))] - - ['make-string - (let ((loop (gensym)) - (done (gensym)) - (empty (gensym))) - (seq (Pop r8) - (assert-natural r8) - (assert-char rax) - (Cmp r8 0) ; special case empty string - (Je empty) - - (Mov r9 rbx) - (Or r9 type-str) - - (Sar r8 int-shift) - (Mov (Mem rbx 0) r8) - (Add rbx 8) - - (Sar rax char-shift) - - (Add r8 1) ; adds 1 - (Sar r8 1) ; when - (Sal r8 1) ; len is odd - - (Label loop) - (Mov (Mem rbx 0) eax) - (Add rbx 4) - (Sub r8 1) - (Cmp r8 0) - (Jne loop) - - (Mov rax r9) - (Jmp done) - - (Label empty) - (Mov rax type-str) - (Label done)))] - - ['string-ref - (seq (Pop r8) - (assert-string r8) - (assert-integer rax) - (Cmp r8 type-str) - (Je 'raise_error_align) ; special case for empty string - (Cmp rax 0) - (Jl 'raise_error_align) - (Xor r8 type-str) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar rax int-shift) ; rax = index - (Sub r9 1) - (Cmp r9 rax) - (Jl 'raise_error_align) - (Sal rax 2) - (Add r8 rax) - (Mov 'eax (Mem r8 8)) - (Sal rax char-shift) - (Or rax type-char))])) - -;; Op3 -> Asm -(define (compile-op3 p) - (match p - ['vector-set! - (seq (Pop r10) - (Pop r8) - (assert-vector r8) - (assert-integer r10) - (Cmp r10 0) - (Jl 'raise_error_align) - (Xor r8 type-vect) ; r8 = ptr - (Mov r9 (Mem r8 0)) ; r9 = len - (Sar r10 int-shift) ; r10 = index - (Sub r9 1) - (Cmp r9 r10) - (Jl 'raise_error_align) - (Sal r10 3) - (Add r8 r10) - (Mov (Mem r8 8) rax) - (Mov rax (value->bits (void))))])) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (assert-type mask type) - (λ (arg) - (seq (Mov r9 arg) - (And r9 mask) - (Cmp r9 type) - (Jne 'raise_error_align)))) - -(define (type-pred mask type) - (let ((l (gensym))) - (seq (And rax mask) - (Cmp rax type) - (Mov rax (value->bits #t)) - (Je l) - (Mov rax (value->bits #f)) - (Label l)))) - -(define assert-integer - (assert-type mask-int type-int)) -(define assert-char - (assert-type mask-char type-char)) -(define assert-box - (assert-type ptr-mask type-box)) -(define assert-cons - (assert-type ptr-mask type-cons)) -(define assert-vector - (assert-type ptr-mask type-vect)) -(define assert-string - (assert-type ptr-mask type-str)) -(define assert-symbol - (assert-type ptr-mask type-symb)) -(define assert-proc - (assert-type ptr-mask type-proc)) - -(define (assert-codepoint r) - (let ((ok (gensym))) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 1114111)) - (Jg 'raise_error_align) - (Cmp r (value->bits 55295)) - (Jl ok) - (Cmp r (value->bits 57344)) - (Jg ok) - (Jmp 'raise_error_align) - (Label ok)))) - -(define (assert-byte r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align) - (Cmp r (value->bits 255)) - (Jg 'raise_error_align))) - -(define (assert-natural r) - (seq (assert-integer r) - (Cmp r (value->bits 0)) - (Jl 'raise_error_align))) - -;; Value -> Asm -(define (eq-imm imm) - (let ((l1 (gensym))) - (seq (Cmp rax (value->bits imm)) - (Mov rax (value->bits #t)) - (Je l1) - (Mov rax (value->bits #f)) - (Label l1)))) - -(define (eq ir1 ir2) - (let ((l1 (gensym))) - (seq (Cmp ir1 ir2) - (Mov rax (value->bits #t)) - (Je l1) - (Mov rax (value->bits #f)) - (Label l1)))) diff --git a/mug/compile-stdin.rkt b/mug/compile-stdin.rkt deleted file mode 100644 index cfa1510..0000000 --- a/mug/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read-all))))) diff --git a/mug/compile.rkt b/mug/compile.rkt deleted file mode 100644 index 5b2d1a6..0000000 --- a/mug/compile.rkt +++ /dev/null @@ -1,55 +0,0 @@ -#lang racket -(provide compile compile-e - ; for notes - compile-string compile-symbol) -(require "ast.rkt" - "types.rkt" - "lambdas.rkt" - "fv.rkt" - "utils.rkt" - "compile-define.rkt" - "compile-expr.rkt" - "compile-literals.rkt" - a86/ast) - -;; Registers used -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r15 'r15) ; stack pad (non-volatile) - -;; type CEnv = (Listof [Maybe Id]) - -;; Prog -> Asm -(define (compile p) - (match p - [(Prog ds e) - (prog (externs) - (Global 'entry) - (Label 'entry) - (Push rbx) ; save callee-saved register - (Push r15) - (Mov rbx rdi) ; recv heap pointer - (init-symbol-table p) - (compile-defines-values ds) - (compile-e e (reverse (define-ids ds)) #f) - (Add rsp (* 8 (length ds))) ;; pop function definitions - (Pop r15) ; restore callee-save register - (Pop rbx) - (Ret) - (compile-defines ds) - (compile-lambda-defines (lambdas p)) - (Label 'raise_error_align) - pad-stack - (Call 'raise_error) - (Data) - (compile-literals p))])) - -(define (externs) - (seq (Extern 'peek_byte) - (Extern 'read_byte) - (Extern 'write_byte) - (Extern 'raise_error) - (Extern 'intern_symbol) - (Extern 'symb_cmp) - (Extern 'memcpy))) diff --git a/mug/compiler/assert.rkt b/mug/compiler/assert.rkt new file mode 100644 index 0000000..0d97df1 --- /dev/null +++ b/mug/compiler/assert.rkt @@ -0,0 +1,68 @@ +#lang racket +(provide assert-integer assert-char assert-byte assert-codepoint + assert-box assert-cons + assert-natural assert-vector assert-string + assert-proc assert-symbol) +(require a86/ast) +(require "../runtime/types.rkt") + +(define (assert-type mask type) + (λ (r) + (seq (Push r) + (And r mask) + (Cmp r type) + (Pop r) + (Jne 'err)))) + +;; Register -> Asm + + +(define assert-integer + (assert-type mask-int type-int)) + +;; Register -> Asm + +(define assert-char + (assert-type mask-char type-char)) +(define assert-box + (assert-type ptr-mask type-box)) +(define assert-cons + (assert-type ptr-mask type-cons)) +(define assert-vector + (assert-type ptr-mask type-vect)) +(define assert-string + (assert-type ptr-mask type-str)) +(define assert-proc + (assert-type ptr-mask type-proc)) +(define assert-symbol + (assert-type ptr-mask type-symb)) + +;; Register -> Asm +(define (assert-codepoint r) + (let ((ok (gensym))) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err) + (Cmp r (value->bits 1114111)) + (Jg 'err) + (Cmp r (value->bits 55295)) + (Jl ok) + (Cmp r (value->bits 57344)) + (Jg ok) + (Jmp 'err) + (Label ok)))) + +;; Register -> Asm +(define (assert-byte r) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err) + (Cmp r (value->bits 255)) + (Jg 'err))) + +;; Register -> Asm +(define (assert-natural r) + (seq (assert-integer r) + (Cmp r (value->bits 0)) + (Jl 'err))) + diff --git a/mug/compiler/compile-literals.rkt b/mug/compiler/compile-literals.rkt new file mode 100644 index 0000000..c0321d4 --- /dev/null +++ b/mug/compiler/compile-literals.rkt @@ -0,0 +1,48 @@ +#lang racket +(provide compile-literals init-symbol-table compile-string-chars symbol->data-label) +(require "../syntax/ast.rkt") +(require "../syntax/literals.rkt") +(require "../runtime/types.rkt") +(require a86/ast a86/registers) + +;; Prog -> Asm +(define (compile-literals p) + (append-map compile-literal (literals p))) + +;; Symbol -> Asm +(define (compile-literal s) + (let ((str (symbol->string s))) + (seq (Label (symbol->data-label s)) + (Dq (value->bits (string-length str))) + (compile-string-chars (string->list str)) + (if (odd? (string-length str)) + (seq (Dd 0)) + (seq))))) + +;; Prog -> Asm +;; Call intern_symbol on every symbol in the program +(define (init-symbol-table p) + (match (symbols p) + ['() (seq)] + [ss (seq (Sub 'rsp 8) + (append-map init-symbol ss) + (Add 'rsp 8))])) + +;; Symbol -> Asm +(define (init-symbol s) + (seq (Lea rdi (symbol->data-label s)) + (Extern 'intern_symbol) + (Call 'intern_symbol))) + +;; [Listof Char] -> Asm +(define (compile-string-chars cs) + (match cs + ['() (seq)] + [(cons c cs) + (seq (Dd (char->integer c)) + (compile-string-chars cs))])) + +(define (symbol->data-label s) + (symbol->label + (string->symbol (string-append "data_" (symbol->string s))))) + diff --git a/mug/compiler/compile-ops.rkt b/mug/compiler/compile-ops.rkt new file mode 100644 index 0000000..bf35a6a --- /dev/null +++ b/mug/compiler/compile-ops.rkt @@ -0,0 +1,298 @@ +#lang racket +(provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack assert-proc) +(require "../syntax/ast.rkt") +(require "../runtime/types.rkt") +(require "assert.rkt") +(require a86/ast a86/registers) + +;; Op0 -> Asm +(define (compile-op0 p) + (match p + ['void (seq (Mov rax (value->bits (void))))] + ['read-byte (seq (Extern 'read_byte) pad-stack (Call 'read_byte) unpad-stack)] + ['peek-byte (seq (Extern 'peek_byte) pad-stack (Call 'peek_byte) unpad-stack)])) + +;; Op1 -> Asm +(define (compile-op1 p) + (match p + ['add1 + (seq (assert-integer rax) + (Add rax (value->bits 1)))] + ['sub1 + (seq (assert-integer rax) + (Sub rax (value->bits 1)))] + ['zero? + (seq (assert-integer rax) + (Cmp rax 0) + if-equal)] + ['char? + (seq (And rax mask-char) + (Cmp rax type-char) + if-equal)] + ['char->integer + (seq (assert-char rax) + (Sar rax char-shift) + (Sal rax int-shift))] + ['integer->char + (seq (assert-codepoint rax) + (Sar rax int-shift) + (Sal rax char-shift) + (Xor rax type-char))] + ['eof-object? + (seq (Cmp rax (value->bits eof)) + if-equal)] + ['write-byte + (seq (Extern 'write_byte) + (assert-byte rax) + pad-stack + (Mov rdi rax) + (Call 'write_byte) + unpad-stack)] + ['box + (seq (Mov (Mem rbx) rax) ; memory write + (Mov rax rbx) ; put box in rax + (Xor rax type-box) ; tag as a box + (Add rbx 8))] + ['unbox + (seq (assert-box rax) + (Mov rax (Mem rax (- type-box))))] + ['car + (seq (assert-cons rax) + (Mov rax (Mem rax (- 0 type-cons))))] + ['cdr + (seq (assert-cons rax) + (Mov rax (Mem rax (- 8 type-cons))))] + + ['empty? (seq (Cmp rax (value->bits '())) if-equal)] + ['cons? (type-pred ptr-mask type-cons)] + ['box? (type-pred ptr-mask type-box)] + ['vector? (type-pred ptr-mask type-vect)] + ['string? (type-pred ptr-mask type-str)] + ['symbol? (type-pred ptr-mask type-symb)] + ['vector-length + (seq (assert-vector rax) + (Mov rax (Mem rax (- type-vect))))] + ['string-length + (seq (assert-string rax) + (Mov rax (Mem rax (- type-str))))] + ['string->symbol + (seq (assert-string rax) + (Xor rax type-str) + (Mov rdi rax) + pad-stack + (Extern 'intern_symbol) + (Call 'intern_symbol) + unpad-stack + (Or rax type-symb))] + ['symbol->string + (seq (assert-symbol rax) + (Xor rax type-symb) + char-array-copy + (Or rax type-str))] + ['string->uninterned-symbol + (seq (assert-string rax) + (Xor rax type-str) + char-array-copy + (Or rax type-symb))])) + +;; Op2 -> Asm +(define (compile-op2 p) + (match p + ['+ + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Add rax r8))] + ['- + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Sub r8 rax) + (Mov rax r8))] + ['< + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Cmp r8 rax) + if-lt)] + ['= + (seq (Pop r8) + (assert-integer r8) + (assert-integer rax) + (Cmp r8 rax) + if-equal)] + ['cons + (seq (Mov (Mem rbx 8) rax) + (Pop rax) + (Mov (Mem rbx 0) rax) + (Mov rax rbx) + (Xor rax type-cons) + (Add rbx 16))] + ['eq? + (seq (Pop r8) + (Cmp rax r8) + if-equal)] + ['make-vector + (let ((nonzero (gensym 'nz)) + (loop (gensym 'loop)) + (theend (gensym 'theend))) + + (seq (Pop r8) + (assert-natural r8) + + ; special case for length = 0 + (Cmp r8 0) + (Jne nonzero) + ; return canonical representation + (Lea rax (Mem 'empty type-vect)) + (Jmp theend) + + ; Code for nonzero case + (Label nonzero) + (Mov (Mem rbx 0) r8) ; write length + (Sar r8 1) ; convert to bytes + (Mov r9 r8) ; save for heap adjustment + + ; start initialization + (Label loop) + (Mov (Mem rbx r8) rax) + (Sub r8 8) + (Cmp r8 0) + (Jne loop) + ; end initialization + + (Mov rax rbx) + (Xor rax type-vect) ; create tagged pointer + (Add rbx r9) ; acct for elements and stored length + (Add rbx 8) + (Label theend)))] + + ['vector-ref + (seq (Pop r8) + (assert-vector r8) + (assert-natural rax) + (Mov r9 (Mem r8 (- type-vect))) + (Cmp rax r9) + (Jge 'err) + (Sar rax 1) + (Mov rax (Mem r8 rax (- 8 type-vect))))] + ['make-string + (let ((nonzero (gensym 'nz)) + (loop (gensym 'loop)) + (theend (gensym 'theend))) + (seq (Pop r8) + (assert-natural r8) + (assert-char rax) + + ; special case for length = 0 + (Cmp r8 0) + (Jne nonzero) + ; return canonical representation + (Lea rax (Mem 'empty type-str)) + (Jmp theend) + + ; Code for nonzero case + (Label nonzero) + + (Mov (Mem rbx 0) r8) ; write length + (Sar r8 2) ; convert to bytes + (Mov r9 r8) ; save for heap adjustment + + (Sar rax char-shift) ; convert to codepoint + + ; start initialization + (Label loop) + (Mov (Mem rbx r8 4) eax) + (Sub r8 4) + (Cmp r8 0) + (Jne loop) + ; end initialization + + (Mov rax rbx) + (Xor rax type-str) ; create tagged pointer + (Add rbx r9) ; acct for elements and stored length + (Add rbx 8) + ; Pad to 8-byte alignment + (Add rbx 4) + (Sar rbx 3) + (Sal rbx 3) + (Label theend)))] + + ['string-ref + (seq (Pop r8) + (assert-natural rax) + (assert-string r8) + (Mov r9 (Mem r8 (- type-str))) + (Cmp rax r9) + (Jge 'err) + (Sar rax 2) + (Mov eax (Mem r8 rax (- 8 type-str))) + (Sal rax char-shift) + (Xor rax type-char))])) + + +;; Op3 -> Asm +(define (compile-op3 p) + (match p + ['vector-set! + (seq (Pop r10) + (Pop r8) + (assert-vector r8) + (assert-natural r10) + (Mov r9 (Mem r8 (- type-vect))) + (Cmp r10 r9) + (Jge 'err) + (Sar r10 1) ; convert to byte offset + (Mov (Mem r8 r10 (- 8 type-vect)) rax) + (Mov rax (value->bits (void))))])) + +(define (type-pred mask type) + (seq (And rax mask) + (Cmp rax type) + if-equal)) + +;; Asm +;; set rax to #t or #f if comparison flag is equal +(define if-equal + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmove rax r9))) + +;; Asm +;; set rax to #t or #f if comparison flag is less than +(define if-lt + (seq (Mov rax (value->bits #f)) + (Mov r9 (value->bits #t)) + (Cmovl rax r9))) + + +;; Asm +;; Dynamically pad the stack to be aligned for a call +(define pad-stack + (seq (Mov r15 rsp) + (And r15 #b1000) + (Sub rsp r15))) + +;; Asm +;; Undo the stack alignment after a call +(define unpad-stack + (seq (Add rsp r15))) + +;; Asm +;; Copy sized array of characters pointed to by rax +(define char-array-copy + (seq (Mov rdi rbx) ; dst + (Mov rsi rax) ; src + (Mov rdx (Mem rax 0)) ; len + (Add rdx 1) ; #words = 1 + (len+1)/2 + (Sar rdx 1) + (Add rdx 1) + (Sal rdx 3) ; #bytes = 8*#words + (Mov r12 rdx) ; save rdx before destroyed + pad-stack + (Extern 'memcpy) + (Call 'memcpy) + unpad-stack + ; rbx should be preserved by memcpy + (Add rbx r12))) + diff --git a/mug/compiler/compile-stdin.rkt b/mug/compiler/compile-stdin.rkt new file mode 100644 index 0000000..f25989a --- /dev/null +++ b/mug/compiler/compile-stdin.rkt @@ -0,0 +1,14 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "compile.rkt") +(require "../syntax/read-all.rkt") +(require a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (asm-display (compile (apply parse-closed (read-all))))) + diff --git a/mountebank/compile-expr.rkt b/mug/compiler/compile.rkt similarity index 53% rename from mountebank/compile-expr.rkt rename to mug/compiler/compile.rkt index e2b9627..88b176b 100644 --- a/mountebank/compile-expr.rkt +++ b/mug/compiler/compile.rkt @@ -1,51 +1,157 @@ #lang racket -(provide compile-e compile-lambda-defines compile-lambda-define free-vars-to-heap) -(require "ast.rkt" - "types.rkt" - "lambdas.rkt" - "fv.rkt" - "utils.rkt" - "compile-ops.rkt" - "compile-datum.rkt" - a86/ast) - -;; Registers used -(define rax 'rax) ; return -(define rbx 'rbx) ; heap -(define rsp 'rsp) ; stack -(define rdi 'rdi) ; arg -(define r8 'r8) -(define r9 'r9) -(define rsi 'rsi) - -;; Expr CEnv Bool -> Asm +(provide compile + compile-e + compile-es + compile-define + compile-match + compile-match-clause + compile-lambda-define + copy-env-to-stack + free-vars-to-heap) + +(require "../syntax/ast.rkt") +(require "compile-ops.rkt") +(require "compile-literals.rkt") +(require "../runtime/types.rkt") +(require "../syntax/lambdas.rkt") +(require "../syntax/fv.rkt") +(require a86/ast a86/registers) + +;; Prog -> Asm +(define (compile p) + (match p + [(Prog ds e) + (prog (Global 'entry) + (Label 'entry) + (Push rbx) ; save callee-saved register + (Push r12) + (Push r15) + (Mov rbx rdi) ; recv heap pointer + (init-symbol-table p) + (compile-defines-values ds) + (compile-e e (reverse (define-ids ds)) #f) + (Add rsp (* 8 (length ds))) ;; pop function definitions + (Pop r15) ; restore callee-save register + (Pop r12) + (Pop rbx) + (Ret) + (compile-defines ds) + (compile-lambda-defines (lambdas p)) + (Label 'err) + pad-stack + (Extern 'raise_error) + (Call 'raise_error) + (Data) + (Label 'empty) + (Dq 0) + (compile-literals p))])) + +;; [Listof Defn] -> [Listof Id] +(define (define-ids ds) + (match ds + ['() '()] + [(cons (Defn f xs e) ds) + (cons f (define-ids ds))])) + +;; [Listof Defn] -> Asm +(define (compile-defines ds) + (match ds + ['() (seq)] + [(cons d ds) + (seq (compile-define d) + (compile-defines ds))])) + +;; Defn -> Asm +(define (compile-define d) + (match d + [(Defn f xs e) + (compile-lambda-define (Lam f xs e))])) + +;; [Listof Lam] -> Asm +(define (compile-lambda-defines ls) + (match ls + ['() (seq)] + [(cons l ls) + (seq (compile-lambda-define l) + (compile-lambda-defines ls))])) + +;; Lam -> Asm +(define (compile-lambda-define l) + (let ((fvs (fv l))) + (match l + [(Lam f xs e) + (let ((env (append (reverse fvs) (reverse xs) (list #f)))) + (seq (Label (symbol->label f)) + (Cmp r8 (length xs)) + (Jne 'err) + (Mov rax (Mem rsp (* 8 (length xs)))) + (copy-env-to-stack fvs 8) + (compile-e e env #t) + (Add rsp (* 8 (length env))) ; pop env + (Ret)))]))) + +;; [Listof Id] Int -> Asm +;; Copy the closure environment at given offset to stack +(define (copy-env-to-stack fvs off) + (match fvs + ['() (seq)] + [(cons _ fvs) + (seq (Mov r9 (Mem rax (- off type-proc))) + (Push r9) + (copy-env-to-stack fvs (+ 8 off)))])) + +;; type CEnv = (Listof [Maybe Id]) +;; Expr CEnv Boolean -> Asm (define (compile-e e c t?) (match e - [(Quote d) (compile-datum d)] - [(Eof) (seq (Mov rax (value->bits eof)))] - [(Var x) (compile-variable x c)] - [(Prim0 p) (compile-prim0 p c)] - [(Prim1 p e) (compile-prim1 p e c)] - [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] + [(Lit d) (compile-datum d)] + [(Eof) (seq (Mov rax (value->bits eof)))] + [(Var x) (compile-variable x c)] + [(Prim0 p) (compile-prim0 p)] + [(Prim1 p e) (compile-prim1 p e c)] + [(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)] [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)] - [(If e1 e2 e3) (compile-if e1 e2 e3 c t?)] - [(Begin e1 e2) (compile-begin e1 e2 c t?)] - [(Let x e1 e2) (compile-let x e1 e2 c t?)] - [(App e es) (compile-app e es c t?)] - [(Lam f xs e) (compile-lam f xs e c)] - [(Match e ps es) (compile-match e ps es c t?)])) + [(If e1 e2 e3) (compile-if e1 e2 e3 c t?)] + [(Begin e1 e2) (compile-begin e1 e2 c t?)] + [(Let x e1 e2) (compile-let x e1 e2 c t?)] + [(App e es) + (compile-app e es c t?)] + [(Lam f xs e) + (compile-lam f xs e c)] + [(Match e ps es) (compile-match e ps es c t?)])) + +;; Datum -> Asm +(define (compile-datum d) + (cond [(string? d) (compile-string d)] + [(symbol? d) (compile-symbol d)] + [else (seq (Mov rax (value->bits d)))])) + +;; Symbol -> Asm +(define (compile-symbol s) + (seq (Lea rax (Mem (symbol->data-label s) type-symb)))) + +;; String -> Asm +(define (compile-string s) + (seq (Lea rax (Mem (symbol->data-label (string->symbol s)) type-str)))) + +;; [Listof Char] -> Asm +(define (compile-string-chars cs) + (match cs + ['() (seq)] + [(cons c cs) + (seq (Dd (char->integer c)) + (compile-string-chars cs))])) + ;; Id CEnv -> Asm (define (compile-variable x c) - (match (lookup x c) - [#f (error "unbound variable")] ;(seq (Lea rax (symbol->label x)))] - [i (seq (Mov rax (Mem rsp i)))])) + (let ((i (lookup x c))) + (seq (Mov rax (Mem rsp i))))) -;; Op0 CEnv -> Asm -(define (compile-prim0 p c) +;; Op0 -> Asm +(define (compile-prim0 p) (compile-op0 p)) -;; Op1 Expr CEnv -> Asm (define (compile-prim1 p e c) (seq (compile-e e c #f) (compile-op1 p))) @@ -65,8 +171,7 @@ (Push rax) (compile-e e3 (cons #f (cons #f c)) #f) (compile-op3 p))) - -;; Expr Expr Expr CEnv Bool -> Asm +;; Expr Expr Expr CEnv Boolean -> Asm (define (compile-if e1 e2 e3 c t?) (let ((l1 (gensym 'if)) (l2 (gensym 'if))) @@ -78,25 +183,25 @@ (Label l1) (compile-e e3 c t?) (Label l2)))) - -;; Expr Expr CEnv Bool -> Asm +;; Expr Expr CEnv Boolean -> Asm (define (compile-begin e1 e2 c t?) (seq (compile-e e1 c #f) (compile-e e2 c t?))) - -;; Id Expr Expr CEnv Bool -> Asm +;; Id Expr Expr CEnv Boolean -> Asm (define (compile-let x e1 e2 c t?) (seq (compile-e e1 c #f) (Push rax) (compile-e e2 (cons x c) t?) (Add rsp 8))) -;; Id [Listof Expr] CEnv Bool -> Asm -(define (compile-app f es c t?) - ;(compile-app-nontail f es c) +;; Id [Listof Expr] CEnv -> Asm +;; The return address is placed above the arguments, so callee pops +;; arguments and return address is next frame +;; Expr [Listof Expr] CEnv Boolean -> Asm +(define (compile-app e es c t?) (if t? - (compile-app-tail f es c) - (compile-app-nontail f es c))) + (compile-app-tail e es c) + (compile-app-nontail e es c))) ;; Expr [Listof Expr] CEnv -> Asm (define (compile-app-tail e es c) @@ -105,8 +210,8 @@ (Add rsp (* 8 (length c))) (Mov rax (Mem rsp (* 8 (length es)))) (assert-proc rax) - (Xor rax type-proc) - (Mov rax (Mem rax 0)) + (Mov rax (Mem rax (- type-proc))) + (Mov r8 (length es)) ; pass arity info (Jmp rax))) ;; Integer Integer -> Asm @@ -129,19 +234,59 @@ (compile-es (cons e es) (cons #f c)) (Mov rax (Mem rsp i)) (assert-proc rax) - (Xor rax type-proc) - (Mov rax (Mem rax 0)) ; fetch the code label + (Mov rax (Mem rax (- type-proc))) ; fetch the code label + (Mov r8 (length es)) ; pass arity info (Jmp rax) (Label r)))) +;; Defns -> Asm +;; Compile the closures for ds and push them on the stack +(define (compile-defines-values ds) + (seq (alloc-defines ds 0) + (init-defines ds (reverse (define-ids ds)) 8) + (add-rbx-defines ds 0))) + +;; Defns Int -> Asm +;; Allocate closures for ds at given offset, but don't write environment yet +(define (alloc-defines ds off) + (match ds + ['() (seq)] + [(cons (Defn f xs e) ds) + (let ((fvs (fv (Lam f xs e)))) + (seq (Lea rax (symbol->label f)) + (Mov (Mem rbx off) rax) + (Mov rax rbx) + (Add rax off) + (Xor rax type-proc) + (Push rax) + (alloc-defines ds (+ off (* 8 (add1 (length fvs)))))))])) + +;; Defns CEnv Int -> Asm +;; Initialize the environment for each closure for ds at given offset +(define (init-defines ds c off) + (match ds + ['() (seq)] + [(cons (Defn f xs e) ds) + (let ((fvs (fv (Lam f xs e)))) + (seq (free-vars-to-heap fvs c off) + (init-defines ds c (+ off (* 8 (add1 (length fvs)))))))])) + +;; Defns Int -> Asm +;; Compute adjustment to rbx for allocation of all ds +(define (add-rbx-defines ds n) + (match ds + ['() (seq (Add rbx (* n 8)))] + [(cons (Defn f xs e) ds) + (add-rbx-defines ds (+ n (add1 (length (fv (Lam f xs e))))))])) + ;; Id [Listof Id] Expr CEnv -> Asm (define (compile-lam f xs e c) (let ((fvs (fv (Lam f xs e)))) (seq (Lea rax (symbol->label f)) - (Mov (Mem rbx 0) rax) + (Mov (Mem rbx) rax) (free-vars-to-heap fvs c 8) (Mov rax rbx) ; return value - (Or rax type-proc) + (Xor rax type-proc) (Add rbx (* 8 (add1 (length fvs))))))) ;; [Listof Id] CEnv Int -> Asm @@ -154,38 +299,6 @@ (Mov (Mem rbx off) r8) (free-vars-to-heap fvs c (+ off 8)))])) -;; [Listof Lam] -> Asm -(define (compile-lambda-defines ls) - (match ls - ['() (seq)] - [(cons l ls) - (seq (compile-lambda-define l) - (compile-lambda-defines ls))])) - -;; Lam -> Asm -(define (compile-lambda-define l) - (let ((fvs (fv l))) - (match l - [(Lam f xs e) - (let ((env (append (reverse fvs) (reverse xs) (list #f)))) - (seq (Label (symbol->label f)) - (Mov rax (Mem rsp (* 8 (length xs)))) - (Xor rax type-proc) - (copy-env-to-stack fvs 8) - (compile-e e env #t) - (Add rsp (* 8 (length env))) ; pop env - (Ret)))]))) - -;; [Listof Id] Int -> Asm -;; Copy the closure environment at given offset to stack -(define (copy-env-to-stack fvs off) - (match fvs - ['() (seq)] - [(cons _ fvs) - (seq (Mov r9 (Mem rax off)) - (Push r9) - (copy-env-to-stack fvs (+ 8 off)))])) - ;; [Listof Expr] CEnv -> Asm (define (compile-es es c) (match es @@ -201,7 +314,7 @@ (seq (compile-e e c #f) (Push rax) ; save away to be restored by each clause (compile-match-clauses ps es (cons #f c) done t?) - (Jmp 'raise_error_align) + (Jmp 'err) (Label done) (Add rsp 8)))) ; pop the saved value being matched @@ -218,7 +331,7 @@ (let ((next (gensym))) (match (compile-pattern p '() next) [(list i cm) - (seq (Mov rax (Mem rsp 0)) ; restore value being matched + (seq (Mov rax (Mem rsp)) ; restore value being matched i (compile-e e (append cm c) t?) (Add rsp (* 8 (length cm))) @@ -228,48 +341,21 @@ ;; Pat CEnv Symbol -> (list Asm CEnv) (define (compile-pattern p cm next) (match p - [(PWild) + [(Var '_) (list (seq) cm)] - [(PVar x) + [(Var x) (list (seq (Push rax)) (cons x cm))] - [(PStr s) - (let ((ok (gensym)) - (fail (gensym))) - (list (seq (Lea rdi (symbol->data-label (string->symbol s))) - (Mov r8 rax) - (And r8 ptr-mask) - (Cmp r8 type-str) - (Je ok) - (Label fail) - (Add rsp (* 8 (length cm))) - (Jmp next) - (Label ok) - (Xor rax type-str) - (Mov rsi rax) - pad-stack - (Call 'symb_cmp) - unpad-stack - (Cmp rax 0) - (Jne fail)) - cm))] - [(PSymb s) - (let ((ok (gensym))) - (list (seq (Lea r9 (Mem (symbol->data-label s) type-symb)) - (Cmp rax r9) - (Je ok) - (Add rsp (* 8 (length cm))) - (Jmp next) - (Label ok)) - cm))] - [(PLit l) + [(Lit l) (let ((ok (gensym))) - (list (seq (Cmp rax (value->bits l)) + (list (seq (Mov r8 rax) + (compile-datum l) + (Cmp rax r8) (Je ok) (Add rsp (* 8 (length cm))) (Jmp next) (Label ok)) cm))] - [(PAnd p1 p2) + [(Conj p1 p2) (match (compile-pattern p1 (cons #f cm) next) [(list i1 cm1) (match (compile-pattern p2 cm1 next) @@ -280,7 +366,7 @@ (Mov rax (Mem rsp (* 8 (- (sub1 (length cm1)) (length cm))))) i2) cm2)])])] - [(PBox p) + [(Box p) (match (compile-pattern p cm next) [(list i1 cm1) (let ((ok (gensym))) @@ -292,11 +378,10 @@ (Add rsp (* 8 (length cm))) ; haven't pushed anything yet (Jmp next) (Label ok) - (Xor rax type-box) - (Mov rax (Mem rax 0)) + (Mov rax (Mem rax (- type-box))) i1) cm1))])] - [(PCons p1 p2) + [(Cons p1 p2) (match (compile-pattern p1 (cons #f cm) next) [(list i1 cm1) (match (compile-pattern p2 cm1 next) @@ -311,10 +396,20 @@ (Jmp next) (Label ok) (Xor rax type-cons) - (Mov r8 (Mem rax 0)) + (Mov r8 (Mem rax 8)) (Push r8) ; push cdr - (Mov rax (Mem rax 8)) ; mov rax car + (Mov rax (Mem rax 0)) ; mov rax car i1 (Mov rax (Mem rsp (* 8 (- (sub1 (length cm1)) (length cm))))) i2) cm2))])])])) + +;; Id CEnv -> Integer +(define (lookup x cenv) + (match cenv + ['() (error "undefined variable:" x)] + [(cons y rest) + (match (eq? x y) + [#t 0] + [#f (+ 8 (lookup x rest))])])) + diff --git a/mug/executor/decode.rkt b/mug/executor/decode.rkt new file mode 100644 index 0000000..4ba7f96 --- /dev/null +++ b/mug/executor/decode.rkt @@ -0,0 +1,54 @@ +#lang racket + +(require "../runtime/types.rkt") +(require ffi/unsafe) + +(provide (all-defined-out)) + +;; Integer -> Value +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (mem-ref (- b type-box))))] + [(cons-bits? b) + (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) + (bits->value (mem-ref (+ 8 (- b type-cons)))))] + + [(vect-bits? b) + (let ((p (- b type-vect))) + (build-vector (bits->value (mem-ref p)) + (lambda (j) + (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] + [(str-bits? b) + (let ((p (- b type-str))) + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] + [(symb-bits? b) + (let ((p (- b type-symb))) + (string->symbol + (build-string (bits->value (mem-ref p)) + (lambda (j) + (integer->char (mem-ref32 (+ p 8 (* 4 j))))))))] + [else (error "invalid bits")])) + +(define (mem-ref i) + (ptr-ref (cast i _int64 _pointer) _int64)) + +(define (mem-ref32 i) + (ptr-ref (cast i _int64 _pointer) _int32)) + +(define _val + (make-ctype _int64 value->bits bits->value)) + diff --git a/mug/executor/exec.rkt b/mug/executor/exec.rkt new file mode 100644 index 0000000..9217a1d --- /dev/null +++ b/mug/executor/exec.rkt @@ -0,0 +1,70 @@ +#lang racket +(require a86/interp) + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe) +(require "decode.rkt") +(require "../runtime/types.rkt") +(struct exec-state (program heap) #:transparent) + +(define (symb-ptr->string p) + (define len (bits->value (ptr-ref p _uint64 0))) + (define cp-base (ptr-add p 8 _byte)) + (build-string + len + (λ (i) + (integer->char (ptr-ref cp-base _uint32 i))))) + +(define (exec/state prog) + (define intern-table (make-hash)) + (define (intern-symbol/cb p) + (define s (symb-ptr->string p)) + (hash-ref! intern-table s (λ () p))) + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)) + (extern 'intern_symbol + intern-symbol/cb + (_fun _pointer -> _pointer)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (asm-unload (exec-state-program st))) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/mug/executor/run-stdin.rkt b/mug/executor/run-stdin.rkt new file mode 100644 index 0000000..ac60d60 --- /dev/null +++ b/mug/executor/run-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "../compiler/compile.rkt") +(require "run.rkt") + +;; -> Void +;; Compile contents of stdin and use asm-interp to run +(define (main) + (read-line) ; ignore #lang racket line + + (run (compile (parse (read))))) + diff --git a/mug/executor/run.rkt b/mug/executor/run.rkt new file mode 100644 index 0000000..d96fe18 --- /dev/null +++ b/mug/executor/run.rkt @@ -0,0 +1,20 @@ +#lang racket +(require a86/interp) +(require "decode.rkt") +(require "exec.rkt") +(provide run run/io) +;; Asm -> Answer +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) +;; Asm String -> (cons Answer String) +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) + diff --git a/mug/interp-defun.rkt b/mug/interp-defun.rkt deleted file mode 100644 index 7d59532..0000000 --- a/mug/interp-defun.rkt +++ /dev/null @@ -1,164 +0,0 @@ -#lang racket -(provide interp interp-env (struct-out Closure) zip) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) -;; | (Closure [Listof Id] Expr Env) -(struct Closure (xs e r) #:prefab) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (interp-var x r ds)] - [(Str s) s] - [(Symb s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(Lam _ xs e) - (Closure xs e r)] - [(App e es) - (match (interp-env e r ds) - ['err 'err] - [f - (match (interp-env* es r ds) - ['err 'err] - [vs - (match f - [(Closure xs e r) - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (append (zip xs vs) r) ds) - 'err)] - [_ 'err])])])] - [(Match e ps es) - (match (interp-env e r ds) - ['err 'err] - [v - (interp-match v ps es r ds)])])) - -;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer -(define (interp-match v ps es r ds) - (match* (ps es) - [('() '()) 'err] - [((cons p ps) (cons e es)) - (match (interp-match-pat p v r) - [#f (interp-match v ps es r ds)] - [r (interp-env e r ds)])])) - -;; Pat Value Env -> [Maybe Env] -(define (interp-match-pat p v r) - (match p - [(PWild) r] - [(PVar x) (ext r x v)] - [(PSymb s) (and (eq? s v) r)] - [(PStr s) (and (string? v) (string=? s v) r)] - [(PLit l) (and (eqv? l v) r)] - [(PBox p) - (match v - [(box v) - (interp-match-pat p v r)] - [_ #f])] - [(PCons p1 p2) - (match v - [(cons v1 v2) - (match (interp-match-pat p1 v1 r) - [#f #f] - [r1 (interp-match-pat p2 v2 r1)])] - [_ #f])] - [(PAnd p1 p2) - (match (interp-match-pat p1 v r) - [#f #f] - [r1 (interp-match-pat p2 v r1)])])) - -;; Id Env [Listof Defn] -> Answer -(define (interp-var x r ds) - (match (lookup r x) - ['err (match (defns-lookup ds x) - [(Defn f xs e) (interp-env (Lam f xs e) '() ds)] - [#f 'err])] - [v v])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> [Maybe Defn] -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/mug/interp-io.rkt b/mug/interp-io.rkt deleted file mode 100644 index 93f7d3c..0000000 --- a/mug/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; (Expr String -> String -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e in) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string in))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/mug/interp-prims.rkt b/mug/interp-prims.rkt deleted file mode 100644 index 7797de6..0000000 --- a/mug/interp-prims.rkt +++ /dev/null @@ -1,74 +0,0 @@ -#lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) - -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) - [(list 'add1 (? integer?)) (add1 v)] - [(list 'sub1 (? integer?)) (sub1 v)] - [(list 'zero? (? integer?)) (zero? v)] - [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] - [(list 'integer->char (? codepoint?)) (integer->char v)] - [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] - [(list 'box v) (box v)] - [(list 'unbox (? box?)) (unbox v)] - [(list 'car (? pair?)) (car v)] - [(list 'cdr (? pair?)) (cdr v)] - [(list 'empty? v) (empty? v)] - [(list 'cons? v) (cons? v)] - [(list 'box? v) (box? v)] - [(list 'vector? v) (vector? v)] - [(list 'vector-length (? vector?)) (vector-length v)] - [(list 'string? v) (string? v)] - [(list 'string-length (? string?)) (string-length v)] - [(list 'symbol? v) (symbol? v)] - [(list 'symbol->string (? symbol?)) (symbol->string v)] - [(list 'string->symbol (? string?)) (string->symbol v)] - [(list 'string->uninterned-symbol (? string?)) - (string->uninterned-symbol v)] - [_ 'err])) - -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] - [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] - [(list 'make-vector (? integer?) _) - (if (<= 0 v1) - (make-vector v1 v2) - 'err)] - [(list 'vector-ref (? vector?) (? integer?)) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-ref v1 v2) - 'err)] - [(list 'make-string (? integer?) (? char?)) - (if (<= 0 v1) - (make-string v1 v2) - 'err)] - [(list 'string-ref (? string?) (? integer?)) - (if (<= 0 v2 (sub1 (string-length v1))) - (string-ref v1 v2) - 'err)] - [_ 'err])) - -;; Op3 Value Value Value -> Answer -(define (interp-prim3 p v1 v2 v3) - (match (list p v1 v2 v3) - [(list 'vector-set! (? vector?) (? integer?) _) - (if (<= 0 v2 (sub1 (vector-length v1))) - (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) - -;; Any -> Boolean -(define (codepoint? v) - (and (integer? v) - (or (<= 0 v 55295) - (<= 57344 v 1114111)))) diff --git a/mug/interp-stdin.rkt b/mug/interp-stdin.rkt deleted file mode 100644 index 965b9cc..0000000 --- a/mug/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read-all))))) - (unless (void? r) - (println r)))) diff --git a/mug/interp.rkt b/mug/interp.rkt deleted file mode 100644 index c295ca6..0000000 --- a/mug/interp.rkt +++ /dev/null @@ -1,163 +0,0 @@ -#lang racket -(provide interp interp-env) -(require "ast.rkt" - "env.rkt" - "interp-prims.rkt") - -;; type Answer = Value | 'err - -;; type Value = -;; | Integer -;; | Boolean -;; | Character -;; | Eof -;; | Void -;; | '() -;; | (cons Value Value) -;; | (box Value) -;; | (vector Value ...) -;; | (string Char ...) -;; | (Value ... -> Answer) - -;; type REnv = (Listof (List Id Value)) -;; type Defns = (Listof Defn) - -;; Prog -> Answer -(define (interp p) - (match p - [(Prog ds e) - (interp-env e '() ds)])) - -;; Expr Env Defns -> Answer -(define (interp-env e r ds) - (match e - [(Int i) i] - [(Bool b) b] - [(Char c) c] - [(Eof) eof] - [(Empty) '()] - [(Var x) (interp-var x r ds)] - [(Str s) s] - [(Symb s) s] - [(Prim0 'void) (void)] - [(Prim0 'read-byte) (read-byte)] - [(Prim0 'peek-byte) (peek-byte)] - [(Prim1 p e) - (match (interp-env e r ds) - ['err 'err] - [v (interp-prim1 p v)])] - [(Prim2 p e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (interp-prim2 p v1 v2)])])] - [(Prim3 p e1 e2 e3) - (match (interp-env e1 r ds) - ['err 'err] - [v1 (match (interp-env e2 r ds) - ['err 'err] - [v2 (match (interp-env e3 r ds) - ['err 'err] - [v3 (interp-prim3 p v1 v2 v3)])])])] - [(If p e1 e2) - (match (interp-env p r ds) - ['err 'err] - [v - (if v - (interp-env e1 r ds) - (interp-env e2 r ds))])] - [(Begin e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [_ (interp-env e2 r ds)])] - [(Let x e1 e2) - (match (interp-env e1 r ds) - ['err 'err] - [v (interp-env e2 (ext r x v) ds)])] - [(Lam _ xs e) - (λ vs - ; check arity matches - (if (= (length xs) (length vs)) - (interp-env e (append (zip xs vs) r) ds) - 'err))] - [(App e es) - (match (interp-env e r ds) - ['err 'err] - [f - (match (interp-env* es r ds) - ['err 'err] - [vs - (if (procedure? f) - (apply f vs) - 'err)])])] - [(Match e ps es) - (match (interp-env e r ds) - ['err 'err] - [v - (interp-match v ps es r ds)])])) - -;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer -(define (interp-match v ps es r ds) - (match* (ps es) - [('() '()) 'err] - [((cons p ps) (cons e es)) - (match (interp-match-pat p v r) - [#f (interp-match v ps es r ds)] - [r (interp-env e r ds)])])) - -;; Pat Value Env -> [Maybe Env] -(define (interp-match-pat p v r) - (match p - [(PWild) r] - [(PVar x) (ext r x v)] - [(PSymb s) (and (eq? s v) r)] - [(PStr s) (and (string? v) (string=? s v) r)] - [(PLit l) (and (eqv? l v) r)] - [(PBox p) - (match v - [(box v) - (interp-match-pat p v r)] - [_ #f])] - [(PCons p1 p2) - (match v - [(cons v1 v2) - (match (interp-match-pat p1 v1 r) - [#f #f] - [r1 (interp-match-pat p2 v2 r1)])] - [_ #f])] - [(PAnd p1 p2) - (match (interp-match-pat p1 v r) - [#f #f] - [r1 (interp-match-pat p2 v r1)])])) - -;; Id Env [Listof Defn] -> Answer -(define (interp-var x r ds) - (match (lookup r x) - ['err (match (defns-lookup ds x) - [(Defn f xs e) (interp-env (Lam f xs e) '() ds)] - [#f 'err])] - [v v])) - -;; (Listof Expr) REnv Defns -> (Listof Value) | 'err -(define (interp-env* es r ds) - (match es - ['() '()] - [(cons e es) - (match (interp-env e r ds) - ['err 'err] - [v (match (interp-env* es r ds) - ['err 'err] - [vs (cons v vs)])])])) - -;; Defns Symbol -> [Maybe Defn] -(define (defns-lookup ds f) - (findf (match-lambda [(Defn g _ _) (eq? f g)]) - ds)) - -(define (zip xs ys) - (match* (xs ys) - [('() '()) '()] - [((cons x xs) (cons y ys)) - (cons (list x y) - (zip xs ys))])) diff --git a/mug/env.rkt b/mug/interpreter/env.rkt similarity index 91% rename from mug/env.rkt rename to mug/interpreter/env.rkt index c43be9c..5c2ab01 100644 --- a/mug/env.rkt +++ b/mug/interpreter/env.rkt @@ -12,4 +12,5 @@ ;; Env Variable Value -> Value (define (ext r x i) - (cons (list x i) r)) \ No newline at end of file + (cons (list x i) r)) + diff --git a/mug/interpreter/interp-io.rkt b/mug/interpreter/interp-io.rkt new file mode 100644 index 0000000..f0bb535 --- /dev/null +++ b/mug/interpreter/interp-io.rkt @@ -0,0 +1,16 @@ +#lang racket +(provide interp/io) +(require "interp.rkt") +;; String Prog -> (Cons Answer String) +;; Interpret p with given string as input, +;; return answer and collected output as string +(define (interp/io p input) + (define result (box #f)) + (define output + (with-input-from-string input + (λ () + (with-output-to-string + (λ () + (set-box! result (interp p))))))) + (cons (unbox result) output)) + diff --git a/knock/interp-prims.rkt b/mug/interpreter/interp-prim.rkt similarity index 59% rename from knock/interp-prims.rkt rename to mug/interpreter/interp-prim.rkt index 15039f9..ea46c7f 100644 --- a/knock/interp-prims.rkt +++ b/mug/interpreter/interp-prim.rkt @@ -1,18 +1,24 @@ #lang racket -(require "ast.rkt") -(provide interp-prim1 interp-prim2 interp-prim3) +(provide interp-prim0 interp-prim1 interp-prim2 interp-prim3) -;; Op1 Value -> Answer -(define (interp-prim1 p1 v) - (match (list p1 v) +;; Op0 -> Value +(define (interp-prim0 op) + (match op + ['read-byte (read-byte)] + ['peek-byte (peek-byte)] + ['void (void)])) + +;; Op1 Value -> Value { raises 'err } +(define (interp-prim1 op v) + (match (list op v) [(list 'add1 (? integer?)) (add1 v)] [(list 'sub1 (? integer?)) (sub1 v)] [(list 'zero? (? integer?)) (zero? v)] [(list 'char? v) (char? v)] - [(list 'char->integer (? char?)) (char->integer v)] [(list 'integer->char (? codepoint?)) (integer->char v)] + [(list 'char->integer (? char?)) (char->integer v)] + [(list 'write-byte (? byte?)) (write-byte v)] [(list 'eof-object? v) (eof-object? v)] - [(list 'write-byte (? byte?)) (write-byte v)] [(list 'box v) (box v)] [(list 'unbox (? box?)) (unbox v)] [(list 'car (? pair?)) (car v)] @@ -24,46 +30,52 @@ [(list 'vector-length (? vector?)) (vector-length v)] [(list 'string? v) (string? v)] [(list 'string-length (? string?)) (string-length v)] - [_ 'err])) + [(list 'symbol? v) (symbol? v)] + [(list 'symbol->string (? symbol? v)) (symbol->string v)] + [(list 'string->symbol (? string? v)) (string->symbol v)] + [(list 'string->uninterned-symbol (? string? v)) + (string->uninterned-symbol v)] + [_ (raise 'err)])) -;; Op2 Value Value -> Answer -(define (interp-prim2 p v1 v2) - (match (list p v1 v2) - [(list '+ (? integer?) (? integer?)) (+ v1 v2)] - [(list '- (? integer?) (? integer?)) (- v1 v2)] - [(list '< (? integer?) (? integer?)) (< v1 v2)] - [(list '= (? integer?) (? integer?)) (= v1 v2)] +;; Op2 Value Value -> Value { raises 'err } +(define (interp-prim2 op v1 v2) + (match (list op v1 v2) + [(list '+ (? integer?) (? integer?)) (+ v1 v2)] + [(list '- (? integer?) (? integer?)) (- v1 v2)] + [(list '< (? integer?) (? integer?)) (< v1 v2)] + [(list '= (? integer?) (? integer?)) (= v1 v2)] + [(list 'eq? v1 v2) (eq? v1 v2)] [(list 'cons v1 v2) (cons v1 v2)] - [(list 'eq? v1 v2) (eq? v1 v2)] [(list 'make-vector (? integer?) _) (if (<= 0 v1) (make-vector v1 v2) - 'err)] + (raise 'err))] [(list 'vector-ref (? vector?) (? integer?)) (if (<= 0 v2 (sub1 (vector-length v1))) (vector-ref v1 v2) - 'err)] + (raise 'err))] [(list 'make-string (? integer?) (? char?)) (if (<= 0 v1) (make-string v1 v2) - 'err)] + (raise 'err))] [(list 'string-ref (? string?) (? integer?)) (if (<= 0 v2 (sub1 (string-length v1))) (string-ref v1 v2) - 'err)] - [_ 'err])) + (raise 'err))] + [_ (raise 'err)])) -;; Op3 Value Value Value -> Answer +;; Op3 Value Value Value -> Value { raises 'err } (define (interp-prim3 p v1 v2 v3) (match (list p v1 v2 v3) [(list 'vector-set! (? vector?) (? integer?) _) (if (<= 0 v2 (sub1 (vector-length v1))) (vector-set! v1 v2 v3) - 'err)] - [_ 'err])) + (raise 'err))] + [_ (raise 'err)])) ;; Any -> Boolean (define (codepoint? v) (and (integer? v) (or (<= 0 v 55295) (<= 57344 v 1114111)))) + diff --git a/mug/interpreter/interp-stdin.rkt b/mug/interpreter/interp-stdin.rkt new file mode 100644 index 0000000..7d85c32 --- /dev/null +++ b/mug/interpreter/interp-stdin.rkt @@ -0,0 +1,13 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt") +(require "interp.rkt") +(require "../syntax/read-all.rkt") + +;; -> Void +;; Parse and interpret contents of stdin, +;; print result on stdout +(define (main) + (read-line) ; ignore #lang racket line + (println (interp (apply parse-closed (read-all))))) + diff --git a/mug/interpreter/interp.rkt b/mug/interpreter/interp.rkt new file mode 100644 index 0000000..46d5c35 --- /dev/null +++ b/mug/interpreter/interp.rkt @@ -0,0 +1,136 @@ +#lang racket +(provide interp interp-e) +(provide interp-match-pat) +(require "../syntax/ast.rkt") +(require "interp-prim.rkt") +(require "env.rkt") + +;; type Value = +;; | Integer +;; | Boolean +;; | Character +;; | Eof +;; | Void +;; | '() +;; | (cons Value Value) +;; | (box Value) +;; | (string Character ...) +;; | (vector Value ...) +;; | (Value ... -> Answer) + +;; type Answer = Value | 'err + +;; type Env = (Listof (List Id Value)) + +(define (err? x) (eq? x 'err)) +;; ClosedExpr -> Answer +;; Prog -> Answer +(define (interp p) + (with-handlers ([err? identity]) + (match p + [(Prog ds e) + (interp-e e '() ds)]))) +;l Expr Env Defns -> Value { raises 'err } +(define (interp-e e r ds) ;; where r closes e + (match e + [(Var x) (interp-var x r ds)] + [(Lit d) d] + [(Eof) eof] + [(Prim0 p) + (interp-prim0 p)] + [(Prim1 p e) + (interp-prim1 p (interp-e e r ds))] + [(Prim2 p e1 e2) + (interp-prim2 p + (interp-e e1 r ds) + (interp-e e2 r ds))] + [(Prim3 p e1 e2 e3) + (interp-prim3 p + (interp-e e1 r ds) + (interp-e e2 r ds) + (interp-e e3 r ds))] + [(If e1 e2 e3) + (if (interp-e e1 r ds) + (interp-e e2 r ds) + (interp-e e3 r ds))] + [(Begin e1 e2) + (begin (interp-e e1 r ds) + (interp-e e2 r ds))] + [(Let x e1 e2) + (let ((v (interp-e e1 r ds))) + (interp-e e2 (ext r x v) ds))] + [(App e es) + (let ((f (interp-e e r ds)) + (vs (interp-e* es r ds))) + (if (procedure? f) + (apply f vs) + (raise 'err)))] + [(Match e ps es) + (let ((v (interp-e e r ds))) + (interp-match v ps es r ds))] + [(Lam f xs e) + (λ vs + ; check arity matches + (if (= (length xs) (length vs)) + (interp-e e (append (zip xs vs) r) ds) + (raise 'err)))])) + +;; (Listof Expr) REnv Defns -> (Listof Value) { raises 'err } +(define (interp-e* es r ds) + (match es + ['() '()] + [(cons e es) + (cons (interp-e e r ds) + (interp-e* es r ds))])) + +;; Id Env [Listof Defn] -> Answer +(define (interp-var x r ds) + (match (lookup r x) + ['err (match (defns-lookup ds x) + [(Defn f xs e) (interp-e (Lam f xs e) '() ds)] + [#f 'err])] + [v v])) + +;; Value [Listof Pat] [Listof Expr] Env Defns -> Answer +(define (interp-match v ps es r ds) + (match* (ps es) + [('() '()) 'err] + [((cons p ps) (cons e es)) + (match (interp-match-pat p v r) + [#f (interp-match v ps es r ds)] + [r (interp-e e r ds)])])) +;; Pat Value Env -> [Maybe Env] +(define (interp-match-pat p v r) + (match p + [(Var '_) r] + [(Var x) (ext r x v)] + [(Lit l) (and (eqv? l v) r)] + [(Box p) + (match v + [(box v) + (interp-match-pat p v r)] + [_ #f])] + [(Cons p1 p2) + (match v + [(cons v1 v2) + (match (interp-match-pat p1 v1 r) + [#f #f] + [r1 (interp-match-pat p2 v2 r1)])] + [_ #f])] + [(Conj p1 p2) + (match (interp-match-pat p1 v r) + [#f #f] + [r1 (interp-match-pat p2 v r1)])])) + +;; Defns Symbol -> Defn +(define (defns-lookup ds f) + (findf (match-lambda [(Defn g _ _) (eq? f g)]) + ds)) + +(define (zip xs ys) + (match* (xs ys) + [('() '()) '()] + [((cons x xs) (cons y ys)) + (cons (list x y) + (zip xs ys))])) + diff --git a/mug/main.c b/mug/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/mug/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/mug/main.rkt b/mug/main.rkt new file mode 100644 index 0000000..f9851a3 --- /dev/null +++ b/mug/main.rkt @@ -0,0 +1,18 @@ +#lang racket +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) + diff --git a/mug/parse-file.rkt b/mug/parse-file.rkt deleted file mode 100644 index a502132..0000000 --- a/mug/parse-file.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; String -> Void -;; Compile contents of given file name, -;; emit asm code on stdout -(define (main fn) - (let ((p (open-input-file fn))) - (begin - (read-line p) ; ignore #lang racket line - (displayln (parse (read-all p))) - (close-input-port p)))) diff --git a/mug/parse.rkt b/mug/parse.rkt deleted file mode 100644 index 5de4e9b..0000000 --- a/mug/parse.rkt +++ /dev/null @@ -1,102 +0,0 @@ -#lang racket -(provide parse parse-define parse-e) -(require "ast.rkt") - -;; [Listof S-Expr] -> Prog -(define (parse s) - (match s - [(cons (and (cons 'define _) d) s) - (match (parse s) - [(Prog ds e) - (Prog (cons (parse-define d) ds) e)])] - [(cons e '()) (Prog '() (parse-e e))] - [_ (error "program parse error")])) - -;; S-Expr -> Defn -(define (parse-define s) - (match s - [(list 'define (list-rest (? symbol? f) xs) e) - (if (andmap symbol? xs) - (Defn f xs (parse-e e)) - (error "parse definition error"))] - [_ (error "Parse defn error" s)])) - -;; S-Expr -> Expr -(define (parse-e s) - (match s - [(? exact-integer?) (Int s)] - [(? boolean?) (Bool s)] - [(? char?) (Char s)] - [(? string?) (Str s)] - ['eof (Eof)] - [(? symbol?) (Var s)] - [(list 'quote (list)) (Empty)] - [(list 'quote (? symbol? s)) (Symb s)] - [(list (? (op? op0) p0)) (Prim0 p0)] - [(list (? (op? op1) p1) e) (Prim1 p1 (parse-e e))] - [(list (? (op? op2) p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))] - [(list (? (op? op3) p3) e1 e2 e3) - (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'begin e1 e2) - (Begin (parse-e e1) (parse-e e2))] - [(list 'if e1 e2 e3) - (If (parse-e e1) (parse-e e2) (parse-e e3))] - [(list 'let (list (list (? symbol? x) e1)) e2) - (Let x (parse-e e1) (parse-e e2))] - [(cons 'match (cons e ms)) - (parse-match (parse-e e) ms)] - [(list (or 'lambda 'λ) xs e) - (if (and (list? xs) - (andmap symbol? xs)) - (Lam (gensym 'lambda) xs (parse-e e)) - (error "parse lambda error"))] - [(cons e es) - (App (parse-e e) (map parse-e es))] - [_ (error "Parse error" s)])) - -(define (parse-match e ms) - (match ms - ['() (Match e '() '())] - [(cons (list p r) ms) - (match (parse-match e ms) - [(Match e ps es) - (Match e - (cons (parse-pat p) ps) - (cons (parse-e r) es))])])) - -(define (parse-pat p) - (match p - [(? boolean?) (PLit p)] - [(? integer?) (PLit p)] - [(? char?) (PLit p)] - ['_ (PWild)] - [(? symbol?) (PVar p)] - [(? string?) (PStr p)] - [(list 'quote (? symbol? s)) - (PSymb s)] - [(list 'quote (list)) - (PLit '())] - [(list 'box p) - (PBox (parse-pat p))] - [(list 'cons p1 p2) - (PCons (parse-pat p1) (parse-pat p2))] - [(list 'and p1 p2) - (PAnd (parse-pat p1) (parse-pat p2))])) - -(define op0 - '(read-byte peek-byte void)) -(define op1 - '(add1 sub1 zero? char? write-byte eof-object? - integer->char char->integer - box unbox empty? cons? box? car cdr - vector? vector-length string? string-length - symbol? symbol->string string->symbol string->uninterned-symbol)) -(define op2 - '(+ - < = cons eq? make-vector vector-ref make-string string-ref)) -(define op3 - '(vector-set!)) - -(define (op? ops) - (λ (x) - (and (symbol? x) - (memq x ops)))) diff --git a/mug/run.rkt b/mug/run.rkt deleted file mode 100644 index eaa53eb..0000000 --- a/mug/run.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide run run/io) -(require "types.rkt" "build-runtime.rkt" - a86/interp) - -;; Asm -> Answer -(define (run is) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp is) - ['err 'err] - [b (bits->value b)]))) - -;; Asm String -> (cons Answer String) -(define (run/io is s) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp/io is s) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) diff --git a/mug/runtime.h b/mug/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/mug/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/mug/runtime/Makefile b/mug/runtime/Makefile new file mode 100644 index 0000000..ee8ff93 --- /dev/null +++ b/mug/runtime/Makefile @@ -0,0 +1,29 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + values.o \ + print.o \ + io.o \ + symbol.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/mug/char.c b/mug/runtime/char.c similarity index 100% rename from mug/char.c rename to mug/runtime/char.c diff --git a/mug/runtime/error.c b/mug/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/mug/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/mug/heap.h b/mug/runtime/heap.h similarity index 100% rename from mug/heap.h rename to mug/runtime/heap.h diff --git a/mountebank/io.c b/mug/runtime/io.c similarity index 50% rename from mountebank/io.c rename to mug/runtime/io.c index 7ef8228..9f1fc45 100644 --- a/mountebank/io.c +++ b/mug/runtime/io.c @@ -1,25 +1,25 @@ #include -#include -#include "types.h" +#include #include "values.h" #include "runtime.h" val_t read_byte(void) { - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + int c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + int c = getc(stdin); + if (c != EOF) + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); - } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + int b = val_unwrap_int(c); + putc((unsigned char)b, stdout); return val_wrap_void(); } diff --git a/mug/runtime/main.c b/mug/runtime/main.c new file mode 100644 index 0000000..610b2bf --- /dev/null +++ b/mug/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/mountebank/print.c b/mug/runtime/print.c similarity index 98% rename from mountebank/print.c rename to mug/runtime/print.c index 2bcb21d..1a9f8a7 100644 --- a/mountebank/print.c +++ b/mug/runtime/print.c @@ -8,6 +8,7 @@ void print_cons(val_cons_t *); void print_vect(val_vect_t*); void print_str(val_str_t*); void print_symb(val_symb_t*); +void print_struct(val_struct_t *); void print_str_char(val_char_t); void print_result_interior(val_t); int utf8_encode_char(val_char_t, char *); @@ -48,11 +49,20 @@ void print_result(val_t x) case T_PROC: printf("#"); break; + case T_STRUCT: + print_struct(val_unwrap_struct(x)); + break; case T_INVALID: printf("internal error"); } } +void print_struct(val_struct_t *s) { + printf("#<"); + print_result_interior(s->name); + printf(">"); +} + void print_symb(val_symb_t *s) { print_str((val_str_t*) s); diff --git a/mountebank/print.h b/mug/runtime/print.h similarity index 100% rename from mountebank/print.h rename to mug/runtime/print.h diff --git a/mug/runtime/runtime.h b/mug/runtime/runtime.h new file mode 100644 index 0000000..2ec5ef1 --- /dev/null +++ b/mug/runtime/runtime.h @@ -0,0 +1,27 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +/* + * Entry point for compiled programs. + * + * The caller supplies the heap pointer. Compiled code may use this as its + * initial allocation pointer / runtime heap base according to the language's + * calling convention. + */ +val_t entry(val_t *heap); + +/* + * Language-facing runtime operations used by compiled code. + * + * These are implemented by the runtime core, typically in terms of lower-level + * host hooks declared in host.h. + */ +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/mug/symbol.c b/mug/runtime/symbol.c similarity index 100% rename from mug/symbol.c rename to mug/runtime/symbol.c diff --git a/mountebank/types.h b/mug/runtime/types.h similarity index 65% rename from mountebank/types.h rename to mug/runtime/types.h index 4093c4f..084310e 100644 --- a/mountebank/types.h +++ b/mug/runtime/types.h @@ -2,41 +2,51 @@ #define TYPES_H /* - Bit layout of values + * Bit layout of runtime values + * + * Values are either: + * - immediates, tagged with low bits ending in #b000 + * - pointers, tagged with one of the pointer tags below + * + * Immediates include: + * - integers + * - characters + * - booleans + * - eof + * - void + * - empty list + */ - Values are either: - - Immediates: end in #b000 - - Pointers - - Immediates are either - - Integers: end in #b0 000 - - Characters: end in #b01 000 - - True: #b11 000 - - False: #b1 11 000 - - Eof: #b10 11 000 - - Void: #b11 11 000 - - Empty: #b100 11 000 -*/ +/* low bits reserved for pointer/immediate discrimination */ #define imm_shift 3 #define ptr_type_mask ((1 << imm_shift) - 1) + +/* pointer tags */ #define box_type_tag 1 #define cons_type_tag 2 #define vect_type_tag 3 #define str_type_tag 4 #define proc_type_tag 5 #define symb_type_tag 6 +#define struct_type_tag 7 + +/* integer immediates */ #define int_shift (1 + imm_shift) #define int_type_mask ((1 << int_shift) - 1) #define int_type_tag (0 << (int_shift - 1)) #define nonint_type_tag (1 << (int_shift - 1)) + +/* character immediates */ #define char_shift (int_shift + 1) #define char_type_mask ((1 << char_shift) - 1) #define char_type_tag ((0 << (char_shift - 1)) | nonint_type_tag) #define nonchar_type_tag ((1 << (char_shift - 1)) | nonint_type_tag) + +/* distinguished immediate constants */ #define val_true ((0 << char_shift) | nonchar_type_tag) #define val_false ((1 << char_shift) | nonchar_type_tag) #define val_eof ((2 << char_shift) | nonchar_type_tag) #define val_void ((3 << char_shift) | nonchar_type_tag) #define val_empty ((4 << char_shift) | nonchar_type_tag) -#endif +#endif /* TYPES_H */ diff --git a/jig/types.rkt b/mug/runtime/types.rkt similarity index 51% rename from jig/types.rkt rename to mug/runtime/types.rkt index c0c1d70..79c8486 100644 --- a/jig/types.rkt +++ b/mug/runtime/types.rkt @@ -1,6 +1,5 @@ #lang racket (provide (all-defined-out)) -(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -9,6 +8,9 @@ (define type-cons #b010) (define type-vect #b011) (define type-str #b100) +(define type-proc #b101) +(define type-symb #b110) +(define type-bint #b110) (define int-shift (+ 1 imm-shift)) (define mask-int #b1111) (define char-shift (+ 2 imm-shift)) @@ -16,35 +18,6 @@ (define type-char #b01000) (define mask-char #b11111) -;; Integer -> Value -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (mem-ref (- b type-box))))] - [(cons-bits? b) - (cons (bits->value (mem-ref (+ 0 (- b type-cons)))) - (bits->value (mem-ref (+ 8 (- b type-cons)))))] - - [(vect-bits? b) - (let ((p (- b type-vect))) - (build-vector (bits->value (mem-ref p)) - (lambda (j) - (bits->value (mem-ref (+ p (* 8 (add1 j))))))))] - [(str-bits? b) - (let ((p (- b type-str))) - (build-string (bits->value (mem-ref p)) - (lambda (j) - (integer->char (mem-ref32 (+ p 8 (* 4 j)))))))] - [else (error "invalid bits")])) - ;; Value -> Integer ;; v must be an immediate (define (value->bits v) @@ -80,9 +53,12 @@ (define (str-bits? v) (= type-str (bitwise-and v imm-mask))) -(define (mem-ref i) - (ptr-ref (cast i _int64 _pointer) _int64)) +(define (bignum-bits? v) + (= type-bint (bitwise-and v imm-mask))) + +(define (proc-bits? v) + (= type-proc (bitwise-and v imm-mask))) -(define (mem-ref32 i) - (ptr-ref (cast i _int64 _pointer) _int32)) +(define (symb-bits? v) + (= type-symb (bitwise-and v imm-mask))) diff --git a/mug/values.c b/mug/runtime/values.c similarity index 90% rename from mug/values.c rename to mug/runtime/values.c index 32e922b..6627fc2 100644 --- a/mug/values.c +++ b/mug/runtime/values.c @@ -16,6 +16,8 @@ type_t val_typeof(val_t x) return T_SYMB; case proc_type_tag: return T_PROC; + case struct_type_tag: + return T_STRUCT; } if ((int_type_mask & x) == int_type_tag) @@ -119,3 +121,12 @@ val_t val_wrap_symb(val_symb_t *v) { return ((val_t)v) | symb_type_tag; } + +val_struct_t* val_unwrap_struct(val_t x) +{ + return (val_struct_t *)(x ^ struct_type_tag); +} +val_t val_wrap_struct(val_struct_t* v) +{ + return ((val_t)v) | struct_type_tag; +} diff --git a/mug/runtime/values.h b/mug/runtime/values.h new file mode 100644 index 0000000..5c41275 --- /dev/null +++ b/mug/runtime/values.h @@ -0,0 +1,119 @@ +#ifndef VALUES_H +#define VALUES_H + +#include + +/* + * Abstract runtime value. + * + * All language values are represented as a tagged 64-bit word. + */ +typedef int64_t val_t; + +/* + * Dynamic type tags used by the runtime and printing code. + */ +typedef enum type_t { + T_INVALID = -1, + + /* immediates */ + T_INT, + T_BOOL, + T_CHAR, + T_EOF, + T_VOID, + T_EMPTY, + + /* heap objects */ + T_BOX, + T_CONS, + T_VECT, + T_STR, + T_SYMB, + T_PROC, + T_STRUCT, +} type_t; + +typedef uint32_t val_char_t; + +/* + * Heap object layouts. + * + * These layouts correspond to the pointer-tagged representations in types.h. + */ +typedef struct val_box_t { + val_t val; +} val_box_t; + +typedef struct val_cons_t { + val_t snd; + val_t fst; +} val_cons_t; + +typedef struct val_vect_t { + uint64_t len; + val_t elems[]; +} val_vect_t; + +typedef struct val_str_t { + uint64_t len; + val_char_t codepoints[]; +} val_str_t; + +typedef struct val_symb_t { + uint64_t len; + val_char_t codepoints[]; +} val_symb_t; + +typedef struct val_struct_t { + val_t name; + val_t *vals; +} val_struct_t; + +/* + * Classify a runtime value. + */ +type_t val_typeof(val_t x); + +/* + * Wrap/unwrap operations. + * + * The behavior of unwrap functions is undefined on type mismatch. + */ + +/* integers */ +int64_t val_unwrap_int(val_t x); +val_t val_wrap_int(int64_t i); + +/* booleans */ +int val_unwrap_bool(val_t x); +val_t val_wrap_bool(int b); + +/* characters */ +val_char_t val_unwrap_char(val_t x); +val_t val_wrap_char(val_char_t c); + +/* special values */ +val_t val_wrap_eof(void); +val_t val_wrap_void(void); + +/* heap objects */ +val_box_t *val_unwrap_box(val_t x); +val_t val_wrap_box(val_box_t *b); + +val_cons_t *val_unwrap_cons(val_t x); +val_t val_wrap_cons(val_cons_t *c); + +val_vect_t *val_unwrap_vect(val_t x); +val_t val_wrap_vect(val_vect_t *v); + +val_str_t *val_unwrap_str(val_t x); +val_t val_wrap_str(val_str_t *v); + +val_symb_t *val_unwrap_symb(val_t x); +val_t val_wrap_symb(val_symb_t *v); + +val_struct_t *val_unwrap_struct(val_t x); +val_t val_wrap_struct(val_struct_t *v); + +#endif /* VALUES_H */ diff --git a/mug/syntax/ast.rkt b/mug/syntax/ast.rkt new file mode 100644 index 0000000..8330791 --- /dev/null +++ b/mug/syntax/ast.rkt @@ -0,0 +1,75 @@ +#lang racket +(provide Lit Prim0 Prim1 Prim2 Prim3 If + Eof Begin + Let Var Prog Defn App + Match Box Cons Conj + Lam) + +;; type Prog = (Prog (Listof Defn) Expr) +(struct Prog (ds e) #:prefab) + +;; type Defn = (Defn Id (Listof Id) Expr) +(struct Defn (f xs e) #:prefab) +;; type Expr = (Lit Datum) +;; | (Eof) +;; | (Prim0 Op0) +;; | (Prim1 Op1 Expr) +;; | (Prim2 Op2 Expr Expr) +;; | (Prim3 Op3 Expr Expr Expr) +;; | (If Expr Expr Expr) +;; | (Begin Expr Expr) +;; | (Let Id Expr Expr) +;; | (Var Id) +;; | (App Expr (Listof Expr)) +;; | (Match Expr (Listof Pat) (Listof Expr)) +;; | (Lam Id (Listof Id) Expr) + +;; type ClosedExpr = { e ∈ Expr | e contains no free variables } + +;; type Id = Symbol +;; type Datum = Integer +;; | Boolean +;; | Character +;; | '() +;; | String +;; | Symbol +;; type Op0 = 'read-byte | 'peek-byte | 'void +;; type Op1 = 'add1 | 'sub1 +;; | 'zero? +;; | 'char? | 'integer->char | 'char->integer +;; | 'write-byte | 'eof-object? +;; | 'car | 'cdr | 'unbox +;; | 'empty? | 'cons? | 'box? +;; | 'box +;; | 'vector? | 'vector-length +;; | 'string? | 'string-length +;; | 'symbol? | 'symbol->string | 'string->symbol | 'string->uninterned-symbol +;; type Op2 = '+ | '- | '< | '= +;; | 'eq? | 'cons +;; | 'make-vector | 'vector-ref +;; | 'make-string | 'string-ref +;; type Op3 = 'vector-set! +;; type Pat = (Var Id) +;; | (Lit Datum) +;; | (Box Pat) +;; | (Cons Pat Pat) +;; | (Conj Pat Pat) + +(struct Eof () #:prefab) +(struct Lit (d) #:prefab) +(struct Prim0 (p) #:prefab) +(struct Prim1 (p e) #:prefab) +(struct Prim2 (p e1 e2) #:prefab) +(struct Prim3 (p e1 e2 e3) #:prefab) +(struct If (e1 e2 e3) #:prefab) +(struct Begin (e1 e2) #:prefab) +(struct Let (x e1 e2) #:prefab) +(struct Var (x) #:prefab) +(struct App (f es) #:prefab) +(struct Lam (f xs e) #:prefab) +(struct Match (e ps es) #:prefab) + +(struct Box (p) #:prefab) +(struct Cons (p1 p2) #:prefab) +(struct Conj (p1 p2) #:prefab) + diff --git a/mug/fv.rkt b/mug/syntax/fv.rkt similarity index 83% rename from mug/fv.rkt rename to mug/syntax/fv.rkt index 2377b7e..1cec0d9 100644 --- a/mug/fv.rkt +++ b/mug/syntax/fv.rkt @@ -28,8 +28,9 @@ ;; Pat -> [Listof Id] (define (bv-pat* p) (match p - [(PVar x) (list x)] - [(PCons p1 p2) (append (bv-pat* p1) (bv-pat* p2))] - [(PAnd p1 p2) (append (bv-pat* p1) (bv-pat* p2))] - [(PBox p) (bv-pat* p)] - [_ '()])) + [(Var x) (list x)] + [(Lit d) '()] + [(Box p) (bv-pat* p)] + [(Cons p1 p2) (append (bv-pat* p1) (bv-pat* p2))] + [(Conj p1 p2) (append (bv-pat* p1) (bv-pat* p2))])) + diff --git a/mug/lambdas.rkt b/mug/syntax/lambdas.rkt similarity index 100% rename from mug/lambdas.rkt rename to mug/syntax/lambdas.rkt index 0a24640..83c5aa8 100644 --- a/mug/lambdas.rkt +++ b/mug/syntax/lambdas.rkt @@ -2,7 +2,6 @@ (require "ast.rkt") (provide lambdas) - ;; Prog -> [Listof Lam] ;; List all of the lambda expressions in p (define (lambdas p) @@ -33,3 +32,4 @@ [(Lam f xs e1) (cons e (lambdas-e e1))] [(Match e ps es) (append (lambdas-e e) (append-map lambdas-e es))] [_ '()])) + diff --git a/mug/compile-literals.rkt b/mug/syntax/literals.rkt similarity index 53% rename from mug/compile-literals.rkt rename to mug/syntax/literals.rkt index 0435961..09ff2de 100644 --- a/mug/compile-literals.rkt +++ b/mug/syntax/literals.rkt @@ -1,38 +1,8 @@ #lang racket -(provide compile-literals init-symbol-table literals compile-string-chars) -(require "ast.rkt" - "utils.rkt" - a86/ast) +(provide literals symbols) -(define rdi 'rdi) +(require "ast.rkt") -;; Prog -> Asm -(define (compile-literals p) - (append-map compile-literal (literals p))) - -;; Symbol -> Asm -(define (compile-literal s) - (let ((str (symbol->string s))) - (seq (Label (symbol->data-label s)) - (Dq (string-length str)) - (compile-string-chars (string->list str)) - (if (odd? (string-length str)) - (seq (Dd 0)) - (seq))))) - -;; Prog -> Asm -;; Call intern_symbol on every symbol in the program -(define (init-symbol-table p) - (match (symbols p) - ['() (seq)] - [ss (seq (Sub 'rsp 8) - (append-map init-symbol ss) - (Add 'rsp 8))])) - -;; Symbol -> Asm -(define (init-symbol s) - (seq (Lea rdi (symbol->data-label s)) - (Call 'intern_symbol))) ;; Prog -> [Listof Symbol] (define (literals p) @@ -64,8 +34,7 @@ ;; Expr -> [Listof (U Symbol String)] (define (literals-e e) (match e - [(Str s) (list s)] - [(Symb s) (list s)] + [(Lit d) (literals-datum d)] [(Prim1 p e) (literals-e e)] [(Prim2 p e1 e2) @@ -86,6 +55,13 @@ (append (literals-e e) (append-map literals-match-clause ps es))] [_ '()])) +;; Datum -> [Listof (U Symbol String)] +(define (literals-datum d) + (cond + [(string? d) (list d)] + [(symbol? d) (list d)] + [else '()])) + ;; Pat Expr -> [Listof (U Symbol String)] (define (literals-match-clause p e) (append (literals-pat p) (literals-e e))) @@ -93,17 +69,9 @@ ;; Pat -> [Listof (U Symbol String)] (define (literals-pat p) (match p - [(PSymb s) (list s)] - [(PStr s) (list s)] - [(PBox p) (literals-pat p)] - [(PCons p1 p2) (append (literals-pat p1) (literals-pat p2))] - [(PAnd p1 p2) (append (literals-pat p1) (literals-pat p2))] + [(Lit d) (literals-datum d)] + [(Box p) (literals-pat p)] + [(Cons p1 p2) (append (literals-pat p1) (literals-pat p2))] + [(Conj p1 p2) (append (literals-pat p1) (literals-pat p2))] [_ '()])) -;; [Listof Char] -> Asm -(define (compile-string-chars cs) - (match cs - ['() (seq)] - [(cons c cs) - (seq (Dd (char->integer c)) - (compile-string-chars cs))])) diff --git a/mug/syntax/parse.rkt b/mug/syntax/parse.rkt new file mode 100644 index 0000000..4025e4a --- /dev/null +++ b/mug/syntax/parse.rkt @@ -0,0 +1,272 @@ +#lang racket +(provide parse parse-closed parse-e parse-define parse-pattern) +(require "ast.rkt") + +;; [Listof S-Expr] -> Prog +(define (parse . ss) + (match (parse-prog ss (parse-defn-names ss) '()) + [(list _ p) p])) + +;; [Listof S-Expr] -> ClosedProg +(define (parse-closed . ss) + (match (parse-prog ss (parse-defn-names ss) '()) + [(list '() p) p] + [(list ys p) (error "undefined identifiers" ys)])) + +;; S-Expr -> Expr +;; Parse a (potentially open) expression +(define (parse-e s) + (match (parse-e/acc s '() '()) + [(list _ e) e])) + +;; S-Expr -> Expr +;; Parse a (potentially open) definition +(define (parse-define s) + (match (parse-define/acc s '() '()) + [(list _ d) d])) + +;; S-Expr -> Pat +;; Parse a (potentially open) pattern +(define (parse-pattern s) + (match (parse-match-pattern/acc s '() '()) + [(list _ _ p) p])) + +;; S-Expr -> r:[Listof Id] +;; where: (distinct? r) +;; Extracts defined function names from given program-like s-expr +;; Does not fully parse definition +;; Example: +;; (parse-defn-names '((define (f x) x) (define (g y) y) 1) -> '(f g) +(define (parse-defn-names ss) + (define (rec ss fs) + (match ss + [(list s) fs] + [(cons (cons (? (not-in fs) 'define) sd) sr) + (match (parse-defn-name sd) + [f (if (memq f fs) + (error "duplicate definition" f) + (rec sr (cons f fs)))])] + [_ (error "parse error")])) + (rec ss '())) + +(define (parse-defn-name s) + (match s + [(cons (cons (? symbol? f) _) _) f] + [_ (error "parse error")])) +;; S-Expr [Listof Id] [Listof Id] -> (list [Listof Id] Prog) +;; s: program shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of program +(define (parse-prog s xs ys) + (match s + [(list s) + (match (parse-e/acc s xs ys) + [(list ys e) + (list ys (Prog '() e))])] + [(cons s ss) + (match (parse-define/acc s xs ys) + [(list ys (and d (Defn f _ _))) + (match (parse-prog ss xs ys) + [(list ys (Prog ds e)) + (list ys (Prog (cons d ds) e))])])])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] Defn) +;; s: definition shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of definition +(define (parse-define/acc s xs ys) + (match s + [(cons 'define sr) + (match sr + [(list (cons (? symbol? g) (and (list (? symbol? zs) ...) (? distinct?))) s) + (match (parse-e/acc s (cons g (append zs xs)) ys) + [(list ys e) + (list ys (Defn g zs e))])] + [_ (error "parse error")])] + [_ (error "parse error")])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] Expr) +;; s: expression shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of expression +(define (parse-e/acc s xs ys) + (define (rec s xs ys) + (define ns xs) + (match s + [(and 'eof (? (not-in ns))) + (list ys (Eof))] + [(? datum?) + (list ys (Lit s))] + [(list (and 'quote (? (not-in ns))) (list)) + (list ys (Lit '()))] + [(list (and 'quote (? (not-in ns))) (? symbol? s)) + (list ys (Lit s))] + [(? symbol? f) + (if (memq s xs) + (list ys (Var s)) + (list (cons s ys) (Var s)))] + [(list-rest (? symbol? (? (not-in ns) k)) sr) + (match k + ['let + (match sr + [(list (list (list (? symbol? x) s1)) s2) + (match (rec s1 xs ys) + [(list ys e1) + (match (rec s2 (cons x xs) ys) + [(list ys e2) + (list ys (Let x e1 e2))])])] + [_ (error "let: bad syntax" s)])] + ['match + (match sr + [(cons s sr) + (match (rec s xs ys) + [(list ys e) + (match (parse-match-clauses/acc sr xs ys) + [(list ys ps es) + (list ys (Match e ps es))])])] + [_ (error "match: bad syntax" s)])] + + [(or 'λ 'lambda) + (match sr + [(list (and (list (? symbol? zs) ...) (? distinct?)) s) + (match (rec s (append zs xs) ys) + [(list ys e) + (list ys (Lam (gensym 'lambda) zs e))])] + [_ (error "lambda: bad syntax" s)])] + [_ + (match (parse-es/acc sr xs ys) + [(list ys es) + (match (cons k es) + [(list (? op0? o)) + (list ys (Prim0 o))] + [(list (? op1? o) e1) + (list ys (Prim1 o e1))] + [(list (? op2? o) e1 e2) + (list ys (Prim2 o e1 e2))] + [(list (? op3? o) e1 e2 e3) + (list ys (Prim3 o e1 e2 e3))] + [(list 'begin e1 e2) + (list ys (Begin e1 e2))] + [(list 'if e1 e2 e3) + (list ys (If e1 e2 e3))] + [(list-rest g es) + (list (cons g ys) (App (Var g) es))])])])] + [(cons s sr) + (match (parse-e/acc s xs ys) + [(list ys e) + (match (parse-es/acc sr xs ys) + [(list ys es) + (list ys (App e es))])])] + [_ + (error "parse error" s)])) + (rec s xs ys)) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Expr]) +;; s: list of expressions shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and parse of expressions +(define (parse-es/acc s xs ys) + (match s + ['() (list ys '())] + [(cons s ss) + (match (parse-e/acc s xs ys) + [(list ys e) + (match (parse-es/acc ss xs ys) + [(list ys es) + (list ys (cons e es))])])] + [_ (error "parse error")])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Expr]) +;; s: list of match clauses shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables and list of parsed clause patterns and clause expressions +(define (parse-match-clauses/acc sr xs ys) + (match sr + ['() (list ys '() '())] + [(cons (list sp se) sr) + (match (parse-match-pattern/acc sp xs ys) + [(list ys xs p) + (match (parse-e/acc se xs ys) + [(list ys e) + (match (parse-match-clauses/acc sr xs ys) + [(list ys ps es) + (list ys (cons p ps) (cons e es))])])])])) +;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Pat) +;; s: list of patterns shaped s-expr to be parsed +;; xs: bound variables +;; ys: free variables +;; returns list of free variables, bound variables, and parse of pattern +(define (parse-match-pattern/acc s xs ys) + (define (rec p xs ys) + (match p + [(? self-quoting-datum?) (list ys xs (Lit p))] + ['_ (list ys xs (Var '_))] + [(? symbol?) (list ys (cons p xs) (Var p))] + [(list 'quote '()) + (list ys xs (Lit '()))] + [(list 'quote (? symbol? s)) + (list ys xs (Lit s))] + [(list 'quote (? datum? d)) + (list ys xs (Lit d))] + [(list 'box s) + (match (rec s xs ys) + [(list ys xs p) + (list ys xs (Box p))])] + [(list 'cons s1 s2) + (match (rec s1 xs ys) + [(list ys xs p1) + (match (rec s2 xs ys) + [(list ys xs p2) + (list ys xs (Cons p1 p2))])])] + [(list 'and s1 s2) + (match (rec s1 xs ys) + [(list ys xs p1) + (match (rec s2 xs ys) + [(list ys xs p2) + (list ys xs (Conj p1 p2))])])] + [_ (error "parse pattern error")])) + (rec s xs ys)) + +;; [Listof Any] -> Boolean +(define (distinct? xs) + (not (check-duplicates xs))) + +;; xs:[Listof Any] -> p:(x:Any -> Boolean) +;; Produce a predicate p for things not in xs +(define (not-in xs) + (λ (x) (not (memq x xs)))) +(define (in m) + (λ (x) (memq x m))) + +;; Any -> Boolean +(define (self-quoting-datum? x) + (or (exact-integer? x) + (boolean? x) + (char? x) + (string? x))) + +;; Any -> Boolean +(define (datum? x) + (or (self-quoting-datum? x) + (empty? x))) + +;; Any -> Boolean +(define (op0? x) + (memq x '(read-byte peek-byte void))) + +(define (op1? x) + (memq x '(add1 sub1 zero? + char? integer->char char->integer + write-byte eof-object? + box unbox empty? cons? box? car cdr + vector? vector-length string? string-length + symbol? symbol->string string->symbol string->uninterned-symbol))) + +(define (op2? x) + (memq x '(+ - < = eq? cons + make-vector vector-ref make-string string-ref))) + +(define (op3? x) + (memq x '(vector-set!))) + diff --git a/mug/read-all.rkt b/mug/syntax/read-all.rkt similarity index 99% rename from mug/read-all.rkt rename to mug/syntax/read-all.rkt index 8a3289a..a83fe69 100644 --- a/mug/read-all.rkt +++ b/mug/syntax/read-all.rkt @@ -6,3 +6,4 @@ (if (eof-object? r) '() (cons r (read-all))))) + diff --git a/mug/test/build-runtime.rkt b/mug/test/build-runtime.rkt deleted file mode 100644 index 7023ee0..0000000 --- a/mug/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/mug/test/compile.rkt b/mug/test/compile.rkt deleted file mode 100644 index ee289de..0000000 --- a/mug/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../run.rkt") - -(test-runner (λ p (run (compile (parse p))))) -(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/mug/test/define-tests.rkt b/mug/test/define-tests.rkt new file mode 100644 index 0000000..edfbc7b --- /dev/null +++ b/mug/test/define-tests.rkt @@ -0,0 +1,420 @@ +#lang racket +(provide test test/io) +(require rackunit) + +(define (test run) + (begin ;; Abscond + (check-equal? (run 7) 7) + (check-equal? (run -8) -8)) + + (begin ;; Blackmail + (check-equal? (run '(add1 (add1 7))) 9) + (check-equal? (run '(add1 (sub1 7))) 7)) + + (begin ;; Con + (check-equal? (run '(if (zero? 0) 1 2)) 1) + (check-equal? (run '(if (zero? 1) 1 2)) 2) + (check-equal? (run '(if (zero? -7) 1 2)) 2) + (check-equal? (run '(if (zero? 0) + (if (zero? 1) 1 2) + 7)) + 2) + (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) + (if (zero? 1) 1 2) + 7)) + 7)) + + (begin ;; Dupe + (check-equal? (run #t) #t) + (check-equal? (run #f) #f) + (check-equal? (run '(if #t 1 2)) 1) + (check-equal? (run '(if #f 1 2)) 2) + (check-equal? (run '(if 0 1 2)) 1) + (check-equal? (run '(if #t 3 4)) 3) + (check-equal? (run '(if #f 3 4)) 4) + (check-equal? (run '(if 0 3 4)) 3) + (check-equal? (run '(zero? 4)) #f) + (check-equal? (run '(zero? 0)) #t)) + + (begin ;; Dodger + (check-equal? (run #\a) #\a) + (check-equal? (run #\b) #\b) + (check-equal? (run '(char? #\a)) #t) + (check-equal? (run '(char? #t)) #f) + (check-equal? (run '(char? 8)) #f) + (check-equal? (run '(char->integer #\a)) (char->integer #\a)) + (check-equal? (run '(integer->char 955)) #\λ)) + + (begin ;; Evildoer + (check-equal? (run '(void)) (void)) + (check-equal? (run '(begin 1 2)) 2) + (check-equal? (run '(eof-object? (void))) #f)) + + (begin ;; Extort + (check-equal? (run '(add1 #f)) 'err) + (check-equal? (run '(sub1 #f)) 'err) + (check-equal? (run '(zero? #f)) 'err) + (check-equal? (run '(char->integer #f)) 'err) + (check-equal? (run '(integer->char #f)) 'err) + (check-equal? (run '(integer->char -1)) 'err) + (check-equal? (run '(write-byte #f)) 'err) + (check-equal? (run '(write-byte -1)) 'err) + (check-equal? (run '(write-byte 256)) 'err) + (check-equal? (run '(begin (integer->char 97) + (integer->char 98))) + #\b)) + + (begin ;; Fraud + (check-equal? (run '(let ((x 7)) x)) 7) + (check-equal? (run '(let ((x 7)) 2)) 2) + (check-equal? (run '(let ((x 7)) (add1 x))) 8) + (check-equal? (run '(let ((x (add1 7))) x)) 8) + (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) + (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) + (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) + + (check-equal? (run '(let ((x 0)) + (if (zero? x) 7 8))) + 7) + (check-equal? (run '(let ((x 1)) + (add1 (if (zero? x) 7 8)))) + 9) + (check-equal? (run '(+ 3 4)) 7) + (check-equal? (run '(- 3 4)) -1) + (check-equal? (run '(+ (+ 2 1) 4)) 7) + (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) + (check-equal? (run '(let ((x (+ 1 2))) + (let ((z (- 4 x))) + (+ (+ x x) z)))) + 7) + + (check-equal? (run '(= 5 5)) #t) + (check-equal? (run '(= 4 5)) #f) + (check-equal? (run '(= (add1 4) 5)) #t) + (check-equal? (run '(< 5 5)) #f) + (check-equal? (run '(< 4 5)) #t) + (check-equal? (run '(< (add1 4) 5)) #f)) + + (begin ;; Hustle + (check-equal? (run '(empty? (cons 1 2))) #f) + (check-equal? (run '(box 1)) (box 1)) + (check-equal? (run '(box -1)) (box -1)) + (check-equal? (run '(cons 1 2)) (cons 1 2)) + (check-equal? (run '(unbox (box 1))) 1) + (check-equal? (run '(car (cons 1 2))) 1) + (check-equal? (run '(cdr (cons 1 2))) 2) + (check-equal? (run '(cons 1 '())) (list 1)) + (check-equal? (run '(let ((x (cons 1 2))) + (begin (cdr x) + (car x)))) + 1) + (check-equal? (run '(let ((x (cons 1 2))) + (let ((y (box 3))) + (unbox y)))) + 3) + (check-equal? (run '(eq? 1 1)) #t) + (check-equal? (run '(eq? 1 2)) #f) + (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) + (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t)) + + (begin ;; Hoax + (check-equal? (run '(make-vector 0 0)) #()) + (check-equal? (run '(make-vector 1 0)) #(0)) + (check-equal? (run '(make-vector 3 0)) #(0 0 0)) + (check-equal? (run '(make-vector 3 5)) #(5 5 5)) + (check-equal? (run '(vector? (make-vector 0 0))) #t) + (check-equal? (run '(vector? (cons 0 0))) #f) + (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) + (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) + (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) + (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 0 4) + x))) + #(4 5 5)) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 1 4) + x))) + #(5 4 5)) + (check-equal? (run '(let ((x (make-vector 3 5))) + (begin (vector-set! x 3 4) + x))) + 'err) + (check-equal? (run '(vector-length (make-vector 3 #f))) 3) + (check-equal? (run '(vector-length (make-vector 0 #f))) 0) + (check-equal? (run '"") "") + (check-equal? (run '"fred") "fred") + (check-equal? (run '"wilma") "wilma") + (check-equal? (run '(make-string 0 #t)) 'err) + (check-equal? (run '(make-string 0 #\f)) "") + (check-equal? (run '(make-string 3 #\f)) "fff") + (check-equal? (run '(make-string 3 #\g)) "ggg") + (check-equal? (run '(string-length "")) 0) + (check-equal? (run '(string-length "fred")) 4) + (check-equal? (run '(string-ref "" 0)) 'err) + (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) + (check-equal? (run '(string-ref "fred" 0)) #\f) + (check-equal? (run '(string-ref "fred" 1)) #\r) + (check-equal? (run '(string-ref "fred" 2)) #\e) + (check-equal? (run '(string-ref "fred" 4)) 'err) + (check-equal? (run '(string? "fred")) #t) + (check-equal? (run '(string? (cons 1 2))) #f) + (check-equal? (run '(begin (make-string 3 #\f) + (make-string 3 #\f))) + "fff") + (check-equal? (run '(vector-set! (make-vector 0 #f) 0 #t)) 'err)) + + (begin ;; Iniquity + (check-equal? (run + '(define (f x) x) + '(f 5)) + 5) + (check-equal? (run + '(define (tri x) + (if (zero? x) + 0 + (+ x (tri (sub1 x))))) + '(tri 9)) + 45) + + (check-equal? (run + '(define (even? x) + (if (zero? x) + #t + (odd? (sub1 x)))) + '(define (odd? x) + (if (zero? x) + #f + (even? (sub1 x)))) + '(even? 101)) + #f) + + (check-equal? (run + '(define (map-add1 xs) + (if (empty? xs) + '() + (cons (add1 (car xs)) + (map-add1 (cdr xs))))) + '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) + '(2 3 4)) + (check-equal? (run '(define (f x y) y) + '(f 1 (add1 #f))) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1)) + 'err) + (check-equal? (run '(define (f x y) y) + '(f 1 2 3)) + 'err)) + + (begin ;; Knock + (check-equal? (run '(match 1)) 'err) + (check-equal? (run '(match 1 [1 2])) + 2) + (check-equal? (run '(match 1 [2 1] [1 2])) + 2) + (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) + 2) + (check-equal? (run '(match 1 [2 1] [0 3])) + 'err) + (check-equal? (run '(match 1 [_ 2] [_ 3])) + 2) + (check-equal? (run '(match 1 [x 2] [_ 3])) + 2) + (check-equal? (run '(match 1 [x x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) + (cons 1 2)) + (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) + 1) + (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) + 3) + (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) + 3) + (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) + 2) + (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) + 0) + (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) + 1) + (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) + 1) + (check-equal? (run '(match 1 [8589934592 1] [_ 2])) 2) + (check-equal? (run '(match 8589934592 [8589934592 1] [_ 2])) 1)) + + (begin ;; Loot + (check-true (procedure? (run '(λ (x) x)))) + (check-equal? (run '((λ (x) x) 5)) + 5) + + (check-equal? (run '(let ((f (λ (x) x))) (f 5))) + 5) + (check-equal? (run '(let ((f (λ (x y) x))) (f 5 7))) + 5) + (check-equal? (run '(let ((f (λ (x y) y))) (f 5 7))) + 7) + (check-equal? (run '((let ((x 1)) + (let ((y 2)) + (lambda (z) (cons x (cons y (cons z '())))))) + 3)) + '(1 2 3)) + (check-equal? (run '(define (adder n) + (λ (x) (+ x n))) + '((adder 5) 10)) + 15) + (check-equal? (run '(((λ (t) + ((λ (f) (t (λ (z) ((f f) z)))) + (λ (f) (t (λ (z) ((f f) z)))))) + (λ (tri) + (λ (n) + (if (zero? n) + 0 + (+ n (tri (sub1 n))))))) + 36)) + 666) + (check-equal? (run '(define (tri n) + (if (zero? n) + 0 + (+ n (tri (sub1 n))))) + '(tri 36)) + 666) + (check-equal? (run '(define (tri n) + (match n + [0 0] + [m (+ m (tri (sub1 m)))])) + '(tri 36)) + 666) + (check-equal? (run '((match 8 [8 (lambda (x) x)]) 12)) + 12)) + + (begin ;; Mug + (check-equal? (run '(symbol? 'foo)) #t) + (check-equal? (run '(symbol? (string->symbol "foo"))) #t) + (check-equal? (run '(eq? 'foo 'foo)) #t) + (check-equal? (run '(eq? (string->symbol "foo") + (string->symbol "foo"))) + #t) + (check-equal? (run '(eq? 'foo (string->symbol "foo"))) + #t) + (check-equal? (run '(eq? 'fff (string->symbol (make-string 3 #\f)))) + #t) + (check-equal? (run '(symbol? 'g0)) #t) + (check-equal? (run '(symbol? "g0")) #f) + (check-equal? (run '(symbol? (string->symbol "g0"))) #t) + (check-equal? (run '(symbol? (string->uninterned-symbol "g0"))) #t) + (check-equal? (run '(eq? 'g0 (string->symbol "g0"))) #t) + (check-equal? (run '(eq? 'g0 (string->uninterned-symbol "g0"))) #f) + (check-equal? (run '(eq? (string->uninterned-symbol "g0") (string->uninterned-symbol "g0"))) + #f) + (check-equal? (run '(eq? (symbol->string 'foo) (symbol->string 'foo))) #f) + (check-equal? (run '(string? (symbol->string 'foo))) #t) + (check-equal? (run '(eq? (symbol->string 'foo) "foo")) #f) + (check-equal? (run ''foo) 'foo) + (check-equal? (run '(eq? (match #t [_ "foo"]) "bar")) #f) + (check-equal? (run '(eq? (match #t [_ 'foo]) 'bar)) #f) + (check-equal? (run '(match 'foo ['bar #t] [_ #f])) #f) + (check-equal? (run '(match 'foo ['foo #t] [_ #f])) #t) + (check-equal? (run '(match "foo" ["foo" #t] [_ #f])) #t) + (check-equal? (run '(match "foo" ["bar" #t] [_ #f])) #f) + (check-equal? (run '(match (cons '+ (cons 1 (cons 2 '()))) + [(cons '+ (cons x (cons y '()))) + (+ x y)])) + 3))) + +(define (test/io run) + (begin ;; Evildoer + (check-equal? (run "" 7) (cons 7 "")) + (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) + (check-equal? (run "a" '(read-byte)) (cons 97 "")) + (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) + (cons 98 "a")) + (check-equal? (run "" '(read-byte)) (cons eof "")) + (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) + (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) + (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) + (cons (void) "ab")) + + (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) + (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) + (check-equal? (run "†" '(read-byte)) (cons 226 "")) + (check-equal? (run "†" '(peek-byte)) (cons 226 ""))) + + (begin ;; Extort + (check-equal? (run "" '(write-byte #t)) (cons 'err ""))) + + (begin ;; Fraud + (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) + (check-equal? (run "" + '(let ((x 97)) + (begin (write-byte x) + x))) + (cons 97 "a")) + (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) + (cons 97 "")) + (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) + (cons 97 ""))) + + (begin ;; Iniquity + (check-equal? (run "" + '(define (print-alphabet i) + (if (zero? i) + (void) + (begin (write-byte (- 123 i)) + (print-alphabet (sub1 i))))) + '(print-alphabet 26)) + (cons (void) "abcdefghijklmnopqrstuvwxyz")) + + (check-equal? (run "" + '(define (f x) + (write-byte x)) + '(f 97)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (write-byte x)) + '(f 97 98)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x) + (let ((y x)) + (write-byte y))) + '(f 97)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (let ((y x)) + (write-byte y))) + '(f 97 98)) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x) + (write-byte x)) + '(let ((z 97)) + (f z))) + (cons (void) "a")) + (check-equal? (run "" + '(define (f x y) + (write-byte x)) + '(let ((z 97)) + (f z 98))) + (cons (void) "a"))) + + (begin ;; Knock + (check-equal? (run "" + '(match (write-byte 97) + [_ 1])) + (cons 1 "a"))) + + (begin ;; Loot + (check-equal? (run "" + '((begin (write-byte 97) + (λ (x) + (begin (write-byte x) + (write-byte 99)))) + 98)) + (cons (void) "abc")))) + diff --git a/mug/test/interp-defun.rkt b/mug/test/interp-defun.rkt deleted file mode 100644 index 68ef419..0000000 --- a/mug/test/interp-defun.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp-defun.rkt" - "../interp-io.rkt") - -(define (closure->proc xs e r) - ;; Could make this better by calling the interpreter, - ;; but it's only used in tests where all we care about - ;; is that you get a procedure. - (lambda _ - (error "This function is not callable."))) - -(test-runner - (λ p - (match (interp (parse p)) - [(Closure xs e r) (closure->proc xs e r)] - [v v]))) -(test-runner-io - (λ (s . p) - (match (interp/io (parse p) s) - [(cons (Closure xs e r) o) - (cons (closure->proc xs e r) o)] - [r r]))) diff --git a/mug/test/interp.rkt b/mug/test/interp.rkt deleted file mode 100644 index cd7b654..0000000 --- a/mug/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/mug/test/run-compile-tests.rkt b/mug/test/run-compile-tests.rkt new file mode 100644 index 0000000..2cf66fd --- /dev/null +++ b/mug/test/run-compile-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../compiler/compile.rkt") +(require "../syntax/parse.rkt") +(require "../executor/run.rkt") +(require "define-tests.rkt") +(test (λ p (run (compile (apply parse-closed p))))) +(test/io (λ (in . p) (run/io (compile (apply parse-closed p)) in))) + diff --git a/mug/test/run-interp-tests.rkt b/mug/test/run-interp-tests.rkt new file mode 100644 index 0000000..96137ef --- /dev/null +++ b/mug/test/run-interp-tests.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../interpreter/interp.rkt") +(require "../interpreter/interp-io.rkt") +(require "../syntax/parse.rkt") +(require "define-tests.rkt") +(test (λ p (interp (apply parse-closed p)))) +(test/io (λ (in . p) (interp/io (apply parse-closed p) in))) + diff --git a/mug/test/run-parse-tests.rkt b/mug/test/run-parse-tests.rkt new file mode 100644 index 0000000..e03cb56 --- /dev/null +++ b/mug/test/run-parse-tests.rkt @@ -0,0 +1,89 @@ +#lang racket +(require "../syntax/parse.rkt") +(require "../syntax/ast.rkt") +(require rackunit) + +(define (p e) + (Prog '() e)) + +(begin ; Abscond + (check-equal? (parse 42) (p (Lit 42))) + (check-equal? (parse -1) (p (Lit -1)))) +(begin ; Blackmail + (check-equal? (parse '(add1 42)) (p (Prim1 'add1 (Lit 42))))) +(begin ; Dupe + (check-equal? (parse '(if (zero? 1) 2 3)) + (p (If (Prim1 'zero? (Lit 1)) (Lit 2) (Lit 3)))) + (check-equal? (parse '(if #t 2 3)) + (p (If (Lit #t) (Lit 2) (Lit 3))))) +(begin ; Dodger + (check-equal? (parse #\a) (p (Lit #\a))) + (check-equal? (parse '(char->integer #\a)) + (p (Prim1 'char->integer (Lit #\a))))) +(begin ; Evildoer + (check-equal? (parse 'eof) (p (Eof))) + (check-equal? (parse '(void)) (p (Prim0 'void))) + (check-equal? (parse '(read-byte)) (p (Prim0 'read-byte)))) +(begin ; Fraud + (check-equal? (parse 'x) (p (Var 'x))) + (check-exn exn:fail? (λ () (parse-closed 'x))) + (check-equal? (parse '(+ 1 2)) + (p (Prim2 '+ (Lit 1) (Lit 2)))) + (check-equal? (parse '(let ((x 1)) x)) + (p (Let 'x (Lit 1) (Var 'x)))) + (check-equal? (parse-closed '(let ((x 1)) x)) + (p (Let 'x (Lit 1) (Var 'x)))) + (check-equal? (parse 'add1) (p (Var 'add1))) + (check-exn exn:fail? (λ () (parse-closed 'add1))) + (check-equal? (parse '(let ((let 1)) let)) + (p (Let 'let (Lit 1) (Var 'let)))) + (check-equal? (parse '(let ((if 1)) if)) + (p (Let 'if (Lit 1) (Var 'if))))) +(begin ; Hustle + (check-equal? (parse ''()) (p (Lit '()))) + (check-equal? (parse '(box 1)) (p (Prim1 'box (Lit 1)))) + (check-equal? (parse '(cons 1 2)) (p (Prim2 'cons (Lit 1) (Lit 2))))) +(begin ; Hoax + (check-equal? (parse "asdf") (p (Lit "asdf"))) + (check-equal? (parse '(make-string 10 #\a)) + (p (Prim2 'make-string (Lit 10) (Lit #\a))))) + +(begin ; Iniquity + (check-equal? (parse '(define (f x) x) 1) + (Prog (list (Defn 'f '(x) (Var 'x))) (Lit 1))) + (check-equal? (parse '(define (define) 0) '(define)) + (Prog (list (Defn 'define '() (Lit 0))) + (App (Var 'define) '()))) + (check-exn exn:fail? (λ () (parse '(define (f y y) y) 1))) + (check-equal? (parse-closed '(define (f x) (g x)) + '(define (g x) (f x)) + '(f 0)) + (Prog (list (Defn 'f '(x) (App (Var 'g) (list (Var 'x)))) + (Defn 'g '(x) (App (Var 'f) (list (Var 'x))))) + (App (Var 'f) (list (Lit 0)))))) +(begin ; Knock + (check-equal? (parse '(match 1)) + (p (Match (Lit 1) '() '()))) + (check-equal? (parse '(match 1 [_ #t])) + (p (Match (Lit 1) (list (Var '_)) (list (Lit #t))))) + (check-equal? (parse '(match 1 [x x])) + (p (Match (Lit 1) (list (Var 'x)) (list (Var 'x))))) + (check-equal? (parse-closed '(match 1 [x x])) + (p (Match (Lit 1) (list (Var 'x)) (list (Var 'x))))) + (check-equal? (parse '(match 1 [x y])) + (p (Match (Lit 1) (list (Var 'x)) (list (Var 'y))))) + (check-equal? (parse '(match x ['() 1])) + (p (Match (Var 'x) (list (Lit '())) (list (Lit 1))))) + (check-exn exn:fail? (λ () (parse-closed '(match 1 [x y]))))) + +(begin ; Loot + (check-equal? (parse '(f x)) + (p (App (Var 'f) (list (Var 'x)))))) + +(begin ; Mug + (check-equal? (parse ''x) + (p (Lit 'x))) + (check-equal? (parse '(let ((quote 1)) + 'x)) + (p (Let 'quote (Lit 1) (App (Var 'quote) (list (Var 'x))))))) + diff --git a/mug/test/test-runner.rkt b/mug/test/test-runner.rkt deleted file mode 100644 index d4d68ed..0000000 --- a/mug/test/test-runner.rkt +++ /dev/null @@ -1,389 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (f x) x) - '(define (g x) (f x)) - '(g 5)) - 5) - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run - '(define (f x) - 10) - '(f 1)) - 10) - (check-equal? (run - '(define (f x) - 10) - '(let ((x 2)) (f 1))) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(f 1 2)) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(let ((z 2)) (f 1 2))) - 10) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err) - - ;; Knock examples - (check-equal? (run '(match 1)) 'err) - (check-equal? (run '(match 1 [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) - 2) - (check-equal? (run '(match 1 [2 1] [0 3])) - 'err) - (check-equal? (run '(match 1 [_ 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) - (cons 1 2)) - (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) - 3) - (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) - 3) - (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) - 2) - (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) - 0) - (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) - 1) - (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) - 1) - - ;; Loot examples - (check-true (procedure? (run '(λ (x) x)))) - (check-equal? (run '((λ (x) x) 5)) - 5) - - (check-equal? (run '(let ((f (λ (x) x))) (f 5))) - 5) - (check-equal? (run '(let ((f (λ (x y) x))) (f 5 7))) - 5) - (check-equal? (run '(let ((f (λ (x y) y))) (f 5 7))) - 7) - (check-equal? (run '((let ((x 1)) - (let ((y 2)) - (lambda (z) (cons x (cons y (cons z '())))))) - 3)) - '(1 2 3)) - (check-equal? (run '(define (adder n) - (λ (x) (+ x n))) - '((adder 5) 10)) - 15) - (check-equal? (run '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36)) - 666) - (check-equal? (run '(define (tri n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))) - '(tri 36)) - 666) - (check-equal? (run '(define (tri n) - (match n - [0 0] - [m (+ m (tri (sub1 m)))])) - '(tri 36)) - 666) - (check-equal? (run '((match 8 [8 (lambda (x) x)]) 12)) - 12) - - ;; Mug examples - (check-equal? (run '(symbol? 'foo)) #t) - (check-equal? (run '(symbol? (string->symbol "foo"))) #t) - (check-equal? (run '(eq? 'foo 'foo)) #t) - (check-equal? (run '(eq? (string->symbol "foo") - (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'foo (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'fff (string->symbol (make-string 3 #\f)))) - #t) - (check-equal? (run '(symbol? 'g0)) #t) - (check-equal? (run '(symbol? "g0")) #f) - (check-equal? (run '(symbol? (string->symbol "g0"))) #t) - (check-equal? (run '(symbol? (string->uninterned-symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->uninterned-symbol "g0"))) #f) - (check-equal? (run '(eq? (string->uninterned-symbol "g0") (string->uninterned-symbol "g0"))) - #f) - (check-equal? (run '(eq? (symbol->string 'foo) (symbol->string 'foo))) #f) - (check-equal? (run '(string? (symbol->string 'foo))) #t) - (check-equal? (run '(eq? (symbol->string 'foo) "foo")) #f) - (check-equal? (run ''foo) 'foo) - (check-equal? (run '(eq? (match #t [_ "foo"]) "bar")) #f) - (check-equal? (run '(eq? (match #t [_ 'foo]) 'bar)) #f) - (check-equal? (run '(match 'foo ['bar #t] [_ #f])) #f) - (check-equal? (run '(match 'foo ['foo #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["foo" #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["bar" #t] [_ #f])) #f) - (check-equal? (run '(match (cons '+ (cons 1 (cons 2 '()))) - [(cons '+ (cons x (cons y '()))) - (+ x y)])) - 3)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - #| - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz")) -|#) diff --git a/mug/types.rkt b/mug/types.rkt deleted file mode 100644 index 1bb4f59..0000000 --- a/mug/types.rkt +++ /dev/null @@ -1,108 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require ffi/unsafe) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define type-proc #b101) -(define type-symb #b110) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) - -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (heap-ref b)))] - [(cons-bits? b) - (cons (bits->value (heap-ref (+ b 8))) - (bits->value (heap-ref b)))] - [(vect-bits? b) - (if (zero? (untag b)) - (vector) - (build-vector (heap-ref b) - (lambda (j) - (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] - [(str-bits? b) - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j))))] - [(symb-bits? b) - (string->symbol - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j)))))] - [(proc-bits? b) - (lambda _ - (error "This function is not callable."))] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eq? v #t) #b00011000] - [(eq? v #f) #b00111000] - [(eof-object? v) #b01011000] - [(void? v) #b01111000] - [(empty? v) #b10011000] - [(integer? v) - (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [else (error "not an immediate value")])) - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (= type-int (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (= type-cons (bitwise-and v imm-mask))) - -(define (box-bits? v) - (= type-box (bitwise-and v imm-mask))) - -(define (vect-bits? v) - (= type-vect (bitwise-and v imm-mask))) - -(define (str-bits? v) - (= type-str (bitwise-and v imm-mask))) - -(define (proc-bits? v) - (= type-proc (bitwise-and v imm-mask))) - -(define (symb-bits? v) - (= type-symb (bitwise-and v imm-mask))) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/mug/utils.rkt b/mug/utils.rkt deleted file mode 100644 index 612b738..0000000 --- a/mug/utils.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang racket -(provide symbol->data-label lookup pad-stack unpad-stack) -(require a86/ast) - -(define rsp 'rsp) -(define r15 'r15) - -(define (symbol->data-label s) - (symbol->label - (string->symbol (string-append "data_" (symbol->string s))))) - -;; Id CEnv -> [Maybe Integer] -(define (lookup x cenv) - (match cenv - ['() #f] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (match (lookup x rest) - [#f #f] - [i (+ 8 i)])])])) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/mug/values.h b/mug/values.h deleted file mode 100644 index c1de09d..0000000 --- a/mug/values.h +++ /dev/null @@ -1,84 +0,0 @@ -#ifndef VALUES_H -#define VALUES_H - -#include - -/* any abstract value */ -typedef int64_t val_t; - -typedef enum type_t { - T_INVALID = -1, - /* immediates */ - T_INT, - T_BOOL, - T_CHAR, - T_EOF, - T_VOID, - T_EMPTY, - /* pointers */ - T_BOX, - T_CONS, - T_VECT, - T_STR, - T_SYMB, - T_PROC, -} type_t; - -typedef uint32_t val_char_t; -typedef struct val_box_t { - val_t val; -} val_box_t; -typedef struct val_cons_t { - val_t snd; - val_t fst; -} val_cons_t; -typedef struct val_vect_t { - uint64_t len; - val_t elems[]; -} val_vect_t; -typedef struct val_str_t { - uint64_t len; - val_char_t codepoints[]; -} val_str_t; -typedef struct val_symb_t { - uint64_t len; - val_char_t codepoints[]; -} val_symb_t; - -/* return the type of x */ -type_t val_typeof(val_t x); - -/** - * Wrap/unwrap values - * - * The behavior of unwrap functions are undefined on type mismatch. - */ -int64_t val_unwrap_int(val_t x); -val_t val_wrap_int(int64_t i); - -int val_unwrap_bool(val_t x); -val_t val_wrap_bool(int b); - -val_char_t val_unwrap_char(val_t x); -val_t val_wrap_char(val_char_t b); - -val_t val_wrap_eof(); - -val_t val_wrap_void(); - -val_box_t* val_unwrap_box(val_t x); -val_t val_wrap_box(val_box_t* b); - -val_cons_t* val_unwrap_cons(val_t x); -val_t val_wrap_cons(val_cons_t* c); - -val_vect_t* val_unwrap_vect(val_t x); -val_t val_wrap_vect(val_vect_t* c); - -val_str_t* val_unwrap_str(val_t x); -val_t val_wrap_str(val_str_t* c); - -val_symb_t* val_unwrap_symb(val_t x); -val_t val_wrap_symb(val_symb_t* c); - -#endif diff --git a/neerdowell/Makefile b/neerdowell/Makefile index 3fc9599..74eaae1 100644 --- a/neerdowell/Makefile +++ b/neerdowell/Makefile @@ -1,38 +1,38 @@ ifeq ($(shell uname), Darwin) - LANGS_CC ?= arch -x86_64 clang + LANGS_CC ?= arch -x86_64 clang -### -fuse-ld=lld LANGS_AS ?= arch -x86_64 clang -c else - LANGS_CC ?= clang + LANGS_CC ?= clang -fuse-ld=lld LANGS_AS ?= clang -c endif -objs = \ - main.o \ - print.o \ - values.o \ - io.o \ - symbol.o +RACKET ?= racket -default: runtime.o +RUNTIME_DIR := runtime +RUNTIME := $(RUNTIME_DIR)/runtime.o -runtime.o: $(objs) - ld -r $(objs) -o runtime.o +# Example source extension for this language. +SRC_EXT := rkt -%.run: %.o runtime.o - $(LANGS_CC) runtime.o $< -o $@ +default: + @echo "example: make foo.run" -.c.o: - $(LANGS_CC) -fPIC -c -g -o $@ $< +# Build the runtime bundles if needed. +$(RUNTIME): + $(MAKE) -C $(RUNTIME_DIR) -.s.o: +# Compile source program to assembly. +%.s: %.$(SRC_EXT) + cat $< | $(RACKET) -t compiler/compile-stdin.rkt -m > $@ + +# Assemble to object. +%.o: %.s $(LANGS_AS) -o $@ $< -%.s: %.rkt - cat $< | racket -t compile-stdin.rkt -m > $@ +# Link standalone executable. +%.run: %.o $(RUNTIME) + $(LANGS_CC) -o $@ $^ clean: @$(RM) *.o *.s *.run ||: - @echo "$(shell basename $(shell pwd)): cleaned!" - -%.test: %.run %.rkt - @test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))" + @$(MAKE) -C $(RUNTIME_DIR) clean diff --git a/neerdowell/build-runtime.rkt b/neerdowell/build-runtime.rkt deleted file mode 100644 index 66aad89..0000000 --- a/neerdowell/build-runtime.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket -(require racket/runtime-path) -(provide runtime-path) - -(define-runtime-path here ".") - -(void - (system (string-append "make -C '" - (path->string (normalize-path here)) - "' runtime.o"))) - -(define runtime-path - (path->string - (normalize-path (build-path here "runtime.o")))) diff --git a/neerdowell/compile-define.rkt b/neerdowell/compile-define.rkt deleted file mode 100644 index a8a6992..0000000 --- a/neerdowell/compile-define.rkt +++ /dev/null @@ -1,72 +0,0 @@ -#lang racket -(provide compile-define compile-defines-values define-ids compile-defines) -(require "ast.rkt" - "types.rkt" - "fv.rkt" - "utils.rkt" - "compile-expr.rkt" - a86/ast) - -(define rax 'rax) -(define rbx 'rbx) - -;; [Listof Defn] -> [Listof Id] -(define (define-ids ds) - (match ds - ['() '()] - [(cons (Defn f xs e) ds) - (cons f (define-ids ds))])) - -;; [Listof Defn] -> Asm -(define (compile-defines ds) - (match ds - ['() (seq)] - [(cons d ds) - (seq (compile-define d) - (compile-defines ds))])) - -;; Defn -> Asm -(define (compile-define d) - (match d - [(Defn f xs e) - (compile-lambda-define (Lam f xs e))])) - -;; Defns -> Asm -;; Compile the closures for ds and push them on the stack -(define (compile-defines-values ds) - (seq (alloc-defines ds 0) - (init-defines ds (reverse (define-ids ds)) 8) - (add-rbx-defines ds 0))) - -;; Defns Int -> Asm -;; Allocate closures for ds at given offset, but don't write environment yet -(define (alloc-defines ds off) - (match ds - ['() (seq)] - [(cons (Defn f xs e) ds) - (let ((fvs (fv (Lam f xs e)))) - (seq (Lea rax (symbol->label f)) - (Mov (Mem rbx off) rax) - (Mov rax rbx) - (Add rax off) - (Or rax type-proc) - (Push rax) - (alloc-defines ds (+ off (* 8 (add1 (length fvs)))))))])) - -;; Defns CEnv Int -> Asm -;; Initialize the environment for each closure for ds at given offset -(define (init-defines ds c off) - (match ds - ['() (seq)] - [(cons (Defn f xs e) ds) - (let ((fvs (fv (Lam f xs e)))) - (seq (free-vars-to-heap fvs c off) - (init-defines ds c (+ off (* 8 (add1 (length fvs)))))))])) - -;; Defns Int -> Asm -;; Compute adjustment to rbx for allocation of all ds -(define (add-rbx-defines ds n) - (match ds - ['() (seq (Add rbx (* n 8)))] - [(cons (Defn f xs e) ds) - (add-rbx-defines ds (+ n (add1 (length (fv (Lam f xs e))))))])) diff --git a/neerdowell/compile-stdin.rkt b/neerdowell/compile-stdin.rkt deleted file mode 100644 index cfa1510..0000000 --- a/neerdowell/compile-stdin.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; -> Void -;; Compile contents of stdin, -;; emit asm code on stdout -(define (main) - (read-line) ; ignore #lang racket line - (asm-display (compile (parse (read-all))))) diff --git a/mountebank/compile-datum.rkt b/neerdowell/compiler/compile-datum.rkt similarity index 98% rename from mountebank/compile-datum.rkt rename to neerdowell/compiler/compile-datum.rkt index 9fe2720..a7ab58a 100644 --- a/mountebank/compile-datum.rkt +++ b/neerdowell/compiler/compile-datum.rkt @@ -1,6 +1,6 @@ #lang racket (provide compile-datum) -(require "types.rkt" +(require "../runtime/types.rkt" "utils.rkt" a86/ast) diff --git a/mountebank/compile-define.rkt b/neerdowell/compiler/compile-define.rkt similarity index 95% rename from mountebank/compile-define.rkt rename to neerdowell/compiler/compile-define.rkt index a8a6992..3b2c2d4 100644 --- a/mountebank/compile-define.rkt +++ b/neerdowell/compiler/compile-define.rkt @@ -1,8 +1,8 @@ #lang racket (provide compile-define compile-defines-values define-ids compile-defines) -(require "ast.rkt" - "types.rkt" - "fv.rkt" +(require "../syntax/ast.rkt" + "../syntax/fv.rkt" + "../runtime/types.rkt" "utils.rkt" "compile-expr.rkt" a86/ast) diff --git a/neerdowell/compile-expr.rkt b/neerdowell/compiler/compile-expr.rkt similarity index 98% rename from neerdowell/compile-expr.rkt rename to neerdowell/compiler/compile-expr.rkt index f309fd2..13e67ba 100644 --- a/neerdowell/compile-expr.rkt +++ b/neerdowell/compiler/compile-expr.rkt @@ -1,9 +1,9 @@ #lang racket (provide compile-e compile-lambda-define compile-lambda-defines free-vars-to-heap) -(require "ast.rkt" - "types.rkt" - "lambdas.rkt" - "fv.rkt" +(require "../syntax/ast.rkt" + "../syntax/lambdas.rkt" + "../syntax/fv.rkt" + "../runtime/types.rkt" "utils.rkt" "compile-ops.rkt" "compile-datum.rkt" diff --git a/neerdowell/compile-literals.rkt b/neerdowell/compiler/compile-literals.rkt similarity index 99% rename from neerdowell/compile-literals.rkt rename to neerdowell/compiler/compile-literals.rkt index 7530b30..19317b5 100644 --- a/neerdowell/compile-literals.rkt +++ b/neerdowell/compiler/compile-literals.rkt @@ -1,6 +1,6 @@ #lang racket (provide compile-literals init-symbol-table literals) -(require "ast.rkt" +(require "../syntax/ast.rkt" "utils.rkt" a86/ast) diff --git a/neerdowell/compile-ops.rkt b/neerdowell/compiler/compile-ops.rkt similarity index 99% rename from neerdowell/compile-ops.rkt rename to neerdowell/compiler/compile-ops.rkt index 5c492fd..8e25308 100644 --- a/neerdowell/compile-ops.rkt +++ b/neerdowell/compiler/compile-ops.rkt @@ -2,7 +2,10 @@ (provide compile-op pad-stack unpad-stack assert-proc compile-make-struct ; for notes assert-cons) -(require "ast.rkt" "types.rkt" "utils.rkt" a86/ast) +(require "../syntax/ast.rkt" + "../runtime/types.rkt" + "utils.rkt" + a86/ast) (define rax 'rax) ; return (define eax 'eax) ; 32-bit load/store diff --git a/iniquity-gc/compile-stdin.rkt b/neerdowell/compiler/compile-stdin.rkt similarity index 64% rename from iniquity-gc/compile-stdin.rkt rename to neerdowell/compiler/compile-stdin.rkt index cfa1510..91ca4cc 100644 --- a/iniquity-gc/compile-stdin.rkt +++ b/neerdowell/compiler/compile-stdin.rkt @@ -1,6 +1,9 @@ #lang racket (provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) +(require "../syntax/parse.rkt" + "../syntax/read-all.rkt" + "compile.rkt" + a86/printer) ;; -> Void ;; Compile contents of stdin, diff --git a/neerdowell/compile.rkt b/neerdowell/compiler/compile.rkt similarity index 84% rename from neerdowell/compile.rkt rename to neerdowell/compiler/compile.rkt index 6d0028b..f97074a 100644 --- a/neerdowell/compile.rkt +++ b/neerdowell/compiler/compile.rkt @@ -1,9 +1,9 @@ #lang racket (provide compile compile-e) -(require "ast.rkt" - "types.rkt" - "lambdas.rkt" - "fv.rkt" +(require "../syntax/ast.rkt" + "../syntax/lambdas.rkt" + "../syntax/fv.rkt" + "../runtime/types.rkt" "utils.rkt" "compile-define.rkt" "compile-expr.rkt" @@ -15,6 +15,7 @@ (define rsp 'rsp) ; stack (define rdi 'rdi) ; arg (define r15 'r15) ; stack pad (non-volatile) +(define r12 'r12) ;; type CEnv = (Listof [Maybe Id]) @@ -27,12 +28,14 @@ (Label 'entry) (Push rbx) ; save callee-saved register (Push r15) + (Push r12) (Mov rbx rdi) ; recv heap pointer (init-symbol-table p) (compile-defines-values ds) (compile-e e (reverse (define-ids ds)) #f) (Add rsp (* 8 (length ds))) ;; pop function definitions - (Pop r15) ; restore callee-save register + (Pop r12) ; restore callee-save register + (Pop r15) (Pop rbx) (Ret) (compile-defines ds) diff --git a/mountebank/utils.rkt b/neerdowell/compiler/utils.rkt similarity index 100% rename from mountebank/utils.rkt rename to neerdowell/compiler/utils.rkt diff --git a/neerdowell/env.rkt b/neerdowell/env.rkt deleted file mode 100644 index c43be9c..0000000 --- a/neerdowell/env.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket -(provide lookup ext) - -;; Env Variable -> Answer -(define (lookup env x) - (match env - ['() 'err] - [(cons (list y i) env) - (match (symbol=? x y) - [#t i] - [#f (lookup env x)])])) - -;; Env Variable Value -> Value -(define (ext r x i) - (cons (list x i) r)) \ No newline at end of file diff --git a/neerdowell/executor/decode.rkt b/neerdowell/executor/decode.rkt new file mode 100644 index 0000000..033b020 --- /dev/null +++ b/neerdowell/executor/decode.rkt @@ -0,0 +1,57 @@ +#lang racket +(provide bits->value _val) + +(require "../runtime/types.rkt" + ffi/unsafe) + +(struct struct-val () #:transparent) + +(define (bits->value b) + (cond [(= b (value->bits #t)) #t] + [(= b (value->bits #f)) #f] + [(= b (value->bits eof)) eof] + [(= b (value->bits (void))) (void)] + [(= b (value->bits '())) '()] + [(int-bits? b) + (arithmetic-shift b (- int-shift))] + [(char-bits? b) + (integer->char (arithmetic-shift b (- char-shift)))] + [(box-bits? b) + (box (bits->value (heap-ref b)))] + [(cons-bits? b) + (cons (bits->value (heap-ref (+ b 8))) + (bits->value (heap-ref b)))] + [(vect-bits? b) + (if (zero? (untag b)) + (vector) + (build-vector (heap-ref b) + (lambda (j) + (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] + [(str-bits? b) + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j))))] + [(symb-bits? b) + (string->symbol + (if (zero? (untag b)) + (string) + (build-string (heap-ref b) + (lambda (j) + (char-ref (+ b 8) j)))))] + [(struct-bits? b) + (struct-val)] + [(proc-bits? b) + (lambda _ + (error "This function is not callable."))] + [else (error "invalid bits")])) + +(define (heap-ref i) + (ptr-ref (cast (untag i) _int64 _pointer) _int64)) + +(define (char-ref i j) + (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) + +(define _val + (make-ctype _int64 value->bits bits->value)) diff --git a/neerdowell/executor/exec.rkt b/neerdowell/executor/exec.rkt new file mode 100644 index 0000000..5e2f7fd --- /dev/null +++ b/neerdowell/executor/exec.rkt @@ -0,0 +1,95 @@ +#lang racket + +(provide exec + (struct-out exec-state) + exec-unload + call-with-exec) + +(require a86/interp + ffi/unsafe + "decode.rkt" + "../runtime/types.rkt") + +(struct exec-state (program heap) #:transparent) + +;; ------------------------------------------------------------ +;; symbol helpers + +;; Runtime layout of val_symb_t: +;; uint64_t len; +;; uint32_t codepoints[]; + +(define (symb-ptr->string p) + (define len (ptr-ref p _uint64 0)) + (define cp-base (ptr-add p 8 _byte)) + (build-string + len + (λ (i) + (integer->char (ptr-ref cp-base _uint32 i))))) + +(define (string-compare a b) + (cond + [(stringstring p1) + (symb-ptr->string p2))) + +;; ------------------------------------------------------------ +;; low-level execution + +(define (exec/state prog) + (define intern-table (make-hash)) + (define (intern-symbol/cb p) + (define s (symb-ptr->string p)) + (hash-ref! intern-table s (λ () p))) + + (define heap (malloc _int64 10000)) + (exec-state + (parameterize + ([current-externs + (list + (extern 'read_byte read-byte (_fun -> _val)) + (extern 'peek_byte peek-byte (_fun -> _val)) + (extern 'write_byte write-byte (_fun _val -> _val)) + (extern 'raise_error + (λ () (raise 'err)) + (_fun -> _void)) + (extern 'intern_symbol + intern-symbol/cb + (_fun _pointer -> _pointer)) + (extern 'symb_cmp + symb-cmp/cb + (_fun _pointer _pointer -> _int)))]) + (asm-load prog)) + heap)) + +(define (exec-call st) + (match-define (exec-state program heap) st) + (with-handlers ([(λ (x) (eq? x 'err)) identity]) + (asm-call program 'entry heap))) + +(define (exec-unload st) + (match-define (exec-state program heap) st) + (asm-unload program)) + +;; ------------------------------------------------------------ +;; public API + +;; execute with runtime system and Racket host +;; return raw bits plus the live state needed to interpret them safely + +;; CAUTION: this does not unload +(define (exec asm) + (exec-call (exec/state asm))) + +;; version of above that ensures unloading +(define (call-with-exec e f) + (define st (exec/state e)) + (dynamic-wind + void + (λ () (f (exec-call st))) + (λ () (exec-unload st)))) + diff --git a/neerdowell/executor/run-stdin.rkt b/neerdowell/executor/run-stdin.rkt new file mode 100644 index 0000000..50f0958 --- /dev/null +++ b/neerdowell/executor/run-stdin.rkt @@ -0,0 +1,14 @@ +#lang racket +(provide main) +(require "../syntax/parse.rkt" + "../syntax/read-all.rkt" + "../compiler/compile.rkt" + "run.rkt" + a86/printer) + +;; -> Void +;; Compile contents of stdin, +;; emit asm code on stdout +(define (main) + (read-line) ; ignore #lang racket line + (run (parse (read-all)))) diff --git a/neerdowell/executor/run.rkt b/neerdowell/executor/run.rkt new file mode 100644 index 0000000..c9620a5 --- /dev/null +++ b/neerdowell/executor/run.rkt @@ -0,0 +1,21 @@ +#lang racket + +(provide run run/io) + +(require "exec.rkt" + "decode.rkt") + +;; Asm -> Value +(define (run asm) + (call-with-exec + asm + (λ (r) + (match r + ['err 'err] + [b (bits->value b)])))) + +(define (run/io asm in) + (parameterize ((current-output-port (open-output-string)) + (current-input-port (open-input-string in))) + (cons (run asm) + (get-output-string (current-output-port))))) diff --git a/neerdowell/interp-io.rkt b/neerdowell/interp-io.rkt deleted file mode 100644 index 93f7d3c..0000000 --- a/neerdowell/interp-io.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide interp/io) -(require "interp.rkt") - -;; (Expr String -> String -;; Interpret e with given string as input, -;; collect output as string (including printed result) -(define (interp/io e in) - (parameterize ((current-output-port (open-output-string)) - (current-input-port (open-input-string in))) - (cons (interp e) - (get-output-string (current-output-port))))) diff --git a/neerdowell/interp-stdin.rkt b/neerdowell/interp-stdin.rkt deleted file mode 100644 index 965b9cc..0000000 --- a/neerdowell/interp-stdin.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") - -;; -> Void -;; Parse and interpret contents of stdin, -;; print result on stdout -(define (main) - (read-line) ; ignore #lang racket line - (let ((r (interp (parse (read-all))))) - (unless (void? r) - (println r)))) diff --git a/iniquity-gc/env.rkt b/neerdowell/interpreter/env.rkt similarity index 100% rename from iniquity-gc/env.rkt rename to neerdowell/interpreter/env.rkt diff --git a/neerdowell/interp-defun.rkt b/neerdowell/interpreter/interp-defun.rkt similarity index 99% rename from neerdowell/interp-defun.rkt rename to neerdowell/interpreter/interp-defun.rkt index 6692231..a548046 100644 --- a/neerdowell/interp-defun.rkt +++ b/neerdowell/interpreter/interp-defun.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-env (struct-out Closure) zip) -(require "ast.rkt" +(require "../syntax/ast.rkt" "env.rkt" "interp-prims.rkt") diff --git a/iniquity-gc/interp-io.rkt b/neerdowell/interpreter/interp-io.rkt similarity index 100% rename from iniquity-gc/interp-io.rkt rename to neerdowell/interpreter/interp-io.rkt diff --git a/neerdowell/interp-prims.rkt b/neerdowell/interpreter/interp-prims.rkt similarity index 99% rename from neerdowell/interp-prims.rkt rename to neerdowell/interpreter/interp-prims.rkt index 9f4cdfa..c130b6e 100644 --- a/neerdowell/interp-prims.rkt +++ b/neerdowell/interpreter/interp-prims.rkt @@ -1,5 +1,5 @@ #lang racket -(require "ast.rkt") +(require "../syntax/ast.rkt") (provide interp-prim StructVal) ;; type Struct = (StructVal Symbol (Vectorof Value)) diff --git a/iniquity-gc/interp-stdin.rkt b/neerdowell/interpreter/interp-stdin.rkt similarity index 73% rename from iniquity-gc/interp-stdin.rkt rename to neerdowell/interpreter/interp-stdin.rkt index 965b9cc..1da0197 100644 --- a/iniquity-gc/interp-stdin.rkt +++ b/neerdowell/interpreter/interp-stdin.rkt @@ -1,6 +1,8 @@ #lang racket (provide main) -(require "parse.rkt" "interp.rkt" "read-all.rkt") +(require "../syntax/parse.rkt" + "../syntax/read-all.rkt" + "interp.rkt") ;; -> Void ;; Parse and interpret contents of stdin, diff --git a/neerdowell/interp.rkt b/neerdowell/interpreter/interp.rkt similarity index 99% rename from neerdowell/interp.rkt rename to neerdowell/interpreter/interp.rkt index 1ee5d9f..2a67244 100644 --- a/neerdowell/interp.rkt +++ b/neerdowell/interpreter/interp.rkt @@ -1,6 +1,6 @@ #lang racket (provide interp interp-env) -(require "ast.rkt" +(require "../syntax/ast.rkt" "env.rkt" "interp-prims.rkt") diff --git a/neerdowell/io.c b/neerdowell/io.c deleted file mode 100644 index 7ef8228..0000000 --- a/neerdowell/io.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include "types.h" -#include "values.h" -#include "runtime.h" - -val_t read_byte(void) -{ - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); -} - -val_t peek_byte(void) -{ - char c = getc(in); - ungetc(c, in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); - -} - -val_t write_byte(val_t c) -{ - putc((char) val_unwrap_int(c), out); - return val_wrap_void(); -} diff --git a/neerdowell/main.c b/neerdowell/main.c deleted file mode 100644 index 1ca6115..0000000 --- a/neerdowell/main.c +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include -#include "values.h" -#include "print.h" -#include "runtime.h" - -FILE* in; -FILE* out; -void (*error_handler)(); -val_t *heap; - -void error_exit() -{ - printf("err\n"); - exit(1); -} - -void raise_error() -{ - return error_handler(); -} - -int main(int argc, char** argv) -{ - in = stdin; - out = stdout; - error_handler = &error_exit; - heap = malloc(8 * heap_size); - - val_t result; - - result = entry(heap); - - print_result(result); - if (val_typeof(result) != T_VOID) - putchar('\n'); - - free(heap); - return 0; -} diff --git a/neerdowell/main.rkt b/neerdowell/main.rkt new file mode 100644 index 0000000..4299806 --- /dev/null +++ b/neerdowell/main.rkt @@ -0,0 +1,20 @@ +#lang racket +(require "syntax/ast.rkt") +(require "syntax/parse.rkt") +(require "interpreter/interp.rkt") +(require "interpreter/interp-io.rkt") +(require "compiler/compile.rkt") +(require "runtime/types.rkt") +(require "executor/decode.rkt") +(require "executor/run.rkt") +(require "executor/exec.rkt") +(provide (all-from-out "syntax/ast.rkt")) +(provide (all-from-out "syntax/parse.rkt")) +(provide (all-from-out "interpreter/interp.rkt")) +(provide (all-from-out "interpreter/interp-io.rkt")) +(provide (all-from-out "compiler/compile.rkt")) +(provide (all-from-out "runtime/types.rkt")) +(provide (all-from-out "executor/decode.rkt")) +(provide (all-from-out "executor/run.rkt")) +(provide (all-from-out "executor/exec.rkt")) + diff --git a/neerdowell/parse-file.rkt b/neerdowell/parse-file.rkt deleted file mode 100644 index a502132..0000000 --- a/neerdowell/parse-file.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket -(provide main) -(require "parse.rkt" "compile.rkt" "read-all.rkt" a86/printer) - -;; String -> Void -;; Compile contents of given file name, -;; emit asm code on stdout -(define (main fn) - (let ((p (open-input-file fn))) - (begin - (read-line p) ; ignore #lang racket line - (displayln (parse (read-all p))) - (close-input-port p)))) diff --git a/neerdowell/print.h b/neerdowell/print.h deleted file mode 100644 index c22081a..0000000 --- a/neerdowell/print.h +++ /dev/null @@ -1,8 +0,0 @@ -#ifndef PRINT_H -#define PRINT_H - -#include "values.h" - -void print_result(val_t); - -#endif diff --git a/neerdowell/read-all.rkt b/neerdowell/read-all.rkt deleted file mode 100644 index 8a3289a..0000000 --- a/neerdowell/read-all.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(provide read-all) -;; read all s-expression until eof -(define (read-all) - (let ((r (read))) - (if (eof-object? r) - '() - (cons r (read-all))))) diff --git a/neerdowell/run.rkt b/neerdowell/run.rkt deleted file mode 100644 index eaa53eb..0000000 --- a/neerdowell/run.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(provide run run/io) -(require "types.rkt" "build-runtime.rkt" - a86/interp) - -;; Asm -> Answer -(define (run is) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp is) - ['err 'err] - [b (bits->value b)]))) - -;; Asm String -> (cons Answer String) -(define (run/io is s) - (parameterize ((current-objs (list runtime-path))) - (match (asm-interp/io is s) - [(cons 'err o) (cons 'err o)] - [(cons b o) (cons (bits->value b) o)]))) diff --git a/neerdowell/runtime.h b/neerdowell/runtime.h deleted file mode 100644 index cf6a73c..0000000 --- a/neerdowell/runtime.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef RUNTIME_H -#define RUNTIME_H - -#include "values.h" - -val_t entry(val_t*); -extern FILE* in; -extern FILE* out; -extern void (*error_handler)(); - -// in words -#define heap_size 10000 -extern val_t *heap; - -#endif /* RUNTIME_H */ diff --git a/neerdowell/runtime/Makefile b/neerdowell/runtime/Makefile new file mode 100644 index 0000000..ee8ff93 --- /dev/null +++ b/neerdowell/runtime/Makefile @@ -0,0 +1,29 @@ +ifeq ($(shell uname), Darwin) + LANGS_CC ?= arch -x86_64 clang + LANGS_AS ?= arch -x86_64 clang -c +else + LANGS_CC ?= clang + LANGS_AS ?= clang -c +endif + +CFLAGS += -fPIC -g + +OBJS = \ + main.o \ + values.o \ + print.o \ + io.o \ + symbol.o \ + error.o + +default: runtime.o + +runtime.o: $(OBJS) + ld -r $(OBJS) -o $@ + +%.o: %.c + $(LANGS_CC) $(CFLAGS) -c -o $@ $< + +clean: + @$(RM) *.o runtime.o ||: + @echo "$(shell basename $(shell pwd)): cleaned!" diff --git a/neerdowell/char.c b/neerdowell/runtime/char.c similarity index 100% rename from neerdowell/char.c rename to neerdowell/runtime/char.c diff --git a/neerdowell/runtime/error.c b/neerdowell/runtime/error.c new file mode 100644 index 0000000..69a535a --- /dev/null +++ b/neerdowell/runtime/error.c @@ -0,0 +1,9 @@ +#include +#include +#include "runtime.h" + +_Noreturn void raise_error(void) +{ + printf("err\n"); + exit(1); +} diff --git a/neerdowell/heap.h b/neerdowell/runtime/heap.h similarity index 100% rename from neerdowell/heap.h rename to neerdowell/runtime/heap.h diff --git a/mug/io.c b/neerdowell/runtime/io.c similarity index 50% rename from mug/io.c rename to neerdowell/runtime/io.c index 7ef8228..9f1fc45 100644 --- a/mug/io.c +++ b/neerdowell/runtime/io.c @@ -1,25 +1,25 @@ #include -#include -#include "types.h" +#include #include "values.h" #include "runtime.h" val_t read_byte(void) { - char c = getc(in); - return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); + int c = getc(stdin); + return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); } val_t peek_byte(void) { - char c = getc(in); - ungetc(c, in); + int c = getc(stdin); + if (c != EOF) + ungetc(c, stdin); return (c == EOF) ? val_wrap_eof() : val_wrap_int(c); - } val_t write_byte(val_t c) { - putc((char) val_unwrap_int(c), out); + int b = val_unwrap_int(c); + putc((unsigned char)b, stdout); return val_wrap_void(); } diff --git a/neerdowell/runtime/main.c b/neerdowell/runtime/main.c new file mode 100644 index 0000000..610b2bf --- /dev/null +++ b/neerdowell/runtime/main.c @@ -0,0 +1,26 @@ +#include +#include +#include "values.h" +#include "print.h" +#include "runtime.h" + +/* in words */ +#define heap_size 10000 + +int main(int argc, char **argv) +{ + val_t *heap = malloc(8 * heap_size); + if (!heap) { + fprintf(stderr, "out of memory\n"); + return 1; + } + + val_t result = entry(heap); + + print_result(result); + if (val_typeof(result) != T_VOID) + putchar('\n'); + + free(heap); + return 0; +} diff --git a/mug/print.c b/neerdowell/runtime/print.c similarity index 98% rename from mug/print.c rename to neerdowell/runtime/print.c index 2bcb21d..1a9f8a7 100644 --- a/mug/print.c +++ b/neerdowell/runtime/print.c @@ -8,6 +8,7 @@ void print_cons(val_cons_t *); void print_vect(val_vect_t*); void print_str(val_str_t*); void print_symb(val_symb_t*); +void print_struct(val_struct_t *); void print_str_char(val_char_t); void print_result_interior(val_t); int utf8_encode_char(val_char_t, char *); @@ -48,11 +49,20 @@ void print_result(val_t x) case T_PROC: printf("#"); break; + case T_STRUCT: + print_struct(val_unwrap_struct(x)); + break; case T_INVALID: printf("internal error"); } } +void print_struct(val_struct_t *s) { + printf("#<"); + print_result_interior(s->name); + printf(">"); +} + void print_symb(val_symb_t *s) { print_str((val_str_t*) s); diff --git a/mug/print.h b/neerdowell/runtime/print.h similarity index 100% rename from mug/print.h rename to neerdowell/runtime/print.h diff --git a/neerdowell/runtime/runtime.h b/neerdowell/runtime/runtime.h new file mode 100644 index 0000000..2ec5ef1 --- /dev/null +++ b/neerdowell/runtime/runtime.h @@ -0,0 +1,27 @@ +#ifndef RUNTIME_H +#define RUNTIME_H + +#include "values.h" + +/* + * Entry point for compiled programs. + * + * The caller supplies the heap pointer. Compiled code may use this as its + * initial allocation pointer / runtime heap base according to the language's + * calling convention. + */ +val_t entry(val_t *heap); + +/* + * Language-facing runtime operations used by compiled code. + * + * These are implemented by the runtime core, typically in terms of lower-level + * host hooks declared in host.h. + */ +val_t read_byte(void); +val_t peek_byte(void); +val_t write_byte(val_t); + +_Noreturn void raise_error(void); + +#endif /* RUNTIME_H */ diff --git a/neerdowell/symbol.c b/neerdowell/runtime/symbol.c similarity index 100% rename from neerdowell/symbol.c rename to neerdowell/runtime/symbol.c diff --git a/mug/types.h b/neerdowell/runtime/types.h similarity index 65% rename from mug/types.h rename to neerdowell/runtime/types.h index 4093c4f..084310e 100644 --- a/mug/types.h +++ b/neerdowell/runtime/types.h @@ -2,41 +2,51 @@ #define TYPES_H /* - Bit layout of values + * Bit layout of runtime values + * + * Values are either: + * - immediates, tagged with low bits ending in #b000 + * - pointers, tagged with one of the pointer tags below + * + * Immediates include: + * - integers + * - characters + * - booleans + * - eof + * - void + * - empty list + */ - Values are either: - - Immediates: end in #b000 - - Pointers - - Immediates are either - - Integers: end in #b0 000 - - Characters: end in #b01 000 - - True: #b11 000 - - False: #b1 11 000 - - Eof: #b10 11 000 - - Void: #b11 11 000 - - Empty: #b100 11 000 -*/ +/* low bits reserved for pointer/immediate discrimination */ #define imm_shift 3 #define ptr_type_mask ((1 << imm_shift) - 1) + +/* pointer tags */ #define box_type_tag 1 #define cons_type_tag 2 #define vect_type_tag 3 #define str_type_tag 4 #define proc_type_tag 5 #define symb_type_tag 6 +#define struct_type_tag 7 + +/* integer immediates */ #define int_shift (1 + imm_shift) #define int_type_mask ((1 << int_shift) - 1) #define int_type_tag (0 << (int_shift - 1)) #define nonint_type_tag (1 << (int_shift - 1)) + +/* character immediates */ #define char_shift (int_shift + 1) #define char_type_mask ((1 << char_shift) - 1) #define char_type_tag ((0 << (char_shift - 1)) | nonint_type_tag) #define nonchar_type_tag ((1 << (char_shift - 1)) | nonint_type_tag) + +/* distinguished immediate constants */ #define val_true ((0 << char_shift) | nonchar_type_tag) #define val_false ((1 << char_shift) | nonchar_type_tag) #define val_eof ((2 << char_shift) | nonchar_type_tag) #define val_void ((3 << char_shift) | nonchar_type_tag) #define val_empty ((4 << char_shift) | nonchar_type_tag) -#endif +#endif /* TYPES_H */ diff --git a/iniquity-gc/types.rkt b/neerdowell/runtime/types.rkt similarity index 54% rename from iniquity-gc/types.rkt rename to neerdowell/runtime/types.rkt index 9dbc9d5..f37867c 100644 --- a/iniquity-gc/types.rkt +++ b/neerdowell/runtime/types.rkt @@ -1,6 +1,5 @@ #lang racket (provide (all-defined-out)) -(require ffi/unsafe) (define imm-shift 3) (define imm-mask #b111) @@ -9,6 +8,9 @@ (define type-cons #b010) (define type-vect #b011) (define type-str #b100) +(define type-proc #b101) +(define type-symb #b110) +(define type-struct #b111) (define int-shift (+ 1 imm-shift)) (define char-shift (+ 2 imm-shift)) (define type-int #b0000) @@ -16,35 +18,6 @@ (define type-char #b01000) (define mask-char #b11111) -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (heap-ref b)))] - [(cons-bits? b) - (cons (bits->value (heap-ref (+ b 8))) - (bits->value (heap-ref b)))] - [(vect-bits? b) - (if (zero? (untag b)) - (vector) - (build-vector (heap-ref b) - (lambda (j) - (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] - [(str-bits? b) - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j))))] - [else (error "invalid bits")])) - (define (value->bits v) (cond [(eq? v #t) #b00011000] [(eq? v #f) #b00111000] @@ -79,12 +52,15 @@ (define (str-bits? v) (= type-str (bitwise-and v imm-mask))) +(define (proc-bits? v) + (= type-proc (bitwise-and v imm-mask))) + +(define (symb-bits? v) + (= type-symb (bitwise-and v imm-mask))) + +(define (struct-bits? v) + (= type-struct (bitwise-and v imm-mask))) + (define (untag i) (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/mountebank/values.c b/neerdowell/runtime/values.c similarity index 90% rename from mountebank/values.c rename to neerdowell/runtime/values.c index 32e922b..6627fc2 100644 --- a/mountebank/values.c +++ b/neerdowell/runtime/values.c @@ -16,6 +16,8 @@ type_t val_typeof(val_t x) return T_SYMB; case proc_type_tag: return T_PROC; + case struct_type_tag: + return T_STRUCT; } if ((int_type_mask & x) == int_type_tag) @@ -119,3 +121,12 @@ val_t val_wrap_symb(val_symb_t *v) { return ((val_t)v) | symb_type_tag; } + +val_struct_t* val_unwrap_struct(val_t x) +{ + return (val_struct_t *)(x ^ struct_type_tag); +} +val_t val_wrap_struct(val_struct_t* v) +{ + return ((val_t)v) | struct_type_tag; +} diff --git a/neerdowell/runtime/values.h b/neerdowell/runtime/values.h new file mode 100644 index 0000000..5c41275 --- /dev/null +++ b/neerdowell/runtime/values.h @@ -0,0 +1,119 @@ +#ifndef VALUES_H +#define VALUES_H + +#include + +/* + * Abstract runtime value. + * + * All language values are represented as a tagged 64-bit word. + */ +typedef int64_t val_t; + +/* + * Dynamic type tags used by the runtime and printing code. + */ +typedef enum type_t { + T_INVALID = -1, + + /* immediates */ + T_INT, + T_BOOL, + T_CHAR, + T_EOF, + T_VOID, + T_EMPTY, + + /* heap objects */ + T_BOX, + T_CONS, + T_VECT, + T_STR, + T_SYMB, + T_PROC, + T_STRUCT, +} type_t; + +typedef uint32_t val_char_t; + +/* + * Heap object layouts. + * + * These layouts correspond to the pointer-tagged representations in types.h. + */ +typedef struct val_box_t { + val_t val; +} val_box_t; + +typedef struct val_cons_t { + val_t snd; + val_t fst; +} val_cons_t; + +typedef struct val_vect_t { + uint64_t len; + val_t elems[]; +} val_vect_t; + +typedef struct val_str_t { + uint64_t len; + val_char_t codepoints[]; +} val_str_t; + +typedef struct val_symb_t { + uint64_t len; + val_char_t codepoints[]; +} val_symb_t; + +typedef struct val_struct_t { + val_t name; + val_t *vals; +} val_struct_t; + +/* + * Classify a runtime value. + */ +type_t val_typeof(val_t x); + +/* + * Wrap/unwrap operations. + * + * The behavior of unwrap functions is undefined on type mismatch. + */ + +/* integers */ +int64_t val_unwrap_int(val_t x); +val_t val_wrap_int(int64_t i); + +/* booleans */ +int val_unwrap_bool(val_t x); +val_t val_wrap_bool(int b); + +/* characters */ +val_char_t val_unwrap_char(val_t x); +val_t val_wrap_char(val_char_t c); + +/* special values */ +val_t val_wrap_eof(void); +val_t val_wrap_void(void); + +/* heap objects */ +val_box_t *val_unwrap_box(val_t x); +val_t val_wrap_box(val_box_t *b); + +val_cons_t *val_unwrap_cons(val_t x); +val_t val_wrap_cons(val_cons_t *c); + +val_vect_t *val_unwrap_vect(val_t x); +val_t val_wrap_vect(val_vect_t *v); + +val_str_t *val_unwrap_str(val_t x); +val_t val_wrap_str(val_str_t *v); + +val_symb_t *val_unwrap_symb(val_t x); +val_t val_wrap_symb(val_symb_t *v); + +val_struct_t *val_unwrap_struct(val_t x); +val_t val_wrap_struct(val_struct_t *v); + +#endif /* VALUES_H */ diff --git a/neerdowell/ast.rkt b/neerdowell/syntax/ast.rkt similarity index 100% rename from neerdowell/ast.rkt rename to neerdowell/syntax/ast.rkt diff --git a/neerdowell/fv.rkt b/neerdowell/syntax/fv.rkt similarity index 100% rename from neerdowell/fv.rkt rename to neerdowell/syntax/fv.rkt diff --git a/neerdowell/lambdas.rkt b/neerdowell/syntax/lambdas.rkt similarity index 100% rename from neerdowell/lambdas.rkt rename to neerdowell/syntax/lambdas.rkt diff --git a/neerdowell/parse.rkt b/neerdowell/syntax/parse.rkt similarity index 100% rename from neerdowell/parse.rkt rename to neerdowell/syntax/parse.rkt diff --git a/iniquity-gc/read-all.rkt b/neerdowell/syntax/read-all.rkt similarity index 100% rename from iniquity-gc/read-all.rkt rename to neerdowell/syntax/read-all.rkt diff --git a/neerdowell/test/build-runtime.rkt b/neerdowell/test/build-runtime.rkt deleted file mode 100644 index 7023ee0..0000000 --- a/neerdowell/test/build-runtime.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require a86/interp) - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) diff --git a/neerdowell/test/compile.rkt b/neerdowell/test/compile.rkt deleted file mode 100644 index ee289de..0000000 --- a/neerdowell/test/compile.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../run.rkt") - -(test-runner (λ p (run (compile (parse p))))) -(test-runner-io (λ (s . p) (run/io (compile (parse p)) s))) diff --git a/neerdowell/test/interp-defun.rkt b/neerdowell/test/interp-defun.rkt deleted file mode 100644 index 68ef419..0000000 --- a/neerdowell/test/interp-defun.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp-defun.rkt" - "../interp-io.rkt") - -(define (closure->proc xs e r) - ;; Could make this better by calling the interpreter, - ;; but it's only used in tests where all we care about - ;; is that you get a procedure. - (lambda _ - (error "This function is not callable."))) - -(test-runner - (λ p - (match (interp (parse p)) - [(Closure xs e r) (closure->proc xs e r)] - [v v]))) -(test-runner-io - (λ (s . p) - (match (interp/io (parse p) s) - [(cons (Closure xs e r) o) - (cons (closure->proc xs e r) o)] - [r r]))) diff --git a/neerdowell/test/interp.rkt b/neerdowell/test/interp.rkt deleted file mode 100644 index cd7b654..0000000 --- a/neerdowell/test/interp.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../interp.rkt" - "../interp-io.rkt") - -(test-runner (λ p (interp (parse p)))) -(test-runner-io (λ (s . p) (interp/io (parse p) s))) diff --git a/neerdowell/test/test-runner.rkt b/neerdowell/test/test-runner.rkt deleted file mode 100644 index a0fc443..0000000 --- a/neerdowell/test/test-runner.rkt +++ /dev/null @@ -1,550 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (f x) x) - '(define (g x) (f x)) - '(g 5)) - 5) - (check-equal? (run - '(define (even? x) - (if (zero? x) - #t - (odd? (sub1 x)))) - '(define (odd? x) - (if (zero? x) - #f - (even? (sub1 x)))) - '(even? 101)) - #f) - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run - '(define (f x) - 10) - '(f 1)) - 10) - (check-equal? (run - '(define (f x) - 10) - '(let ((x 2)) (f 1))) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(f 1 2)) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(let ((z 2)) (f 1 2))) - 10) - (check-equal? (run '(define (f x y) y) - '(f 1 (add1 #f))) - 'err) - - ;; Knock examples - (check-equal? (run '(match 1)) 'err) - (check-equal? (run '(match 1 [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) - 2) - (check-equal? (run '(match 1 [2 1] [0 3])) - 'err) - (check-equal? (run '(match 1 [_ 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) - (cons 1 2)) - (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) - 3) - (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) - 3) - (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) - 2) - (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) - 0) - (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) - 1) - (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) - 1) - - ;; Loot examples - (check-true (procedure? (run '(λ (x) x)))) - (check-equal? (run '((λ (x) x) 5)) - 5) - - (check-equal? (run '(let ((f (λ (x) x))) (f 5))) - 5) - (check-equal? (run '(let ((f (λ (x y) x))) (f 5 7))) - 5) - (check-equal? (run '(let ((f (λ (x y) y))) (f 5 7))) - 7) - (check-equal? (run '((let ((x 1)) - (let ((y 2)) - (lambda (z) (cons x (cons y (cons z '())))))) - 3)) - '(1 2 3)) - (check-equal? (run '(define (adder n) - (λ (x) (+ x n))) - '((adder 5) 10)) - 15) - (check-equal? (run '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36)) - 666) - (check-equal? (run '(define (tri n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))) - '(tri 36)) - 666) - (check-equal? (run '(define (tri n) - (match n - [0 0] - [m (+ m (tri (sub1 m)))])) - '(tri 36)) - 666) - (check-equal? (run '((match 8 [8 (lambda (x) x)]) 12)) - 12) - - ;; Mug examples - (check-equal? (run '(symbol? 'foo)) #t) - (check-equal? (run '(symbol? (string->symbol "foo"))) #t) - (check-equal? (run '(eq? 'foo 'foo)) #t) - (check-equal? (run '(eq? (string->symbol "foo") - (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'foo (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'fff (string->symbol (make-string 3 #\f)))) - #t) - (check-equal? (run '(symbol? 'g0)) #t) - (check-equal? (run '(symbol? "g0")) #f) - (check-equal? (run '(symbol? (string->symbol "g0"))) #t) - (check-equal? (run '(symbol? (string->uninterned-symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->uninterned-symbol "g0"))) #f) - (check-equal? (run '(eq? (string->uninterned-symbol "g0") (string->uninterned-symbol "g0"))) - #f) - (check-equal? (run '(eq? (symbol->string 'foo) (symbol->string 'foo))) #f) - (check-equal? (run '(string? (symbol->string 'foo))) #t) - (check-equal? (run '(eq? (symbol->string 'foo) "foo")) #f) - (check-equal? (run ''foo) 'foo) - (check-equal? (run '(eq? (match #t [_ "foo"]) "bar")) #f) - (check-equal? (run '(eq? (match #t [_ 'foo]) 'bar)) #f) - (check-equal? (run '(match 'foo ['bar #t] [_ #f])) #f) - (check-equal? (run '(match 'foo ['foo #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["foo" #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["bar" #t] [_ #f])) #f) - (check-equal? (run '(match (cons '+ (cons 1 (cons 2 '()))) - [(cons '+ (cons x (cons y '()))) - (+ x y)])) - 3) - - ;; Mountebank examples - (check-equal? (run '#()) - #()) - (check-equal? (run ''#()) - #()) - (check-equal? (run ''#t) - #t) - (check-equal? (run ''7) - 7) - (check-equal? (run ''(1 2 3)) - '(1 2 3)) - (check-equal? (run ''(1 . 2)) - '(1 . 2)) - (check-equal? (run ''(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) - '(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) - (check-equal? (run '(define (f) (cons 1 2)) - '(eq? (f) (f))) - #f) - (check-equal? (run '(define (f) '(1 . 2)) - '(eq? (f) (f))) - #t) - (check-equal? (run '(let ((x '(foo . foo))) - (eq? (car x) (cdr x)))) - #t) - (check-equal? - (run '(define (eval e r) - (match e - [(list 'zero? e) - (zero? (eval e r))] - [(list 'sub1 e) - (sub1 (eval e r))] - [(list '+ e1 e2) - (+ (eval e1 r) (eval e2 r))] - [(list 'if e1 e2 e3) - (if (eval e1 r) - (eval e2 r) - (eval e3 r))] - [(list 'λ (list x) e) - (lambda (v) (eval e (cons (cons x v) r)))] - [(list e1 e2) - ((eval e1 r) (eval e2 r))] - [_ - (if (symbol? e) - (lookup r e) - e)])) - '(define (lookup r x) - (match r - [(cons (cons y v) r) - (if (eq? x y) - v - (lookup r x))])) - '(eval '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36) - '())) - 666) - - ;; Neerdowell examples - (check-equal? (run '(struct foo ()) - '(foo? (foo))) - #t) - (check-equal? (run '(struct foo (x)) - '(foo? (foo 1))) - #t) - (check-equal? (run '(struct foo ()) - '(struct bar ()) - '(foo? (bar))) - #f) - (check-equal? (run '(struct foo ()) - '(struct bar ()) - '(bar? (bar))) - #t) - (check-equal? (run '(struct foo ()) - '(struct bar ()) - '(bar? #())) - #f) - (check-equal? (run '(struct foo (x)) - '(foo-x (foo 3))) - 3) - (check-equal? (run '(struct foo (x)) - '(let ((x (foo 3))) - (foo-x x))) - 3) - (check-equal? (run '(struct foo (x)) - '(let ((x (foo 3))) - (foo-x x))) - 3) - (check-equal? (run '(struct foo (x)) - '(let ((x (foo (foo 3)))) - (foo? (foo-x x)))) - #t) - (check-equal? (run '(struct foo (x y z)) - '(let ((x (foo 1 2 3))) - (cons (foo-x x) - (cons (foo-y x) - (cons (foo-z x) - '()))))) - '(1 2 3)) - (check-equal? (run '(struct foo ()) - '(eq? (foo) (foo))) - #f) - (check-equal? (run '(struct foo (x)) - '(foo-x #t)) - 'err) - (check-equal? (run '(struct foo (x)) - '(struct bar (y)) - '(match (bar 5) - [(foo x) #f] - [(bar x) x])) - 5) - (check-equal? (run '(struct nil ()) - '(struct pair (x y)) - '(define (len x) - (match x - [(nil) 0] - [(pair _ x) (add1 (len x))])) - '(len (pair 1 (pair 2 (pair 3 (nil)))))) - 3) - (check-equal? (run '(match (cons (cons 1 2) '()) - [(cons (cons x y) '()) y])) - 2) - (check-equal? (run '(struct foo (p q)) - '(match (cons (foo 1 2) '()) - [(cons (foo x y) _) y])) - 2) - (check-equal? (run '(struct foo (p q)) - '(match (cons (foo 1 2) '()) - [(cons (foo x 3) _) x] - [_ 9])) - 9) - (check-equal? (run '(struct foo (x q)) - '(define (get z) - (match z - ['() #f] - [(cons (foo x q) y) x])) - '(get (cons (foo 7 2) '()))) - 7) - (check-equal? (run '(struct posn (x y)) - '(define (posn-xs ps) - (match ps - ['() '()] - [(cons (posn x y) ps) - (cons x (posn-xs ps))])) - '(posn-xs (cons (posn 3 4) (cons (posn 5 6) (cons (posn 7 8) '()))))) - '(3 5 7)) - (check-equal? (run '(struct Foo (x y z)) - '(match (Foo 1 2 3) - [(Foo x y z) z])) - 3) - (check-equal? (run '(struct Boo (x)) - '(match 8 - [(Boo 'y) 0] - [_ 1])) - 1)) - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - #| - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz")) -|#) diff --git a/neerdowell/types.rkt b/neerdowell/types.rkt deleted file mode 100644 index 9375b78..0000000 --- a/neerdowell/types.rkt +++ /dev/null @@ -1,116 +0,0 @@ -#lang racket -(provide (all-defined-out)) -(require ffi/unsafe) - -(define imm-shift 3) -(define imm-mask #b111) -(define ptr-mask #b111) -(define type-box #b001) -(define type-cons #b010) -(define type-vect #b011) -(define type-str #b100) -(define type-proc #b101) -(define type-symb #b110) -(define type-struct #b111) -(define int-shift (+ 1 imm-shift)) -(define char-shift (+ 2 imm-shift)) -(define type-int #b0000) -(define mask-int #b1111) -(define type-char #b01000) -(define mask-char #b11111) - -(struct struct-val () #:transparent) - -(define (bits->value b) - (cond [(= b (value->bits #t)) #t] - [(= b (value->bits #f)) #f] - [(= b (value->bits eof)) eof] - [(= b (value->bits (void))) (void)] - [(= b (value->bits '())) '()] - [(int-bits? b) - (arithmetic-shift b (- int-shift))] - [(char-bits? b) - (integer->char (arithmetic-shift b (- char-shift)))] - [(box-bits? b) - (box (bits->value (heap-ref b)))] - [(cons-bits? b) - (cons (bits->value (heap-ref (+ b 8))) - (bits->value (heap-ref b)))] - [(vect-bits? b) - (if (zero? (untag b)) - (vector) - (build-vector (heap-ref b) - (lambda (j) - (bits->value (heap-ref (+ b (* 8 (add1 j))))))))] - [(str-bits? b) - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j))))] - [(symb-bits? b) - (string->symbol - (if (zero? (untag b)) - (string) - (build-string (heap-ref b) - (lambda (j) - (char-ref (+ b 8) j)))))] - [(struct-bits? b) - (struct-val)] - [(proc-bits? b) - (lambda _ - (error "This function is not callable."))] - [else (error "invalid bits")])) - -(define (value->bits v) - (cond [(eq? v #t) #b00011000] - [(eq? v #f) #b00111000] - [(eof-object? v) #b01011000] - [(void? v) #b01111000] - [(empty? v) #b10011000] - [(integer? v) - (arithmetic-shift v int-shift)] - [(char? v) - (bitwise-ior type-char - (arithmetic-shift (char->integer v) char-shift))] - [else (error "not an immediate value")])) - -(define (imm-bits? v) - (zero? (bitwise-and v imm-mask))) - -(define (int-bits? v) - (= type-int (bitwise-and v mask-int))) - -(define (char-bits? v) - (= type-char (bitwise-and v mask-char))) - -(define (cons-bits? v) - (= type-cons (bitwise-and v imm-mask))) - -(define (box-bits? v) - (= type-box (bitwise-and v imm-mask))) - -(define (vect-bits? v) - (= type-vect (bitwise-and v imm-mask))) - -(define (str-bits? v) - (= type-str (bitwise-and v imm-mask))) - -(define (proc-bits? v) - (= type-proc (bitwise-and v imm-mask))) - -(define (symb-bits? v) - (= type-symb (bitwise-and v imm-mask))) - -(define (struct-bits? v) - (= type-struct (bitwise-and v imm-mask))) - -(define (untag i) - (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask))) - (integer-length ptr-mask))) - -(define (heap-ref i) - (ptr-ref (cast (untag i) _int64 _pointer) _int64)) - -(define (char-ref i j) - (integer->char (ptr-ref (cast (untag i) _int64 _pointer) _uint32 j))) diff --git a/neerdowell/utils.rkt b/neerdowell/utils.rkt deleted file mode 100644 index 612b738..0000000 --- a/neerdowell/utils.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang racket -(provide symbol->data-label lookup pad-stack unpad-stack) -(require a86/ast) - -(define rsp 'rsp) -(define r15 'r15) - -(define (symbol->data-label s) - (symbol->label - (string->symbol (string-append "data_" (symbol->string s))))) - -;; Id CEnv -> [Maybe Integer] -(define (lookup x cenv) - (match cenv - ['() #f] - [(cons y rest) - (match (eq? x y) - [#t 0] - [#f (match (lookup x rest) - [#f #f] - [i (+ 8 i)])])])) - -;; Asm -;; Dynamically pad the stack to be aligned for a call -(define pad-stack - (seq (Mov r15 rsp) - (And r15 #b1000) - (Sub rsp r15))) - -;; Asm -;; Undo the stack alignment after a call -(define unpad-stack - (seq (Add rsp r15))) diff --git a/neerdowell/values.h b/neerdowell/values.h deleted file mode 100644 index 1f1dafa..0000000 --- a/neerdowell/values.h +++ /dev/null @@ -1,91 +0,0 @@ -#ifndef VALUES_H -#define VALUES_H - -#include - -/* any abstract value */ -typedef int64_t val_t; - -typedef enum type_t { - T_INVALID = -1, - /* immediates */ - T_INT, - T_BOOL, - T_CHAR, - T_EOF, - T_VOID, - T_EMPTY, - /* pointers */ - T_BOX, - T_CONS, - T_VECT, - T_STR, - T_SYMB, - T_PROC, - T_STRUCT, -} type_t; - -typedef uint32_t val_char_t; -typedef struct val_box_t { - val_t val; -} val_box_t; -typedef struct val_cons_t { - val_t snd; - val_t fst; -} val_cons_t; -typedef struct val_vect_t { - uint64_t len; - val_t elems[]; -} val_vect_t; -typedef struct val_str_t { - uint64_t len; - val_char_t codepoints[]; -} val_str_t; -typedef struct val_symb_t { - uint64_t len; - val_char_t codepoints[]; -} val_symb_t; -typedef struct val_struct_t { - val_t name; - val_t* vals; -} val_struct_t; -/* return the type of x */ -type_t val_typeof(val_t x); - -/** - * Wrap/unwrap values - * - * The behavior of unwrap functions are undefined on type mismatch. - */ -int64_t val_unwrap_int(val_t x); -val_t val_wrap_int(int64_t i); - -int val_unwrap_bool(val_t x); -val_t val_wrap_bool(int b); - -val_char_t val_unwrap_char(val_t x); -val_t val_wrap_char(val_char_t b); - -val_t val_wrap_eof(); - -val_t val_wrap_void(); - -val_box_t* val_unwrap_box(val_t x); -val_t val_wrap_box(val_box_t* b); - -val_cons_t* val_unwrap_cons(val_t x); -val_t val_wrap_cons(val_cons_t* c); - -val_vect_t* val_unwrap_vect(val_t x); -val_t val_wrap_vect(val_vect_t* c); - -val_str_t* val_unwrap_str(val_t x); -val_t val_wrap_str(val_str_t* c); - -val_symb_t* val_unwrap_symb(val_t x); -val_t val_wrap_symb(val_symb_t* c); - -val_struct_t* val_unwrap_struct(val_t x); -val_t val_wrap_struct(val_struct_t* c); - -#endif diff --git a/outlaw/test/compile.rkt b/outlaw/test/compile.rkt deleted file mode 100644 index 0d8f86a..0000000 --- a/outlaw/test/compile.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket -(require "test-runner.rkt" - "../parse.rkt" - "../compile.rkt" - "../unload-bits-asm.rkt" - "../a86/interp.rkt") - -;; link with runtime for IO operations -(unless (file-exists? "../runtime.o") - (system "make -C .. runtime.o")) -(current-objs - (list (path->string (normalize-path "../runtime.o")))) - -(test-runner (λ p (unload/free (asm-interp (compile (parse p)))))) -(test-runner-io (λ (s . p) - (match (asm-interp/io (compile (parse p)) s) - ['err 'err] - [(cons r o) (cons (unload/free r) o)]))) diff --git a/outlaw/test/test-runner.rkt b/outlaw/test/test-runner.rkt deleted file mode 100644 index 64f0d41..0000000 --- a/outlaw/test/test-runner.rkt +++ /dev/null @@ -1,781 +0,0 @@ -#lang racket -(provide test-runner test-runner-io) -(require rackunit) - -(define (test-runner run) - ;; Abscond examples - (check-equal? (run 7) 7) - (check-equal? (run -8) -8) - - ;; Blackmail examples - (check-equal? (run '(add1 (add1 7))) 9) - (check-equal? (run '(add1 (sub1 7))) 7) - - ;; Con examples - (check-equal? (run '(if (zero? 0) 1 2)) 1) - (check-equal? (run '(if (zero? 1) 1 2)) 2) - (check-equal? (run '(if (zero? -7) 1 2)) 2) - (check-equal? (run '(if (zero? 0) - (if (zero? 1) 1 2) - 7)) - 2) - (check-equal? (run '(if (zero? (if (zero? 0) 1 0)) - (if (zero? 1) 1 2) - 7)) - 7) - - ;; Dupe examples - (check-equal? (run #t) #t) - (check-equal? (run #f) #f) - (check-equal? (run '(if #t 1 2)) 1) - (check-equal? (run '(if #f 1 2)) 2) - (check-equal? (run '(if 0 1 2)) 1) - (check-equal? (run '(if #t 3 4)) 3) - (check-equal? (run '(if #f 3 4)) 4) - (check-equal? (run '(if 0 3 4)) 3) - (check-equal? (run '(zero? 4)) #f) - (check-equal? (run '(zero? 0)) #t) - - ;; Dodger examples - (check-equal? (run #\a) #\a) - (check-equal? (run #\b) #\b) - (check-equal? (run '(char? #\a)) #t) - (check-equal? (run '(char? #t)) #f) - (check-equal? (run '(char? 8)) #f) - (check-equal? (run '(char->integer #\a)) (char->integer #\a)) - (check-equal? (run '(integer->char 955)) #\λ) - - ;; Extort examples - (check-equal? (run '(add1 #f)) 'err) - (check-equal? (run '(sub1 #f)) 'err) - (check-equal? (run '(zero? #f)) 'err) - (check-equal? (run '(char->integer #f)) 'err) - (check-equal? (run '(integer->char #f)) 'err) - (check-equal? (run '(integer->char -1)) 'err) - (check-equal? (run '(write-byte #f)) 'err) - (check-equal? (run '(write-byte -1)) 'err) - (check-equal? (run '(write-byte 256)) 'err) - - ;; Fraud examples - (check-equal? (run '(let ((x 7)) x)) 7) - (check-equal? (run '(let ((x 7)) 2)) 2) - (check-equal? (run '(let ((x 7)) (add1 x))) 8) - (check-equal? (run '(let ((x (add1 7))) x)) 8) - (check-equal? (run '(let ((x 7)) (let ((y 2)) x))) 7) - (check-equal? (run '(let ((x 7)) (let ((x 2)) x))) 2) - (check-equal? (run '(let ((x 7)) (let ((x (add1 x))) x))) 8) - - (check-equal? (run '(let ((x 0)) - (if (zero? x) 7 8))) - 7) - (check-equal? (run '(let ((x 1)) - (add1 (if (zero? x) 7 8)))) - 9) - (check-equal? (run '(+ 3 4)) 7) - (check-equal? (run '(- 3 4)) -1) - (check-equal? (run '(+ (+ 2 1) 4)) 7) - (check-equal? (run '(+ (+ 2 1) (+ 2 2))) 7) - (check-equal? (run '(let ((x (+ 1 2))) - (let ((z (- 4 x))) - (+ (+ x x) z)))) - 7) - (check-equal? (run '(= 5 5)) #t) - (check-equal? (run '(= 4 5)) #f) - (check-equal? (run '(= (add1 4) 5)) #t) - (check-equal? (run '(< 5 5)) #f) - (check-equal? (run '(< 4 5)) #t) - (check-equal? (run '(< (add1 4) 5)) #f) - - ;; Hustle examples - (check-equal? (run ''()) '()) - (check-equal? (run '(box 1)) (box 1)) - (check-equal? (run '(box -1)) (box -1)) - (check-equal? (run '(cons 1 2)) (cons 1 2)) - (check-equal? (run '(unbox (box 1))) 1) - (check-equal? (run '(car (cons 1 2))) 1) - (check-equal? (run '(cdr (cons 1 2))) 2) - (check-equal? (run '(cons 1 '())) (list 1)) - (check-equal? (run '(let ((x (cons 1 2))) - (begin (cdr x) - (car x)))) - 1) - (check-equal? (run '(let ((x (cons 1 2))) - (let ((y (box 3))) - (unbox y)))) - 3) - (check-equal? (run '(eq? 1 1)) #t) - (check-equal? (run '(eq? 1 2)) #f) - (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f) - (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t) - - ;; Hoax examples - (check-equal? (run '(make-vector 0 0)) #()) - (check-equal? (run '(make-vector 1 0)) #(0)) - (check-equal? (run '(make-vector 3 0)) #(0 0 0)) - (check-equal? (run '(make-vector 3 5)) #(5 5 5)) - (check-equal? (run '(vector? (make-vector 0 0))) #t) - (check-equal? (run '(vector? (cons 0 0))) #f) - (check-equal? (run '(vector-ref (make-vector 0 #f) 0)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) -1)) 'err) - (check-equal? (run '(vector-ref (make-vector 3 5) 0)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 1)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 2)) 5) - (check-equal? (run '(vector-ref (make-vector 3 5) 3)) 'err) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 0 4) - x))) - #(4 5 5)) - (check-equal? (run '(let ((x (make-vector 3 5))) - (begin (vector-set! x 1 4) - x))) - #(5 4 5)) - (check-equal? (run '(vector-length (make-vector 3 #f))) 3) - (check-equal? (run '(vector-length (make-vector 0 #f))) 0) - (check-equal? (run '"") "") - (check-equal? (run '"fred") "fred") - (check-equal? (run '"wilma") "wilma") - (check-equal? (run '(make-string 0 #\f)) "") - (check-equal? (run '(make-string 3 #\f)) "fff") - (check-equal? (run '(make-string 3 #\g)) "ggg") - (check-equal? (run '(string-length "")) 0) - (check-equal? (run '(string-length "fred")) 4) - (check-equal? (run '(string-ref "" 0)) 'err) - (check-equal? (run '(string-ref (make-string 0 #\a) 0)) 'err) - (check-equal? (run '(string-ref "fred" 0)) #\f) - (check-equal? (run '(string-ref "fred" 1)) #\r) - (check-equal? (run '(string-ref "fred" 2)) #\e) - (check-equal? (run '(string-ref "fred" 4)) 'err) - (check-equal? (run '(string? "fred")) #t) - (check-equal? (run '(string? (cons 1 2))) #f) - (check-equal? (run '(begin (make-string 3 #\f) - (make-string 3 #\f))) - "fff") - - ;; Iniquity tests - (check-equal? (run - '(define (f x) x) - '(f 5)) - 5) - (check-equal? (run - '(define (tri x) - (if (zero? x) - 0 - (+ x (tri (sub1 x))))) - '(tri 9)) - 45) - - (check-equal? (run - '(define (f x) x) - '(define (g x) (f x)) - '(g 5)) - 5) - (check-equal? (run - '(define (my-even? x) - (if (zero? x) - #t - (my-odd? (sub1 x)))) - '(define (my-odd? x) - (if (zero? x) - #f - (my-even? (sub1 x)))) - '(my-even? 101)) - #f) - (check-equal? (run - '(define (map-add1 xs) - (if (empty? xs) - '() - (cons (add1 (car xs)) - (map-add1 (cdr xs))))) - '(map-add1 (cons 1 (cons 2 (cons 3 '()))))) - '(2 3 4)) - (check-equal? (run - '(define (f x) - 10) - '(f 1)) - 10) - (check-equal? (run - '(define (f x) - 10) - '(let ((x 2)) (f 1))) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(f 1 2)) - 10) - (check-equal? (run - '(define (f x y) - 10) - '(let ((z 2)) (f 1 2))) - 10) - - ;; Knock examples - (check-equal? (run '(match 1)) 'err) - (check-equal? (run '(match 1 [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2])) - 2) - (check-equal? (run '(match 1 [2 1] [1 2] [0 3])) - 2) - (check-equal? (run '(match 1 [2 1] [0 3])) - 'err) - (check-equal? (run '(match 1 [_ 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x 2] [_ 3])) - 2) - (check-equal? (run '(match 1 [x x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [x x] [_ 3])) - (cons 1 2)) - (check-equal? (run '(match (cons 1 2) [(cons x y) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons x 2) x] [_ 3])) - 1) - (check-equal? (run '(match (cons 1 2) [(cons 3 2) 0] [_ 3])) - 3) - (check-equal? (run '(match 1 [(cons x y) x] [_ 3])) - 3) - (check-equal? (run '(match (cons 1 2) [(cons 1 3) 0] [(cons 1 y) y] [_ 3])) - 2) - (check-equal? (run '(match (box 1) [(box 1) 0] [_ 1])) - 0) - (check-equal? (run '(match (box 1) [(box 2) 0] [_ 1])) - 1) - (check-equal? (run '(match (box 1) [(box x) x] [_ 2])) - 1) - - ;; Loot examples - (check-true (procedure? (run '(λ (x) x)))) - (check-equal? (run '((λ (x) x) 5)) - 5) - - (check-equal? (run '(let ((f (λ (x) x))) (f 5))) - 5) - (check-equal? (run '(let ((f (λ (x y) x))) (f 5 7))) - 5) - (check-equal? (run '(let ((f (λ (x y) y))) (f 5 7))) - 7) - (check-equal? (run '((let ((x 1)) - (let ((y 2)) - (lambda (z) (cons x (cons y (cons z '())))))) - 3)) - '(1 2 3)) - (check-equal? (run '(define (adder n) - (λ (x) (+ x n))) - '((adder 5) 10)) - 15) - (check-equal? (run '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36)) - 666) - (check-equal? (run '(define (tri n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))) - '(tri 36)) - 666) - (check-equal? (run '(define (tri n) - (match n - [0 0] - [m (+ m (tri (sub1 m)))])) - '(tri 36)) - 666) - (check-equal? (run '((match 8 [8 (lambda (x) x)]) 12)) - 12) - - ;; Mug examples - (check-equal? (run '(symbol? 'foo)) #t) - (check-equal? (run '(symbol? (string->symbol "foo"))) #t) - (check-equal? (run '(eq? 'foo 'foo)) #t) - (check-equal? (run '(eq? (string->symbol "foo") - (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'foo (string->symbol "foo"))) - #t) - (check-equal? (run '(eq? 'fff (string->symbol (make-string 3 #\f)))) - #t) - (check-equal? (run '(symbol? 'g0)) #t) - (check-equal? (run '(symbol? "g0")) #f) - (check-equal? (run '(symbol? (string->symbol "g0"))) #t) - (check-equal? (run '(symbol? (string->uninterned-symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->symbol "g0"))) #t) - (check-equal? (run '(eq? 'g0 (string->uninterned-symbol "g0"))) #f) - (check-equal? (run '(eq? (string->uninterned-symbol "g0") (string->uninterned-symbol "g0"))) - #f) - (check-equal? (run '(eq? (symbol->string 'foo) (symbol->string 'foo))) #f) - (check-equal? (run '(string? (symbol->string 'foo))) #t) - (check-equal? (run '(eq? (symbol->string 'foo) "foo")) #f) - (check-equal? (run ''foo) 'foo) - (check-equal? (run '(eq? (match #t [_ "foo"]) "bar")) #f) - (check-equal? (run '(eq? (match #t [_ 'foo]) 'bar)) #f) - (check-equal? (run '(match 'foo ['bar #t] [_ #f])) #f) - (check-equal? (run '(match 'foo ['foo #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["foo" #t] [_ #f])) #t) - (check-equal? (run '(match "foo" ["bar" #t] [_ #f])) #f) - (check-equal? (run '(match (cons '+ (cons 1 (cons 2 '()))) - [(cons '+ (cons x (cons y '()))) - (+ x y)])) - 3) - - ;; Mountebank examples - (check-equal? (run '#()) - #()) - (check-equal? (run ''#()) - #()) - (check-equal? (run ''#t) - #t) - (check-equal? (run ''7) - 7) - (check-equal? (run ''(1 2 3)) - '(1 2 3)) - (check-equal? (run ''(1 . 2)) - '(1 . 2)) - (check-equal? (run ''(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) - '(("1") (#() #(1 #(2))) (#&(1)) (#f) (4) (5))) - (check-equal? (run '(define (f) (cons 1 2)) - '(eq? (f) (f))) - #f) - (check-equal? (run '(define (f) '(1 . 2)) - '(eq? (f) (f))) - #t) - (check-equal? (run '(let ((x '(foo . foo))) - (eq? (car x) (cdr x)))) - #t) - (check-equal? - (run '(define (eval e r) - (match e - [(list 'zero? e) - (zero? (eval e r))] - [(list 'sub1 e) - (sub1 (eval e r))] - [(list '+ e1 e2) - (+ (eval e1 r) (eval e2 r))] - [(list 'if e1 e2 e3) - (if (eval e1 r) - (eval e2 r) - (eval e3 r))] - [(list 'λ (list x) e) - (lambda (v) (eval e (cons (cons x v) r)))] - [(list e1 e2) - ((eval e1 r) (eval e2 r))] - [_ - (if (symbol? e) - (lookup r e) - e)])) - '(define (lookup r x) - (match r - [(cons (cons y v) r) - (if (eq? x y) - v - (lookup r x))])) - '(eval '(((λ (t) - ((λ (f) (t (λ (z) ((f f) z)))) - (λ (f) (t (λ (z) ((f f) z)))))) - (λ (tri) - (λ (n) - (if (zero? n) - 0 - (+ n (tri (sub1 n))))))) - 36) - '())) - 666) - - ;; Neerdowell examples - (check-equal? (run '(struct foo ()) - '(foo? (foo))) - #t) - (check-equal? (run '(struct foo (x)) - '(foo? (foo 1))) - #t) - (check-equal? (run '(struct foo ()) - '(struct bar ()) - '(foo? (bar))) - #f) - (check-equal? (run '(struct foo ()) - '(struct bar ()) - '(bar? (bar))) - #t) - (check-equal? (run '(struct foo ()) - '(struct bar ()) - '(bar? #())) - #f) - (check-equal? (run '(struct foo (x)) - '(foo-x (foo 3))) - 3) - (check-equal? (run '(struct foo (x)) - '(let ((x (foo 3))) - (foo-x x))) - 3) - (check-equal? (run '(struct foo (x)) - '(let ((x (foo 3))) - (foo-x x))) - 3) - (check-equal? (run '(struct foo (x)) - '(let ((x (foo (foo 3)))) - (foo? (foo-x x)))) - #t) - (check-equal? (run '(struct foo (x y z)) - '(let ((x (foo 1 2 3))) - (cons (foo-x x) - (cons (foo-y x) - (cons (foo-z x) - '()))))) - '(1 2 3)) - (check-equal? (run '(struct foo ()) - '(eq? (foo) (foo))) - #f) - (check-equal? (run '(struct foo (x)) - '(foo-x #t)) - 'err) - (check-equal? (run '(struct foo (x)) - '(struct bar (y)) - '(match (bar 5) - [(foo x) #f] - [(bar x) x])) - 5) - (check-equal? (run '(struct nil ()) - '(struct pair (x y)) - '(define (len x) - (match x - [(nil) 0] - [(pair _ x) (add1 (len x))])) - '(len (pair 1 (pair 2 (pair 3 (nil)))))) - 3) - (check-equal? (run '(match (cons (cons 1 2) '()) - [(cons (cons x y) '()) y])) - 2) - (check-equal? (run '(struct foo (p q)) - '(match (cons (foo 1 2) '()) - [(cons (foo x y) _) y])) - 2) - (check-equal? (run '(struct foo (p q)) - '(match (cons (foo 1 2) '()) - [(cons (foo x 3) _) x] - [_ 9])) - 9) - (check-equal? (run '(struct foo (x q)) - '(define (get z) - (match z - ['() #f] - [(cons (foo x q) y) x])) - '(get (cons (foo 7 2) '()))) - 7) - (check-equal? (run '(struct posn (x y)) - '(define (posn-xs ps) - (match ps - ['() '()] - [(cons (posn x y) ps) - (cons x (posn-xs ps))])) - '(posn-xs (cons (posn 3 4) (cons (posn 5 6) (cons (posn 7 8) '()))))) - '(3 5 7)) - (check-equal? (run '(struct Foo (x y z)) - '(match (Foo 1 2 3) - [(Foo x y z) z])) - 3) - (check-equal? (run '(struct Boo (x)) - '(match 8 - [(Boo 'y) 0] - [_ 1])) - 1) - - ;; Outlaw examples - (check-equal? (run '(+)) 0) - (check-equal? (run '(+ 1 2 3)) 6) - (check-equal? (run '(< 1)) #t) - (check-equal? (run '(< 1 2 3)) #t) - (check-equal? (run '(< 1 3 3)) #f) - (check-equal? (run '(> 1)) #t) - (check-equal? (run '(> 3 2 1)) #t) - (check-equal? (run '(> 3 3 1)) #f) - (check-equal? (run '(<= 1)) #t) - (check-equal? (run '(<= 1 2 3)) #t) - (check-equal? (run '(<= 1 3 3)) #t) - (check-equal? (run '(<= 1 4 3)) #f) - (check-equal? (run '(>= 1)) #t) - (check-equal? (run '(>= 3 2 1)) #t) - (check-equal? (run '(>= 3 3 1)) #t) - (check-equal? (run '(>= 3 4 1)) #f) - (check-equal? (run '(list)) '()) - (check-equal? (run '(list 1 2 3)) '(1 2 3)) - (check-equal? (run '(map add1 (list 1 2 3))) '(2 3 4)) - (check-equal? (run '(map + (list 1 2 3) (list 4 5 6))) '(5 7 9)) - (check-equal? (run '(append)) '()) - (check-equal? (run '(append '(1 2 3))) '(1 2 3)) - (check-equal? (run '(append '(1 2 3) '())) '(1 2 3)) - (check-equal? (run '(append '() '(1 2 3))) '(1 2 3)) - (check-equal? (run '(append '(1 2 3) '(4 5 6))) '(1 2 3 4 5 6)) - (check-equal? (run '(memq 'x '())) #f) - (check-equal? (run '(memq 'x '(p x y))) '(x y)) - (check-equal? (run '(member 'x '() eq?)) #f) - (check-equal? (run '(member 'x '(p x y) eq?)) '(x y)) - (check-equal? (run '(append-map list '(1 2 3))) '(1 2 3)) - (check-equal? (run '(vector->list #())) '()) - (check-equal? (run '(vector->list #(1 2 3))) '(1 2 3)) - (check-equal? (run '(number->string 0)) "0") - (check-equal? (run '(number->string 10)) "10") - (check-equal? (run '(number->string 123)) "123") - (check-equal? (run '(number->string 0 10)) "0") - (check-equal? (run '(number->string 10 10)) "10") - (check-equal? (run '(number->string 123 10)) "123") - (check-equal? (run '(number->string 0 2)) "0") - (check-equal? (run '(number->string 1 2)) "1") - (check-equal? (run '(number->string 3 2)) "11") - (check-equal? (run '(number->string 8 2)) "1000") - (check-equal? (run '(number->string 0 8)) "0") - (check-equal? (run '(number->string 1 8)) "1") - (check-equal? (run '(number->string 3 8)) "3") - (check-equal? (run '(number->string 8 8)) "10") - (check-equal? (run '(number->string 0 16)) "0") - (check-equal? (run '(number->string 1 16)) "1") - (check-equal? (run '(number->string 3 16)) "3") - (check-equal? (run '(number->string 8 16)) "8") - (check-equal? (run '(number->string 10 16)) "a") - (check-equal? (run '(number->string 15 16)) "f") - (check-equal? (run '(number->string 16 16)) "10") - (check-pred symbol? (run '(gensym))) - (check-equal? (run '(eq? (gensym) (gensym))) #f) - (check-equal? (run '(let ((x (gensym))) (eq? x x))) #t) - (check-pred symbol? (run '(gensym 'fred))) - (check-equal? (run '(eq? (gensym 'fred) (gensym 'fred))) #f) - (check-equal? (run '(let ((x (gensym 'fred))) (eq? x x))) #t) - (check-pred symbol? (run '(gensym "fred"))) - (check-equal? (run '(eq? (gensym "fred") (gensym "fred"))) #f) - (check-equal? (run '(let ((x (gensym "fred"))) (eq? x x))) #t) - (check-equal? (run '(void? (void))) #t) - (check-equal? (run '(void? void)) #f) - (check-equal? (run '(eq? (void) (void))) #t) - (check-equal? (run '(bitwise-and #b111 #b000)) #b000) - (check-equal? (run '(bitwise-and #b111 #b111)) #b111) - (check-equal? (run '(bitwise-and #b101 #b100)) #b100) - (check-equal? (run '(bitwise-and #b001 #b100)) #b000) - (check-equal? (run '(bitwise-ior #b111 #b000)) #b111) - (check-equal? (run '(bitwise-ior #b111 #b111)) #b111) - (check-equal? (run '(bitwise-ior #b101 #b100)) #b101) - (check-equal? (run '(bitwise-ior #b001 #b100)) #b101) - (check-equal? (run '(bitwise-xor #b111 #b000)) #b111) - (check-equal? (run '(bitwise-xor #b111 #b111)) #b000) - (check-equal? (run '(bitwise-xor #b101 #b100)) #b001) - (check-equal? (run '(bitwise-xor #b001 #b100)) #b101) - (check-equal? (run '(arithmetic-shift 1 0)) 1) - (check-equal? (run '(arithmetic-shift 1 1)) 2) - (check-equal? (run '(arithmetic-shift 1 2)) 4) - (check-equal? (run '(arithmetic-shift 1 3)) 8) - (check-equal? (run '(arithmetic-shift 3 2)) 12) - (check-equal? (run '(or)) #f) - (check-equal? (run '(or #t)) #t) - (check-equal? (run '(or 7)) 7) - (check-equal? (run '(or 7 #t)) 7) - (check-equal? (run '(or #f #f #f)) #f) - (check-equal? (run '(or #f 7 9)) 7) - (check-equal? (run '(list->string '())) "") - (check-equal? (run '(list->string '(#\a #\b #\c))) "abc") - (check-equal? (run '(char<=? #\a)) #t) - (check-equal? (run '(char<=? #\a #\b)) #t) - (check-equal? (run '(char<=? #\a #\b #\c)) #t) - (check-equal? (run '(char<=? #\a #\b #\b)) #t) - (check-equal? (run '(char<=? #\a #\b #\a)) #f) - (check-equal? (run '(= (eq-hash-code 'x) (eq-hash-code 'x))) #t) - (check-equal? (run '(= (eq-hash-code 'x) (eq-hash-code 'y))) #f) - (check-equal? (run '(foldr + #f '())) #f) - (check-equal? (run '(foldr + 0 '(1 2 3))) 6) - (check-equal? (run '(list? '())) #t) - (check-equal? (run '(list? '(1 2 3))) #t) - (check-equal? (run '(list? (cons 1 2))) #f) - (check-equal? (run '(list? #t)) #f) - (check-equal? (run '(reverse '())) '()) - (check-equal? (run '(reverse '(1 2 3))) '(3 2 1)) - (check-equal? (run '(remove-duplicates '() eq?)) '()) - (check-equal? (run '(remove-duplicates '(1 2 3) eq?)) '(1 2 3)) - (check-equal? (run '(remove-duplicates '(1 2 3 2 1 3) eq?)) '(1 2 3)) - (check-equal? (run '(remove 'x '() eq?)) '()) - (check-equal? (run '(remove 'x '(x y z) eq?)) '(y z)) - (check-equal? (run '(remove 'x '(p q x r) eq?)) '(p q r)) - (check-equal? (run '(remove 'x '(p q x r x) eq?)) '(p q r x)) - (check-equal? (run '(remove* 'x '() eq?)) '()) - (check-equal? (run '(remove* 'x '(x y z) eq?)) '(y z)) - (check-equal? (run '(remove* 'x '(p q x r) eq?)) '(p q r)) - (check-equal? (run '(remove* 'x '(p q x r x) eq?)) '(p q r)) - (check-equal? (run '(remq* '(x y) '())) '()) - (check-equal? (run '(remq* '(x y) '(x y z))) '(z)) - (check-equal? (run '(remq* '(x y) '(p q x r x))) '(p q r)) - (check-equal? (run '(make-list 0 #\a)) '()) - (check-equal? (run '(make-list 3 #\a)) '(#\a #\a #\a)) - (check-equal? (run '(match 8 - [(? integer?) 1] - [_ 2])) - 1) - (check-equal? (run '(match 8 - [(? string?) 1] - [_ 2])) - 2) - (check-equal? (run '(match (cons 8 "8") - [(cons (? integer?) (? string?)) 1] - [_ 2])) - 1) - (check-equal? (run '(match 8 - [(? (lambda (x) (eq? x 8))) 1] - [_ 2])) - 1) - (check-equal? (run '(match 8 - [(? integer? x) x] - [_ 2])) - 8) - (check-equal? (run '(match (box #\a) - [(box (and x (? integer?))) 1] - [(box (and x (? char?))) x])) - #\a) - - (check-equal? (run '(vector)) #()) - (check-equal? (run '(vector 1 2 3)) #(1 2 3)) - (check-equal? (run '(list->vector '())) #()) - (check-equal? (run '(list->vector '(1 2 3))) #(1 2 3)) - (check-equal? (run '(boolean? #t)) #t) - (check-equal? (run '(boolean? #f)) #t) - (check-equal? (run '(boolean? 8)) #f) - (check-equal? (run '(substring "hello" 0)) "hello") - (check-equal? (run '(substring "hello" 1)) "ello") - (check-equal? (run '(substring "hello" 1 4)) "ell") - (check-equal? (run '(odd? 7)) #t) - (check-equal? (run '(odd? 8)) #f) - (check-equal? (run '(filter odd? '())) '()) - (check-equal? (run '(filter odd? '(1 2 3 4))) '(1 3)) - (check-equal? (run '(findf odd? '())) #f) - (check-equal? (run '(findf odd? '(2 4 3 7))) 3) - (check-equal? (run '(char-alphabetic? #\a)) #t) - (check-equal? (run '(char-alphabetic? #\space)) #f) - (check-equal? (run '(char-whitespace? #\a)) #f) - (check-equal? (run '(char-whitespace? #\space)) #t) - (check-equal? (run '(begin 1)) 1) - (check-equal? (run '(begin 1 2)) 2) - (check-equal? (run '(begin 1 2 3)) 3) - (check-equal? (run '(let () 1 2)) 2) - (check-equal? (run '(let ((x 1)) x x)) 1) - (check-equal? (run '(let ((x 1)) x x x)) 1) - (check-equal? (run '(match 1 [1 2 3])) 3) - (check-equal? (run '(system-type)) (system-type)) - (check-equal? (run '(struct Foo (x)) - '(struct Bar (y)) - '(match (Bar 1) - [(Foo x) #f] - [(Bar x) x])) - 1) - (check-equal? (run '(procedure? add1)) #t) - (check-equal? (run '(procedure? (lambda (x) x))) #t) - (check-equal? (run '(procedure? 8)) #f) - (check-equal? (run '(struct posn (x y)) - '(procedure? (posn 3 4))) - #f) - (check-equal? (run '(apply string-append (list "x"))) - "x") - - (check-equal? (run '(* 0 8)) 0) - (check-equal? (run '(* 1 8)) 8) - (check-equal? (run '(* 2 9)) 18) - (check-equal? (run '(* 2 -3)) -6) - (check-equal? (run '(* 4 3)) 12) - (check-equal? (run '(* 8 3)) 24) - (check-equal? (run '(* 16 2)) 32) - (check-equal? (run '(* 10 5)) 50) - (check-equal? (run '(* 64 2)) 128) - (check-equal? (run '(let ((pred (lambda (x) #t))) - (match 0 - [(and (? pred) _) #t] - [_ #f]))) - #t)) - - -(define (test-runner-io run) - ;; Evildoer examples - (check-equal? (run "" 7) (cons 7 "")) - (check-equal? (run "" '(write-byte 97)) (cons (void) "a")) - (check-equal? (run "a" '(read-byte)) (cons 97 "")) - (check-equal? (run "b" '(begin (write-byte 97) (read-byte))) - (cons 98 "a")) - (check-equal? (run "" '(read-byte)) (cons eof "")) - (check-equal? (run "" '(eof-object? (read-byte))) (cons #t "")) - (check-equal? (run "a" '(eof-object? (read-byte))) (cons #f "")) - (check-equal? (run "" '(begin (write-byte 97) (write-byte 98))) - (cons (void) "ab")) - (check-equal? (run "ab" '(peek-byte)) (cons 97 "")) - (check-equal? (run "ab" '(begin (peek-byte) (read-byte))) (cons 97 "")) - ;; Extort examples - (check-equal? (run "" '(write-byte #t)) (cons 'err "")) - - ;; Fraud examples - (check-equal? (run "" '(let ((x 97)) (write-byte x))) (cons (void) "a")) - (check-equal? (run "" - '(let ((x 97)) - (begin (write-byte x) - x))) - (cons 97 "a")) - (check-equal? (run "b" '(let ((x 97)) (begin (read-byte) x))) - (cons 97 "")) - (check-equal? (run "b" '(let ((x 97)) (begin (peek-byte) x))) - (cons 97 "")) - - ;; Hustle examples - (check-equal? (run "" - '(let ((x 1)) - (begin (write-byte 97) - 1))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x 1)) - (let ((y 2)) - (begin (write-byte 97) - 1)))) - (cons 1 "a")) - - (check-equal? (run "" - '(let ((x (cons 1 2))) - (begin (write-byte 97) - (car x)))) - (cons 1 "a")) - ;; Iniquity examples - (check-equal? (run "" - '(define (print-alphabet i) - (if (zero? i) - (void) - (begin (write-byte (- 123 i)) - (print-alphabet (sub1 i))))) - '(print-alphabet 26)) - (cons (void) "abcdefghijklmnopqrstuvwxyz")) - - ;; Outlaw examples - (check-equal? (run "" '(read-char)) - (cons eof "")) - (check-equal? (run "a" '(read-char)) - (cons #\a "")) - (check-equal? (run "ab" '(read-char)) - (cons #\a "")) - (check-equal? (run "ab" '(cons (read-char) (read-char))) - (cons '(#\a . #\b) "")) - (check-equal? (run "a" '(peek-byte (%current-input-port) 0)) - (cons 97 "")) - (check-equal? (run "ab" '(cons (peek-byte (%current-input-port) 1) (read-byte))) - (cons (cons 98 97) "")) - (check-equal? (run "abc" '(cons (peek-byte (%current-input-port) 2) - (cons (read-byte) (read-byte)))) - (cons (cons 99 (cons 97 98)) "")) - (check-equal? (run "a" '(peek-char)) - (cons #\a "")) - (check-equal? (run "ab" '(cons (peek-char) (peek-char))) - (cons '(#\a . #\a) "")) - (check-equal? (run "λ" '(peek-char)) - (cons #\λ "")) - (check-equal? (run "" '(write-char #\a)) - (cons (void) "a")) - (check-equal? (run "" '(write-char #\newline)) - (cons (void) "\n")) - (check-equal? (run "" '(write-string "hello world")) - (cons 11 "hello world")) - (check-equal? (run "" '(displayln "hello world")) - (cons (void) "hello world\n")) - )