├── .gitignore ├── GNUmakefile ├── README ├── LICENSE ├── main.rkt ├── doc ├── adqc.scrbl ├── stx.scrbl └── ast.scrbl ├── info.rkt ├── t ├── ttt.rkt ├── README ├── fib.rkt ├── calc.rkt ├── ringbuf.rkt ├── 2048.c ├── monaco.rkt ├── 2048.rkt └── main.rkt ├── util.rkt ├── util.h ├── module.rkt ├── exec.rkt ├── verify.rkt ├── print.rkt ├── linker.rkt ├── eval.rkt ├── ast.rkt ├── type.rkt └── compile.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | compiled/ 3 | t/2048.h 4 | t/2048 5 | -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | all: 2 | raco make *.rkt t/*.rkt 3 | raco test *.rkt t 4 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | adqc - A version of C with verification and resource bounds 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This code is available according to same terms as Racket: 2 | 3 | http://download.racket-lang.org/license.html 4 | 5 | Copyright © Jay McCarthy 6 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/require reprovide/reprovide) 3 | (reprovide 4 | (subtract-in "ast.rkt" "type.rkt") 5 | "type.rkt" 6 | "eval.rkt" 7 | "stx.rkt" 8 | "compile.rkt" 9 | "linker.rkt" 10 | "exec.rkt" 11 | "print.rkt" 12 | "util.rkt") 13 | (module reader syntax/module-reader 14 | adqc/module) 15 | -------------------------------------------------------------------------------- /doc/adqc.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/base 3 | scribble/manual 4 | (for-syntax racket/base racket/path) 5 | (for-label scribble/base)) 6 | 7 | @title[#:tag "adqc"]{adqc} 8 | 9 | @defmodule[adqc] 10 | 11 | This manual documents the @racketmodname[adqc] collection. 12 | 13 | @local-table-of-contents[#:style 'immediate-only] 14 | 15 | @include-section["stx.scrbl"] 16 | @include-section["ast.scrbl"] 17 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "adqc") 3 | (define deps '("reprovide-lang" 4 | "threading-lib" 5 | "graph" 6 | "pprint" 7 | "base")) 8 | (define build-deps '("chk-lib" 9 | "scribble-lib")) 10 | (define version "0.1") 11 | (define pkg-authors '(jeapostrophe)) 12 | (define compile-omit-paths '("v1" "v2" "v3")) 13 | (define scribblings '(("doc/adqc.scrbl" (multi-page) ("adqc")))) 14 | -------------------------------------------------------------------------------- /t/ttt.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | syntax/parse) 4 | adqc 5 | "monaco.rkt") 6 | 7 | (define ROWS 3) 8 | (define COLS 3) 9 | (define SLOTS (* ROWS COLS)) 10 | 11 | (define PLAYER-IDX 0) 12 | (define O-START (add1 PLAYER-IDX)) 13 | (define O-LEN SLOTS) 14 | (define X-START (+ O-START O-LEN 1)) 15 | (define X-LEN SLOTS) 16 | 17 | (define-T-expander State 18 | (syntax-parser [_ (syntax/loc this-syntax (T U32))])) 19 | (define-T-expander Board 20 | (syntax-parser [_ (syntax/loc this-syntax (T U16))])) 21 | -------------------------------------------------------------------------------- /t/README: -------------------------------------------------------------------------------- 1 | Things to implement: 2 | - Circular buffer 3 | - Heaps (& other binary trees on fixed arrays) 4 | - Search algorithms 5 | - NES audio synthesizer 6 | - MIC-1 simulator 7 | - Basic UNIX tools (less, editor, etc) 8 | - Simple Scheme implementation (CEK machine w/ stop & copy GC) 9 | - Entity Component System (like Artemis or EntityX) 10 | - FSM language (like Embeddr) 11 | - Libraries (OpenGL, libretro, raart, mode-lambda, lux) 12 | - Basic games (2048, Tetris, Tic-Tac-Toe, etc) 13 | - 2048 --- https://github.com/mevdschee/2048.c/blob/master/2048.c 14 | - Complex games (Shooter, Platformer, Pacman, etc) 15 | -------------------------------------------------------------------------------- /util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/file 4 | syntax/parse/define) 5 | 6 | (define-simple-macro (with-temp-files (c-path:id bin-path:id) body ...+) 7 | (let ([c-path (make-temporary-file "adqc~a.c")]) 8 | (with-handlers ([any/c (λ (e) (delete-file c-path) (raise e))]) 9 | (let ([bin-path (make-temporary-file "adqc~a")]) 10 | (with-handlers ([any/c (λ (e) (delete-file bin-path) (raise e))]) 11 | body ... 12 | (delete-file bin-path) 13 | (delete-file c-path)))))) 14 | 15 | (define (echo-port port [out (current-output-port)]) 16 | (for ([ch (in-port read-char port)]) 17 | (display ch out))) 18 | 19 | (define (snoc l x) (append l (list x))) 20 | 21 | (provide 22 | with-temp-files 23 | (contract-out 24 | [echo-port (->* (input-port?) (output-port?) void?)] 25 | [snoc (-> list? any/c list?)])) 26 | -------------------------------------------------------------------------------- /t/fib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require adqc) 3 | 4 | (define fib-p 5 | (Prog 6 | (define-fun S64 fib ([S64 n]) 7 | (define a : S64 := (S64 0)) 8 | (define b : S64 := (S64 1)) 9 | (define i : S64 := (S64 0)) 10 | (define tmp : S64) 11 | (while (islt i n) 12 | {tmp <- a} 13 | {a <- b} 14 | {b <- (iadd tmp b)} 15 | {i <- (iadd i (S64 1))}) 16 | a))) 17 | 18 | (define (rfib n) 19 | (for/fold ([a 0] [b 1] #:result a) 20 | ([i (in-range n)]) 21 | (values b (+ a b)))) 22 | 23 | (module+ test 24 | (require "main.rkt") 25 | (TProgN fib-p 26 | ["fib" (S64 0) => (S64 (rfib 0))] 27 | ["fib" (S64 1) => (S64 (rfib 1))] 28 | ["fib" (S64 2) => (S64 (rfib 2))] 29 | ["fib" (S64 3) => (S64 (rfib 3))] 30 | ["fib" (S64 4) => (S64 (rfib 4))] 31 | ["fib" (S64 5) => (S64 (rfib 5))] 32 | ["fib" (S64 6) => (S64 (rfib 6))] 33 | ["fib" (S64 7) => (S64 (rfib 7))] 34 | ["fib" (S64 8) => (S64 (rfib 8))])) 35 | -------------------------------------------------------------------------------- /util.h: -------------------------------------------------------------------------------- 1 | #ifndef ADQC_UTIL_H 2 | #define ADQC_UTIL_H 3 | 4 | #include 5 | #include 6 | 7 | static uint8_t cstr_first_char(const char* str) { return *str; } 8 | 9 | static int32_t print_string(const char* str, int32_t n) { 10 | return printf("%.*s", n, str); } 11 | 12 | static int32_t print_S8(int8_t n) { return printf("%hhd", n); } 13 | 14 | static int32_t print_U8(uint8_t n) { return printf("%hhu", n); } 15 | 16 | static int32_t print_S16(int16_t n) { return printf("%hd", n); } 17 | 18 | static int32_t print_U16(uint16_t n) { return printf("%hu", n); } 19 | 20 | static int32_t print_S32(int32_t n) { return printf("%d", n); } 21 | 22 | static int32_t print_U32(uint32_t n) { return printf("%u", n); } 23 | 24 | static int32_t print_S64(int64_t n) { return printf("%ld", n); } 25 | 26 | static int32_t print_U64(uint64_t n) { return printf("%lu", n); } 27 | 28 | static int32_t print_F32(float n) { return printf("%f", (double)n); } 29 | 30 | static int32_t printf_F64(double n) { return printf("%f", n); } 31 | 32 | #endif 33 | 34 | -------------------------------------------------------------------------------- /module.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require syntax/parse/define 3 | "exec.rkt" 4 | "stx.rkt" 5 | "util.rkt") 6 | 7 | ;; XXX support require 8 | ;; XXX fix syntax so that failures blame consuming module, not this one 9 | ;; XXX issue with '*' as command line argument? creates huge vector of useless stuff 10 | ;; XXX Some way to write tests for '#lang adqc' code without having a different 11 | ;; module? Maybe enabling @ reader can help with this? 12 | ;; XXX Disable REPL after running? Right now the user gets dumped into a racket/base 13 | ;; REPL after running, which is awkward/misleading. 14 | 15 | (define (run-module the-p) 16 | (with-temp-files (c-path bin-path) 17 | (define exe (make-executable the-p c-path bin-path)) 18 | (define (on-error e) 19 | (define in (open-input-file c-path)) 20 | (echo-port in (current-error-port)) 21 | (newline (current-error-port)) 22 | (raise e)) 23 | (with-handlers ([exn:fail? on-error]) 24 | (define args (vector->list (current-command-line-arguments))) 25 | (define stdout (apply executable-run exe args)) 26 | (echo-port stdout) 27 | (close-input-port stdout)))) 28 | 29 | (define-simple-macro (adqc-module-begin body ...+) 30 | (#%module-begin (run-module (Prog* body ...)))) 31 | 32 | (provide 33 | (all-from-out "stx.rkt") 34 | (except-out (all-from-out racket/base) #%module-begin) 35 | (rename-out [adqc-module-begin #%module-begin])) 36 | -------------------------------------------------------------------------------- /t/calc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require adqc 3 | racket/port) 4 | 5 | (define-simple-E-expander (C c) 6 | (E (U8 (char->integer c)))) 7 | 8 | (define main 9 | (F+ S32 ([S32 n1] [U8 op] [S32 n2]) 10 | (println 11 | (cond [(= op (C #\+)) (+ n1 n2)] 12 | [(= op (C #\-)) (- n1 n2)] 13 | [(= op (C #\*)) (* n1 n2)] 14 | [(= op (C #\/)) (/ n1 n2)] 15 | [else (error "invalid op\n")])) 16 | ;; XXX type can be inferred here? 17 | (S32 0))) 18 | 19 | (define calc (Prog (include-fun main))) 20 | 21 | (module+ test 22 | (require chk) 23 | (with-temp-files (c-path bin-path) 24 | (define exe (make-executable calc c-path bin-path)) 25 | (define (go args expect) 26 | (define output (apply executable-run exe args)) 27 | (define result (read output)) 28 | (close-input-port output) 29 | (chk result expect)) 30 | (define (!go args) 31 | (define result 32 | (with-handlers ([exn:fail? (λ (e) e)]) 33 | (define output 34 | (parameterize ([current-error-port (open-output-nowhere)]) 35 | (apply executable-run exe args))) 36 | (define r (read output)) 37 | (close-input-port output) 38 | r)) 39 | (chk #:? exn:fail? result)) 40 | (chk* 41 | (go '("2" "+" "3") 5) 42 | (go '("3" "-" "1") 2) 43 | (go '("2" "*" "4") 8) 44 | (go '("6" "/" "2") 3) 45 | (!go '("5" "x" "3")) 46 | ))) 47 | -------------------------------------------------------------------------------- /doc/stx.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label adqc 4 | racket/base 5 | racket/contract)) 6 | 7 | @title[#:tag "stx"]{Syntax} 8 | 9 | @(define the-eval (make-base-eval)) 10 | @(the-eval '(require adqc)) 11 | 12 | @defmodule[adqc/stx] 13 | 14 | @author[@author+email["Conor Finegan" "theconor4@gmail.com"]] 15 | 16 | Syntax and standard library functions for constructing @racketmodname[adqc] 17 | programs. 18 | 19 | @; XXX Put define-type, define-fun, define-global, define-prog, etc. together, 20 | @; or in their own sections? 21 | 22 | @section{Type Syntax} 23 | 24 | @defform[(T ty) 25 | #:grammar 26 | ([ty (array dim ty) 27 | (record f ty ... ...) 28 | (union m I)]) 29 | #:contracts ([dim exact-positive-integer?] 30 | [m symbol?])]{ 31 | Produces a @racket[Type] from @racket[ty]. 32 | } 33 | 34 | @section{Path Syntax} 35 | 36 | @section{Expression Syntax} 37 | 38 | @; XXX let, E-expander, E-free-syntax, unsyntax 39 | @defform[(E e) 40 | #:grammar 41 | ([e (bin-op e e) 42 | (e : ty) 43 | (if e e e) 44 | n 45 | p 46 | x]) 47 | #:contracts ([ty Type?] 48 | [n number?] 49 | [p Path?] 50 | [x symbol?])]{ 51 | Produces an @racket[Expr] from @racket[e]. 52 | } 53 | 54 | @section{Initializer Syntax} 55 | 56 | @section{Statement Syntax} 57 | 58 | @section{Function Syntax} 59 | -------------------------------------------------------------------------------- /t/ringbuf.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require adqc 3 | racket/contract/base) 4 | 5 | (struct ringbuf-spec (ty make push pop) #:transparent) 6 | 7 | (define (specify-ringbuf max-count ty) 8 | (define-type buf_t (array max-count #,ty)) 9 | (define-type ringbuf_t (record buf buf_t 10 | count U32 11 | inptr U32 12 | outptr U32)) 13 | (define-fun S32 make-ringbuf ([ringbuf_t rb] [buf_t arr]) 14 | (set! (rb -> buf) arr) 15 | (set! (rb -> count) 0) 16 | (set! (rb -> inptr) 0) 17 | (set! (rb -> outptr) 0) 18 | (return 0)) 19 | (define-fun S32 ringbuf-push ([ringbuf_t rb] [#,ty v]) 20 | (cond [(= (rb -> count) (U32 max-count)) 21 | (return -1)] 22 | [else 23 | (define buf := (rb -> buf)) 24 | (set! (buf @ (rb -> inptr)) v) 25 | (+=1 (rb -> inptr)) 26 | (%= (rb -> inptr) (U32 max-count)) 27 | (+=1 (rb -> count)) 28 | (return 0)])) 29 | ;; XXX It would be nice to have syntax that made returning values 30 | ;; through reference arguments more ergonomic. 31 | (define-fun S32 ringbuf-pop ([ringbuf_t rb] [#:ref #,ty out]) 32 | (cond [(zero? (rb -> count)) 33 | (return -1)] 34 | [else 35 | (define buf := (rb -> buf)) 36 | (set! out (buf @ (rb -> outptr))) 37 | (+=1 (rb -> outptr)) 38 | (%= (rb -> outptr) (U32 max-count)) 39 | (-=1 (rb -> count)) 40 | (return 0)])) 41 | (ringbuf-spec ringbuf_t make-ringbuf ringbuf-push ringbuf-pop)) 42 | 43 | (provide 44 | (contract-out 45 | [specify-ringbuf (-> exact-nonnegative-integer? Type? ringbuf-spec?)] 46 | [struct ringbuf-spec ([ty Type?] [make Fun?] [push Fun?] [pop Fun?])])) 47 | 48 | (module+ test 49 | (require chk racket/match) 50 | (match-define (ringbuf-spec ringbuf_t make-ringbuf ringbuf-push ringbuf-pop) 51 | (specify-ringbuf 10 (T S32))) 52 | (define-prog p 53 | (include-fun make-ringbuf) 54 | (include-fun ringbuf-push) 55 | (include-fun ringbuf-pop)) 56 | (with-temp-files (c-path bin-path) 57 | (define lp (link-program p c-path bin-path)) 58 | (define (lp-alloc ty) (linked-program-alloc lp ty)) 59 | (define buf (lp-alloc (T (array 10 S32)))) 60 | (define rb (lp-alloc ringbuf_t)) 61 | (define i (lp-alloc (T S32))) 62 | (chk* 63 | (chk (linked-program-run lp "make_ringbuf" (list rb buf)) 0) 64 | (chk (linked-program-run lp "ringbuf_push" (list rb 5)) 0) 65 | (chk (linked-program-run lp "ringbuf_pop" (list rb i)) 0) 66 | (chk (linked-program-read lp i) 5) 67 | (chk (linked-program-run lp "ringbuf_pop" (list rb i)) -1) 68 | ))) 69 | -------------------------------------------------------------------------------- /exec.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/list 4 | racket/match 5 | racket/port 6 | racket/require 7 | racket/runtime-path 8 | (subtract-in "ast.rkt" "type.rkt") 9 | "compile.rkt" 10 | "stx.rkt" 11 | "type.rkt" 12 | "util.rkt") 13 | 14 | (define char* (ExtT (ExternSrc '() '()) "char*")) 15 | (define stdlib-h (ExternSrc '() '("stdlib.h"))) 16 | 17 | (define-runtime-path util-path "util.h") 18 | (define util-h (ExternSrc '() (list (path->string util-path)))) 19 | 20 | (define (ty->ExtFun ty) 21 | (match ty 22 | [(FloT 64) 23 | (ExtFun stdlib-h (list (Arg 'str char* 'read-only)) ty "atof")] 24 | [(IntT #f 8) 25 | (ExtFun util-h (list (Arg 'str char* 'read-only)) ty "cstr_first_char")] 26 | [(IntT #t 32) 27 | (ExtFun stdlib-h (list (Arg 'str char* 'read-only)) ty "atoi")] 28 | [(IntT #t 64) 29 | (ExtFun stdlib-h (list (Arg 'str char* 'read-only)) ty "atol")])) 30 | 31 | (define (wrap-main main) 32 | (define args (Fun-args main)) 33 | (define nargs (length args)) 34 | (define tys (map Arg-ty args)) 35 | (define fns (map ty->ExtFun tys)) 36 | (define arg-xs (map gensym (make-list nargs 'arg))) 37 | (F S32 ([S32 argc] [(array (add1 nargs) #,char*) argv]) 38 | (assert! #:dyn #:msg (format "exactly ~a arguments supplied" nargs) 39 | (ieq argc (S32 (add1 nargs)))) 40 | #,(let ([user-call 41 | (S (let ([x := main <- #,@(for/list ([x (in-list arg-xs)] 42 | [ty (in-list tys)]) 43 | (Var x ty))]) 44 | (return x)))]) 45 | (for/fold ([body user-call]) 46 | ([ty (in-list tys)] 47 | [fn (in-list fns)] 48 | [x (in-list arg-xs)] 49 | [i (in-naturals 1)]) 50 | (Call x ty fn (list (E (argv @ (S32 i)))) body))))) 51 | 52 | (struct executable (bin-path) #:transparent) 53 | 54 | (define (make-executable prog c-path bin-path) 55 | (define n->f (hash-copy (Program-name->fun prog))) 56 | (hash-set! n->f "main" (wrap-main (hash-ref n->f "main"))) 57 | (define prog* (struct-copy Program prog [name->fun n->f])) 58 | (unless (compile-exe prog* c-path bin-path) 59 | (newline (current-error-port)) 60 | (define in (open-input-file c-path)) 61 | (echo-port in (current-error-port)) 62 | (close-input-port in) 63 | (error "call to compile-exe failed (see stderr)")) 64 | (executable bin-path)) 65 | 66 | (define (executable-run exe . args) 67 | (define bin-path (executable-bin-path exe)) 68 | (define-values (sp stdout stdin stderr) 69 | (apply subprocess #f #f #f bin-path args)) 70 | (close-output-port stdin) 71 | (subprocess-wait sp) 72 | (define st (subprocess-status sp)) 73 | (unless (zero? st) 74 | (displayln (port->string stderr #:close? #t) (current-error-port)) 75 | (error 'executable-run "executable failed with exit status ~a (see stderr)" st)) 76 | (close-input-port stderr) 77 | stdout) 78 | 79 | (provide 80 | (contract-out 81 | [struct executable ([bin-path path?])] 82 | [make-executable (-> Program? path? path? executable?)] 83 | [executable-run (->* [executable?] #:rest (listof string?) any/c)])) 84 | -------------------------------------------------------------------------------- /t/2048.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | #include "2048.h" 11 | 12 | // XXX Some way to generate this from racket code? 13 | #define SIZE 4 14 | 15 | uint8_t scheme = 0; 16 | 17 | void get_color(uint8_t value, char *color, size_t length) { 18 | uint8_t original[] = 19 | {8,255,1,255,2,255,3,255,4,255,5,255,6,255,7,255, 20 | 9,0,10,0,11,0,12,0,13,0,14,0,255,0,255,0}; 21 | uint8_t blackwhite[] = 22 | {232,255,234,255,236,255,238,255,240,255,242,255, 23 | 244,255,246,0,248,0,249,0,250,0,251,0,252,0,253,0,254,0,255,0}; 24 | uint8_t bluered[] = 25 | {235,255,63,255,57,255,93,255,129,255,165,255,201,255,200,255,199, 26 | 255,198,255,197,255,196,255,196,255,196,255,196,255,196,255}; 27 | uint8_t *schemes[] = {original,blackwhite,bluered}; 28 | uint8_t *background = schemes[scheme]+0; 29 | uint8_t *foreground = schemes[scheme]+1; 30 | if (value > 0) { 31 | while (value--) { 32 | if (background + 2 < schemes[scheme] + sizeof(original)) { 33 | background+=2; 34 | foreground+=2; }}} 35 | snprintf(color,length,"\033[38;5;%d;48;5;%dm",*foreground,*background); } 36 | 37 | void set_buffered_input(int32_t enable) { 38 | static int32_t enabled = 1; 39 | static struct termios old; 40 | struct termios term; 41 | if (enable && !enabled) { 42 | tcsetattr(STDIN_FILENO, TCSANOW, &old); 43 | enabled = 1; } 44 | else if (!enable && enabled) { 45 | tcgetattr(STDIN_FILENO, &term); 46 | old = term; 47 | term.c_lflag &= (~ICANON & ~ECHO); 48 | tcsetattr(STDIN_FILENO, TCSANOW, &term); 49 | enabled = 0; }} 50 | 51 | void sigint_handler(int32_t sig) { 52 | printf(" TERMINATED \n"); 53 | set_buffered_input(1); 54 | printf("\033[?25h\033[m"); 55 | exit(sig); } 56 | 57 | void register_sigint() { 58 | struct sigaction act; 59 | act.sa_handler = sigint_handler; 60 | sigemptyset(&act.sa_mask); 61 | act.sa_flags = 0; 62 | if (sigaction(SIGINT, &act, NULL) == -1) { 63 | perror("sigaction"); 64 | exit(1); }} 65 | 66 | void draw_board(Board board) { 67 | uint8_t x, y; 68 | char color[40], reset[] = "\033[m"; 69 | printf("\033[H"); 70 | printf("2048.c %17d pts\n\n", score); 71 | for (y = 0; y < SIZE; ++y) { 72 | for (x = 0; x < SIZE; ++x) { 73 | get_color(board[x][y], color, 40); 74 | printf("%s", color); 75 | printf(" "); 76 | printf("%s", reset); } 77 | printf("\n"); 78 | for (x = 0; x < SIZE; ++x) { 79 | get_color(board[x][y], color, 40); 80 | printf("%s", color); 81 | if (board[x][y] != 0) { 82 | char s[8]; 83 | snprintf(s, 8, "%u", (uint32_t)1 << board[x][y]); 84 | uint8_t t = 7 - strlen(s); 85 | printf("%*s%s%*s", (t - t / 2), "", s, (t / 2), ""); } 86 | else { 87 | printf(" · "); } 88 | printf("%s", reset); } 89 | printf("\n"); 90 | for (x = 0; x < SIZE; ++x) { 91 | get_color(board[x][y], color, 40); 92 | printf("%s", color); 93 | printf(" "); 94 | printf("%s", reset); } 95 | printf("\n"); } 96 | printf("\n"); 97 | printf(" ←,↑,→,↓ or q \n"); 98 | printf("\033[A"); } // one line up 99 | 100 | // XXX Generate buffer space from racket code 101 | uint8_t rows[4][4]; 102 | uint8_t* board[4]; 103 | 104 | int32_t main(int32_t argc, char* argv[]) { 105 | srand(time(NULL)); 106 | printf("\033[?25l\033[2J"); 107 | register_sigint(); 108 | set_buffered_input(0); 109 | // XXX Do this better 110 | make_board(board, rows[0], rows[1], rows[2], rows[3]); 111 | 112 | init_board(board); 113 | draw_board(board); 114 | 115 | while (1) { 116 | char c = getchar(); 117 | if (c == -1) { 118 | puts("\nError! Cannot read keyboard input!"); } 119 | 120 | else if (c == 'q') { 121 | printf(" QUIT? (y/n) \n"); 122 | c = getchar(); 123 | if (c == 'y') { 124 | break; } 125 | draw_board(board); } 126 | 127 | else if (c == 'r') { 128 | printf(" RESTART? (y/n) \n"); 129 | c = getchar(); 130 | if (c == 'y') { 131 | init_board(board); } 132 | draw_board(board); } 133 | 134 | else { 135 | uint8_t success = step(board, c); 136 | if (success) { 137 | draw_board(board); 138 | usleep(150000); 139 | add_random(board); 140 | draw_board(board); 141 | if (game_ended(board)) { 142 | printf(" GAME OVER \n"); 143 | // XXX Need break? 144 | break; }}}} 145 | 146 | set_buffered_input(1); 147 | printf("\033[?25h\033[m"); 148 | return 0; } 149 | -------------------------------------------------------------------------------- /verify.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/match 4 | "ast.rkt" 5 | "stx.rkt") 6 | 7 | (define (True? x) 8 | (E (ine (U32 0) #,x))) 9 | 10 | (define (And L R) 11 | (E (iand #,(True? L) #,(True? R)))) 12 | 13 | (define (Or L R) 14 | (E (ior #,(True? L) #,(True? R)))) 15 | 16 | (define (Not e) 17 | (E (ieq (U32 0) #,e))) 18 | 19 | (define (Implies a b) 20 | (Or (Not a) b)) 21 | 22 | ;; XXX annoying that we have to know which are functions and which are 23 | ;; not 24 | 25 | (define (weakest-precond stmt post-cond) 26 | (match stmt 27 | [(Skip _) post-cond] 28 | [(Fail _) (Int #f 32 0)] 29 | [(Assign (Var x _) e) 30 | (subst x e post-cond)] 31 | [(Begin L-stmt R-stmt) 32 | (define post-cond* (weakest-precond R-stmt post-cond)) 33 | (weakest-precond L-stmt post-cond*)] 34 | [(If pred then else) 35 | (And (Implies pred 36 | (weakest-precond else post-cond)) 37 | (Implies (Not pred) 38 | (weakest-precond then post-cond)))] 39 | [(MetaS (cons 'while-invariant invar) (While pred do-stmt)) 40 | (And invar 41 | (And (Implies (And pred invar) 42 | (weakest-precond do-stmt invar)) 43 | (Implies (And (Not pred) invar) 44 | post-cond)))] 45 | [(Jump label) 46 | (Var label)] 47 | [(Let/ec label stmt) 48 | (subst label post-cond (weakest-precond stmt post-cond))])) 49 | 50 | (define (subst x v e) 51 | (define (rec e) (subst x v e)) 52 | (match e 53 | [(Var (== x) _) v] 54 | [(or (? Var?) (? Int?) (? Flo?)) e] 55 | [(BinOp op L R) 56 | (BinOp op (rec L) (rec R))])) 57 | 58 | ;; XXX strongest postcondition 59 | ;; 60 | ;; How to deal with Return? I think you compute the post-condition as 61 | ;; you go and the recursive call gives you the main post-cond, plus a 62 | ;; list of post-conds for each label and you OR them together. 63 | ;; 64 | ;; https://www.risc.jku.at/education/oldmoodle/file.php/22/slides/02-hoare.pdf 65 | 66 | (define (strongest-postcond stmt pre-cond) 67 | (match stmt 68 | [(Skip _) pre-cond] 69 | ;; xxx: Should this actually be false? 70 | [(Fail _) (Int #f 32 1)] 71 | [(Assign (Var x _) e) 72 | (subst e x pre-cond)] 73 | [(Begin f s) 74 | (define pre-cond* (strongest-postcond f pre-cond)) 75 | (strongest-postcond s pre-cond*)] 76 | [(If pred then else) 77 | (And (Implies pred 78 | (strongest-postcond then pre-cond)) 79 | (Implies (Not pred) 80 | (strongest-postcond else pre-cond)))] 81 | [(MetaS (cons 'while-invariant I) (While p body)) 82 | (And pre-cond (Not p))] 83 | )) 84 | 85 | 86 | ;; XXX verify! function that compiler needs (notes about it here:) 87 | 88 | ;; As we are compiling, we could compute the strongest 89 | ;; post-condition (SP) of the code that came before this point and 90 | ;; then check the theorem (not (SP => P)) for UNSAT. If it is SAT, 91 | ;; then the condition is not verified (#f), if it is UNSAT, then the 92 | ;; condition is checked. 93 | ;; 94 | ;; It is awkard to have the compiler interact with the theorem 95 | ;; prover this way though, particularly having to compute the SP. So 96 | ;; another idea is to have the verifier run first and return a weak 97 | ;; hash-table mapping each precondition to whether it can be SAT or 98 | ;; NOT in this way, then compiler can consult the table. 99 | ;; 100 | ;; Alternatively, verify! could be a Program -> Program function 101 | ;; that simply removes the Asserts as it verifies them and the 102 | ;; compiler always treats them as comments... I think that may be 103 | ;; the most beautiful way, but it will take a lot of allocation, :( 104 | ;; That could actually be quite cool, because may it could also use 105 | ;; the SP to do optimization and constant propagation of something 106 | ;; like that. 107 | 108 | ;; eval 109 | #;[(Assert _ p msg) 110 | (or (and (eval-expr-pred σ p) σ) 111 | (error 'Assert "Failed assertion: ~e" msg))] 112 | 113 | ;; compile 114 | #;[(Assert must-be-static? p msg) 115 | (list* "/* ASSERT " msg ": " (compile-expr ρ p) " */" ind-nl 116 | (cond 117 | [(verify! p) 118 | "/* Statically verified! */"] 119 | [(not must-be-static?) 120 | (compile-stmt γ ρ (If p (Skip) (Fail (~a "Assertion failed: " msg))))] 121 | [else 122 | (error 'compile "Assertion not verifiable statically: ~a" msg)]))] 123 | 124 | ;;;; Interval Arithmetic 125 | (struct ival (l e h) #:transparent) 126 | (define (iunit x) (ival x x x)) 127 | (define (ival+ x y) 128 | (match-define (ival lx ex hx) x) 129 | (match-define (ival ly ey hy) y) 130 | (ival (+ lx ly) (+ ex ey) (+ hx hy))) 131 | (define (ivalU P x y) 132 | (match-define (ival lx ex hx) x) 133 | (match-define (ival ly ey hy) y) 134 | (ival (min lx ly) 135 | (+ (* P ex) (* (- 1 P) ey)) 136 | (max hx hy))) 137 | (define (ival*k l e h x) 138 | (match-define (ival lx ex hx) x) 139 | (ival (* l lx) (* e ex) (* h hx))) 140 | ;;;; / Interval Arithmetic 141 | 142 | ;; XXX Bound the trips through Whiles 143 | 144 | ;; XXX Some way to enforce that a value is looked at (could be a 145 | ;; generalization of ReadOnly?) 146 | -------------------------------------------------------------------------------- /t/monaco.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | syntax/parse) 4 | adqc 5 | racket/contract/base 6 | racket/match) 7 | 8 | #| 9 | (adqc-interface game 10 | (type actor) 11 | (type state) 12 | (type action) 13 | (fun bool terminal_p (state))) 14 | 15 | (adqc-module game (ttt) 16 | (implements game) 17 | (define-type actor int64)) 18 | 19 | (adqc-module exe (monaco game) 20 | ....) 21 | 22 | (adqc-compile (monaco (ttt))) 23 | |# 24 | 25 | (struct game (state-ty action-ty actor-ty legal?-fn) #:transparent) 26 | 27 | (define (monaco g) 28 | (match-define (game state-ty action-ty actor-ty legal?) g) 29 | (define-T-expander State (syntax-parser [_ #'state-ty])) 30 | (define-T-expander Action (syntax-parser [_ #'action-ty])) 31 | (define-T-expander Actor (syntax-parser [_ #'actor-ty])) 32 | 33 | (define-global STUNTING := (U8 0)) 34 | (define-global debug? := (U8 0)) 35 | 36 | ;; XXX decode-action-keys - how to pull max_key up to compile level? 37 | 38 | (define node-ptr-bits 16) 39 | (define node-ptr-signed? #f) 40 | (define the-node-ptr-ty (IntT node-ptr-signed? node-ptr-bits)) 41 | (define-T-expander NodePtr (syntax-parser [_ #'the-node-ptr-ty])) 42 | (define the-null-node-expr (Int node-ptr-signed? node-ptr-bits 0)) 43 | (define-E-expander NULL-NODE (syntax-parser [_ #'the-null-node-expr])) 44 | 45 | (define POOL-SIZE (sub1 (expt 2 node-ptr-bits))) 46 | (define SIMULATIONS-PER-ITERATION 4) 47 | (define MIN-ITERS (/ POOL-SIZE SIMULATIONS-PER-ITERATION)) 48 | 49 | (define-type Node 50 | (record w F32 ;; wins 51 | v U32 ;; visits 52 | pr NodePtr ;; parent 53 | lc NodePtr ;; left child 54 | rs NodePtr ;; right sibling 55 | pq NodePtr ;; prev in queue 56 | nq NodePtr ;; next in queue 57 | ia Action ;; initiating action 58 | na Action ;; next action to expand 59 | wh Action)) ;; who is acting 60 | 61 | (define-global NODE : Node := #,(ZedI (T Node))) 62 | (define-global free-ptr := NULL-NODE) 63 | (define-global node-count := (U32 0)) 64 | (define-global recycled := (U32 0)) 65 | (define-global θ-head := NULL-NODE) 66 | 67 | (define-fun void θ-insert ([NodePtr x]) 68 | (assert! #:dyn (!= (NODE @ x -> nq) NULL-NODE)) 69 | (assert! #:dyn (!= (NODE @ x -> pq) NULL-NODE)) 70 | (cond [(= θ-head NULL-NODE) 71 | (set! (NODE @ x -> pq) x) 72 | (set! (NODE @ x -> nq) x)] 73 | [else 74 | (assert! #:dyn (!= (NODE @ θ-head -> nq) NULL-NODE)) 75 | (assert! #:dyn (!= (NODE @ θ-head -> pq) NULL-NODE)) 76 | (set! (NODE @ x -> nq) θ-head) 77 | (set! (NODE @ x -> pq) (NODE @ θ-head -> nq)) 78 | (set! (NODE @ (NODE @ θ-head -> pq) -> nq) x) 79 | (set! (NODE @ θ-head -> pq) x)]) 80 | (assert! #:dyn (!= (NODE @ x -> nq) NULL-NODE)) 81 | (assert! #:dyn (!= (NODE @ x -> pq) NULL-NODE)) 82 | (set! θ-head x)) 83 | 84 | (define-fun void θ-remove ([NodePtr x]) 85 | (define nq := (NODE @ x -> nq)) 86 | (define pq := (NODE @ x -> pq)) 87 | (set! (NODE @ x -> nq) NULL-NODE) 88 | (set! (NODE @ x -> nq) NULL-NODE) 89 | (cond [(= nq x) 90 | (assert! #:dyn (= pq x)) 91 | (assert! #:dyn (= θ-head x)) 92 | (set! θ-head NULL-NODE)] 93 | [else 94 | (set! (NODE @ pq -> nq) nq) 95 | (set! (NODE @ nq -> pq) pq) 96 | (when (= θ-head x) 97 | (set! θ-head nq))]) 98 | (assert! #:dyn (= (NODE @ x -> nq) NULL-NODE)) 99 | (assert! #:dyn (= (NODE @ x -> pq) NULL-NODE))) 100 | 101 | (define (make-do-children fn) 102 | (F void ([NodePtr pr]) 103 | (define c := (NODE @ pr -> lc)) 104 | (while (!= c NULL-NODE) 105 | (define void1 := fn <- c) 106 | (set! c (NODE @ c -> rs))))) 107 | (define do-children-insert (make-do-children θ-insert)) 108 | (define do-children-remove (make-do-children θ-remove)) 109 | 110 | ;; XXX dg_edge, dg_topoprint, dump_graph 111 | 112 | (define-fun void initialize-pool () 113 | (define last := NULL-NODE) 114 | (for ([n : NodePtr := (U32 1)] (< n (U32 POOL-SIZE)) (+=1 n)) 115 | (set! (NODE @ n -> rs) (add1 n)) 116 | (set! last n)) 117 | (set! (NODE @ last -> rs) NULL-NODE) 118 | (set! free-ptr (U32 1))) 119 | 120 | (define-fun Action next-legal ([State st] [Action prev]) 121 | (while (S32 1) 122 | (cond [(zero? prev) 123 | (return 0)] 124 | [else 125 | (-=1 prev) 126 | (define is-legal? := legal? <- st prev) 127 | (when is-legal? 128 | (return (add1 prev)))]))) 129 | 130 | (define-fun void free-node ([NodePtr n]) 131 | (-=1 node-count) 132 | (assert! #:dyn (= (NODE @ n -> pq) NULL-NODE)) 133 | (assert! #:dyn (= (NODE @ n -> nq) NULL-NODE)) 134 | (assert! #:dyn (= (NODE @ n -> pr) NULL-NODE)) 135 | (assert! #:dyn (= (NODE @ n -> lc) NULL-NODE)) 136 | (assert! #:dyn (= (NODE @ n -> rs) NULL-NODE)) 137 | (set! (NODE @ n -> rs) free-ptr) 138 | (set! free-ptr n)) 139 | 140 | ;; XXX free-node-rec without recursion 141 | 142 | (define-fun void recycle ([NodePtr curr]) 143 | (define last := (NODE @ θ-head -> pq)) 144 | (when (= last NULL-NODE) 145 | ;; no last 146 | (return)) 147 | (define pr := (NODE @ last -> pr)) 148 | (when (= pr NULL-NODE) 149 | ;; last has no parent 150 | (return)) 151 | (+=1 recycled) 152 | (define c := (NODE @ pr -> lc)) 153 | (assert! #:dyn (!= c NULL-NODE)) 154 | (set! (NODE @ pr -> na) (add1 (NODE @ c -> ia))) 155 | (set! (NODE @ pr -> lc) (NODE @ c -> rs)) 156 | (set! (NODE @ c -> rs) NULL-NODE) 157 | ;; XXX free-node-rec(c) 158 | ) 159 | 160 | (define-fun NodePtr alloc-node ([NodePtr parent] [Actor lastp] [Action ia] [State st]) 161 | (+=1 node-count) 162 | (define new := free-ptr) 163 | (when (= new NULL-NODE) 164 | (define void1 := recycle <- parent) 165 | (set! new free-ptr) 166 | (when (= new NULL-NODE) 167 | ;; XXX dump_graph ? 168 | (error "alloc-node: out of meemory")))) 169 | ) 170 | 171 | (provide 172 | (contract-out 173 | [monaco (-> game? Program?)] 174 | [struct game ([state-ty non-void-type?] 175 | [action-ty non-void-type?] 176 | [actor-ty non-void-type?] 177 | [legal?-fn Fun?])])) 178 | -------------------------------------------------------------------------------- /print.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (except-in pprint empty) 3 | racket/contract/base 4 | racket/list 5 | racket/match 6 | "ast.rkt") 7 | 8 | (define (sym s) (text (symbol->string s))) 9 | (define (num n) (text (number->string n))) 10 | 11 | (define (type-doc ty) 12 | (match ty 13 | [(IntT signed? bits) 14 | (define ch (if signed? #\S #\U)) 15 | (h-append (char ch) (num bits))] 16 | [(FloT bits) 17 | (h-append (char #\F) (num bits))] 18 | [(ArrT dim ety) 19 | (h-append (text "(array ") (num dim) space (type-doc ety) rparen)] 20 | [(RecT f->ty _ c-order) 21 | (define f-docs 22 | (for/list ([f (in-list c-order)]) 23 | (hs-append (sym f) (type-doc (hash-ref f->ty f))))) 24 | (h-append (text "(record ") (apply hs-append f-docs) rparen)] 25 | [(UniT m->ty _) 26 | (define m-docs 27 | (for/list ([(m ty) (in-hash m->ty)]) 28 | (hs-append (sym m) (type-doc ty)))) 29 | (h-append (text "(union ") (apply hs-append m-docs) rparen)] 30 | [(ExtT _ name) (text name)] 31 | [(? VoiT?) (text "void")] 32 | [(? AnyT?) (text "any")])) 33 | 34 | (define (path-doc p) 35 | (match (unpack-MetaP p) 36 | [(Var x _) (sym x)] 37 | [(Global ty xi) 38 | (define g-name (given-name p)) 39 | (if g-name 40 | (sym g-name) 41 | (group 42 | (h-append 43 | lparen 44 | (nest 2 (v-append (text "Global") (type-doc ty) (init-doc xi))) 45 | rparen)))] 46 | [(Select p ie) 47 | (h-append lparen (path-doc p) (text " @ ") (expr-doc ie) rparen)] 48 | [(Field p f) 49 | (h-append lparen (path-doc p) (text " -> ") (sym f) rparen)] 50 | [(Mode p m) 51 | (h-append lparen (path-doc p) (text " as ") (sym m) rparen)] 52 | [(ExtVar _ name _) (text name)])) 53 | 54 | (define (expr-doc e) 55 | (match (unpack-MetaE e) 56 | [(Int signed? bits val) 57 | (define ty (IntT signed? bits)) 58 | (h-append lparen (type-doc ty) space (num val) rparen)] 59 | [(Flo bits val) 60 | (define ty (FloT bits)) 61 | (h-append lparen (type-doc ty) space (num val) rparen)] 62 | [(Cast ty e) 63 | (h-append lparen (expr-doc e) space colon space (type-doc ty) rparen)] 64 | [(Read p) (path-doc p)] 65 | [(BinOp op L R) 66 | (group 67 | (h-append 68 | lparen 69 | (nest 2 (v-append (sym op) (expr-doc L) (expr-doc R))) 70 | rparen))] 71 | [(LetE x _ xe be) 72 | (define decl 73 | (h-append (text "LetE ([") (sym x) space (expr-doc xe) (text "])"))) 74 | (group (h-append lparen (nest 2 (v-append decl (expr-doc be))) rparen))] 75 | [(IfE ce te fe) 76 | (group 77 | (h-append 78 | lparen 79 | (nest 2 (v-append (hs-append (text "IfE") (expr-doc ce)) 80 | (expr-doc te) (expr-doc fe))) 81 | rparen))])) 82 | 83 | (define (init-doc i) 84 | (match i 85 | [(UndI _) (text "{}")] 86 | [(ConI e) (expr-doc e)] 87 | [(ZedI _) (text "{ 0 }")] 88 | [(ArrI is) 89 | (define is-doc 90 | (apply h-append (add-between (map init-doc is) (h-append comma space)))) 91 | (hs-append lbrace is-doc rbrace)] 92 | [(RecI f->i) 93 | (define i-docs 94 | (add-between 95 | (for/list ([(f i) (in-hash f->i)]) 96 | (hs-append (sym f) (text ":=") (init-doc i))) 97 | (h-append comma space))) 98 | (hs-append lbrace (apply h-append i-docs) rbrace)] 99 | [(UniI m i) 100 | (hs-append lbrace (h-append (text "#:") (sym m)) (init-doc i) rbrace)])) 101 | 102 | (define (stmt-doc s) 103 | (match (unpack-MetaS s) 104 | [(Skip #f) (text "(void)")] 105 | [(Skip msg) 106 | (h-append (text "(void \"") (text msg) dquote rparen)] 107 | [(Fail msg) 108 | (h-append (text "(error \"") (text msg) dquote rparen)] 109 | [(Begin f s) 110 | (group 111 | (h-append 112 | lparen 113 | (nest 2 (v-append (text "begin") (stmt-doc f) (stmt-doc s))) 114 | rparen))] 115 | [(Assign p e) 116 | (h-append (text "(set! ") (path-doc p) space (expr-doc e) rparen)] 117 | [(If p t f) 118 | (group 119 | (h-append 120 | lparen 121 | (nest 2 (v-append (hs-append (text "If") (expr-doc p)) 122 | (stmt-doc t) (stmt-doc f))) 123 | rparen))] 124 | [(While p b) 125 | (group 126 | (h-append 127 | lparen 128 | (nest 2 (v-append (h-append (text "while") (expr-doc p)) 129 | (stmt-doc b))) 130 | rparen))] 131 | [(Jump l) 132 | (h-append (text "(Jump ") (sym l) rparen)] 133 | [(Let/ec l b) 134 | (nest 2 (v-append (h-append (text "(Let/ec ") (sym l)) 135 | (h-append (stmt-doc b) rparen)))] 136 | [(Let x ty xi bs) 137 | (define decl 138 | (h-append (text "Let ([") (sym x) (text " : ") (type-doc ty) 139 | (text " := ") (init-doc xi) (text "])"))) 140 | (group (h-append lparen (nest 2 (v-append decl (stmt-doc bs))) rparen))] 141 | [(Call x ty f as bs) 142 | (define f-name (given-name f)) 143 | (define f-doc (if f-name (sym f-name) (fun-doc f))) 144 | (define decl 145 | (h-append (text "Call ([") (sym x) (text " := ") f-doc (text "])"))) 146 | (group (h-append lparen (v-append decl (stmt-doc bs)) rparen))])) 147 | 148 | (define (fun-doc f) 149 | (match (unpack-MetaFun f) 150 | [(IntFun args ret-x ret-ty ret-lab body) 151 | (define arg-docs 152 | (for/list ([a (in-list args)]) 153 | (match-define (Arg x ty mode) a) 154 | (define mode-doc (h-append (text "#:") (sym mode))) 155 | (h-append lbracket mode-doc space (type-doc ty) space (sym x) rbracket))) 156 | (define head 157 | (h-append (text "(F ") (type-doc ret-ty) space 158 | lparen (apply hs-append arg-docs) rparen)) 159 | ;; XXX Emit ret-x and ret-lab 160 | (nest 2 (v-append head (h-append (stmt-doc body) rparen)))] 161 | [(ExtFun _ _ _ name) (text name)])) 162 | 163 | (define (ast-doc ast) 164 | (match ast 165 | [(? Type?) (type-doc ast)] 166 | [(? Path?) (path-doc ast)] 167 | [(? Expr?) (expr-doc ast)] 168 | [(? Init?) (init-doc ast)] 169 | [(? Stmt?) (stmt-doc ast)] 170 | [(? Fun?) (fun-doc ast)])) 171 | 172 | (define (print-ast ast [out (current-output-port)] [width (current-page-width)]) 173 | (pretty-print (ast-doc ast) out width) 174 | (void)) 175 | 176 | (provide 177 | (contract-out 178 | [print-ast (->* ((or/c Type? Path? Expr? Init? Stmt? Fun?)) 179 | (output-port? (or/c #f natural-number/c)) void?)])) 180 | -------------------------------------------------------------------------------- /linker.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/match 4 | syntax/parse/define 5 | (except-in ffi/unsafe ->) 6 | "ast.rkt" 7 | "compile.rkt" 8 | "stx.rkt" 9 | "print.rkt" 10 | "util.rkt") 11 | 12 | (struct linked-program (lib type-map ty->tag tag->ty ret-tys) #:transparent) 13 | (struct typed-pointer (ty ptr) #:transparent) 14 | 15 | (define (Int/Flo->ctype ty) 16 | (match ty 17 | [(IntT signed? bits) 18 | (if signed? 19 | (match bits 20 | [8 _sint8] 21 | [16 _sint16] 22 | [32 _sint32] 23 | [64 _sint64]) 24 | (match bits 25 | [8 _uint8] 26 | [16 _uint16] 27 | [32 _uint32] 28 | [64 _uint64]))] 29 | [(FloT bits) 30 | (match bits 31 | [32 _float] 32 | [64 _double])])) 33 | 34 | (define (ty->ctype ty->tag tag->ty ty) 35 | (match ty 36 | [(or (? IntT?) (? FloT?)) 37 | (Int/Flo->ctype ty)] 38 | [(or (? ArrT?) (? RecT?) (? UniT?)) 39 | (define (new-type!) 40 | (define tag (gensym 'tag)) 41 | (hash-set! ty->tag ty tag) 42 | (hash-set! tag->ty tag ty) 43 | tag) 44 | (_cpointer (hash-ref ty->tag ty new-type!))])) 45 | 46 | (define (Arg->ctype ty->tag tag->ty arg) 47 | (match-define (Arg _ ty mode) arg) 48 | (match ty 49 | [(or (? IntT?) (? FloT?)) 50 | (if (eq? mode 'ref) 51 | (_cpointer (hash-ref ty->tag ty)) 52 | (Int/Flo->ctype ty))] 53 | [_ (ty->ctype ty->tag tag->ty ty)])) 54 | 55 | (define (ty->untagged-ctype ty) 56 | (match ty 57 | [(or (? IntT?) (? FloT?)) (Int/Flo->ctype ty)] 58 | [(or (? ArrT?) (? RecT?) (? UniT?)) _pointer])) 59 | 60 | (define (ty->alloc-ctype ty) 61 | (match ty 62 | [(or (? IntT?) (? FloT?)) 63 | (Int/Flo->ctype ty)] 64 | [(ArrT dim ety) 65 | (make-array-type (ty->untagged-ctype ty) dim)] 66 | [(RecT f->ty _ c-order) 67 | (make-cstruct-type (for/list ([f (in-list c-order)]) 68 | (ty->untagged-ctype (hash-ref f->ty f))))] 69 | [(UniT m->ty _) 70 | (apply make-union-type 71 | (map ty->untagged-ctype (hash-values m->ty)))])) 72 | 73 | (define (ty->read-ctype ty->tag tag->ty ty) 74 | (match ty 75 | [(or (? IntT?) (? FloT?)) 76 | (Int/Flo->ctype ty)] 77 | [(ArrT dim ety) 78 | (_array (ty->ctype ty->tag tag->ty ety) dim)] 79 | [(RecT f->ty _ c-order) 80 | (apply _list-struct (for/list ([f (in-list c-order)]) 81 | (ty->ctype ty->tag tag->ty (hash-ref f->ty f))))] 82 | ;; XXX Read for unions? 83 | )) 84 | 85 | (define-simple-macro (make-tag-tables (~seq k v) ...) 86 | (values (make-hash (list (cons k v) ...)) 87 | (make-hasheq (list (cons v k) ...)))) 88 | 89 | (define (default-tag-tables) 90 | (make-tag-tables (T S8) 'sint8 (T S16) 'sint16 (T S32) 'sint32 (T S64) 'sint64 91 | (T U8) 'uint8 (T U16) 'uint16 (T U32) 'uint32 (T U64) 'uint64 92 | (T F32) 'float (T F64) 'double)) 93 | 94 | (define (link-program p c-path bin-path) 95 | (unless (compile-library p c-path bin-path) 96 | (define in (open-input-file c-path)) 97 | (newline (current-error-port)) 98 | (echo-port in (current-error-port)) 99 | (newline (current-error-port)) 100 | (for ([(n f) (in-hash (Program-name->fun p))]) 101 | (eprintf "~a:\n" n) 102 | (print-ast (unpack-MetaFun f) (current-error-port)) 103 | (newline (current-error-port))) 104 | (newline (current-error-port)) 105 | (close-input-port in) 106 | (error 'link-program "call to compile-library failed (see stderr)")) 107 | (define lib (ffi-lib bin-path)) 108 | (define name->fun (Program-name->fun p)) 109 | (define-values (ty->tag tag->ty) (default-tag-tables)) 110 | (define type-map 111 | (for/hash ([(name fun) (in-hash name->fun)]) 112 | (match-define (IntFun args _ ret-ty _ _) (unpack-MetaFun fun)) 113 | (define c-args (for/list ([a (in-list args)]) 114 | (Arg->ctype ty->tag tag->ty a))) 115 | (define c-ret (ty->ctype ty->tag tag->ty ret-ty)) 116 | (values name (_cprocedure c-args c-ret)))) 117 | (define ret-tys 118 | (for/hash ([(name fun) (in-hash name->fun)]) 119 | (values name (IntFun-ret-ty (unpack-MetaFun fun))))) 120 | (linked-program lib type-map ty->tag tag->ty ret-tys)) 121 | 122 | (define (linked-program-run lp n args) 123 | (match-define (linked-program lib type-map _ _ ret-tys) lp) 124 | (define fun (get-ffi-obj n lib (hash-ref type-map n))) 125 | (define r (apply fun (for/list ([a (in-list args)]) 126 | (cond [(typed-pointer? a) 127 | (typed-pointer-ptr a)] 128 | [else a])))) 129 | (define ret-ty (hash-ref ret-tys n)) 130 | (cond [(cpointer? r) 131 | (typed-pointer ret-ty r)] 132 | [(equal? ret-ty (FloT 32)) 133 | (real->single-flonum r)] 134 | [else r])) 135 | 136 | (define (linked-program-alloc lp ty) 137 | (define p (malloc (ty->alloc-ctype ty))) 138 | (cpointer-push-tag! p (hash-ref (linked-program-ty->tag lp) ty)) 139 | (typed-pointer ty p)) 140 | 141 | (define (linked-program-read lp maybe-tp) 142 | (match maybe-tp 143 | [(typed-pointer ty ptr) 144 | (define ty->tag (linked-program-ty->tag lp)) 145 | (define tag->ty (linked-program-tag->ty lp)) 146 | (define r (ptr-ref ptr (ty->read-ctype ty->tag tag->ty ty))) 147 | (match ty 148 | [(ArrT dim ety) 149 | (for/vector #:length dim ([e (in-array r)]) 150 | (cond [(or (ArrT? ety) (RecT? ety) (UniT? ety)) 151 | (typed-pointer ety e)] 152 | [else e]))] 153 | [(RecT f->ty _ c-order) 154 | ;; XXX Maybe use make-cstruct-type instead of _list-struct to avoid extra copy. 155 | (for/list ([e (in-list r)] [f (in-list c-order)]) 156 | (define ety (hash-ref f->ty f)) 157 | (cond [(or (ArrT? ety) (RecT? ety) (UniT? ety)) 158 | (typed-pointer ety e)] 159 | [else e]))] 160 | ;; XXX UniT? 161 | [(FloT 32) (real->single-flonum r)] 162 | [_ r])] 163 | [_ maybe-tp])) 164 | 165 | (define (linked-program-write lp tp val) 166 | (match-define (typed-pointer ty ptr) tp) 167 | (define ty->tag (linked-program-ty->tag lp)) 168 | (define tag->ty (linked-program-tag->ty lp)) 169 | (match ty 170 | [(ArrT dim ety) 171 | (define a (ptr-ref ptr (ty->read-ctype ty->tag tag->ty ty))) 172 | (for ([e (in-vector val)] [i (in-naturals)]) 173 | (array-set! a i (cond [(or (ArrT? ety) (RecT? ety) (UniT? ety)) 174 | (typed-pointer-ptr e)] 175 | [else e])))] 176 | [(RecT f->ty _ c-order) 177 | ;; XXX Maybe use make-cstruct-type instead of _list-struct to avoid extra copy. 178 | (define val* (for/list ([e (in-list val)] [f (in-list c-order)]) 179 | (define ety (hash-ref f->ty f)) 180 | (cond [(or (ArrT? ety) (RecT? ety) (UniT? ety)) 181 | (typed-pointer-ptr e)] 182 | [else e]))) 183 | (ptr-set! ptr (ty->read-ctype ty->tag tag->ty ty) val*)] 184 | [_ (ptr-set! ptr (ty->read-ctype ty->tag tag->ty ty) val)])) 185 | 186 | (provide 187 | (contract-out 188 | [struct linked-program ([lib ffi-lib?] 189 | [type-map (hash/c c-identifier-string? ctype?)] 190 | [ty->tag (hash/c Type? symbol?)] 191 | [tag->ty (hash/c symbol? Type?)] 192 | [ret-tys (hash/c c-identifier-string? Type?)])] 193 | [struct typed-pointer ([ty Type?] [ptr cpointer?])] 194 | [link-program (-> Program? path? path? linked-program?)] 195 | [linked-program-run (-> linked-program? c-identifier-string? list? any/c)] 196 | [linked-program-alloc (-> linked-program? Type? typed-pointer?)] 197 | [linked-program-read (-> linked-program? any/c any/c)] 198 | [linked-program-write (-> linked-program? typed-pointer? any/c void?)])) 199 | -------------------------------------------------------------------------------- /t/2048.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require adqc 3 | racket/file 4 | racket/list 5 | racket/runtime-path 6 | racket/system) 7 | 8 | (define-runtime-path 2048-exe-path "2048") 9 | (define-runtime-path 2048-h-path "2048.h") 10 | (define-runtime-path 2048-c-path "2048.c") 11 | (define 2048-c (ExternSrc '() (list (path->string 2048-c-path)))) 12 | 13 | (define SIZE 4) 14 | 15 | (define-type Row (array SIZE U8)) 16 | (define-type Board (array SIZE Row)) 17 | 18 | (define-global score : U32 := (U32 0)) 19 | 20 | (define-fun void make-board ([Board b] [Row r1] [Row r2] [Row r3] [Row r4]) 21 | (set! (b @ 0) r1) 22 | (set! (b @ 1) r2) 23 | (set! (b @ 2) r3) 24 | (set! (b @ 3) r4)) 25 | 26 | (define-fun U8 find-target ([Row r] [U8 x] [U8 stop]) 27 | ;; If the position is already on the first, don't evaluate 28 | (when (zero? x) 29 | (return x)) 30 | (for ([t := (sub1 x)] (S32 1) (-=1 t)) 31 | (cond [(not (zero? (r @ t))) 32 | (unless (= (r @ t) (r @ x)) 33 | ;; merge is not possible, take next position 34 | (return (add1 t))) 35 | (return t)] 36 | [else 37 | ;; we should not slide further, return this one 38 | (when (= t stop) 39 | (return t))])) 40 | ;; we did not find a 41 | (return x)) 42 | 43 | (define-fun U8 slide-array ([Row r]) 44 | (define success := (U8 0)) 45 | (define stop := (U8 0)) 46 | (for ([x := (U8 0)] (< x (U8 SIZE)) (+=1 x)) 47 | (when (not (zero? (r @ x))) 48 | (define t := find-target <- r x stop) 49 | ;; if target is not original position, then move or merge 50 | (unless (= t x) 51 | ;; if target is zero, this is a move 52 | (cond [(zero? (r @ t)) 53 | (set! (r @ t) (r @ x))] 54 | [(= (r @ t) (r @ x)) 55 | ;; merge (increase power of two) 56 | (+=1 (r @ t)) 57 | ;; increase score 58 | (+= score (<< 1 ((r @ t) : U32))) 59 | ;; set stop to avoid double merge 60 | (set! stop (add1 t))] 61 | [else (void)]) 62 | (set! (r @ x) 0) 63 | (set! success 1)))) 64 | (return success)) 65 | 66 | (define-fun void rotate-board ([Board board]) 67 | ;; XXX This var really only exists because it's awkward to embed 68 | ;; SIZE in the individual expressions - SIZE is interpreted as an S8, 69 | ;; which is incompatible with U8, so it would require typing (U8 SIZE) 70 | ;; everwhere we use 'n' now. 71 | (define n := (U8 SIZE)) 72 | (for ([i := (U8 0)] (< i (/ n (U8 2))) (+=1 i)) 73 | ;; XXX Allow path for var init? 74 | (for ([j : U8 := i] (< j (sub1 (- n i))) (+=1 j)) 75 | (define tmp := (board @ i @ j)) 76 | ;; XXX Implement var args for ops so we can just do (- n i 1) 77 | (set! (board @ i @ j) 78 | (board @ j @ (sub1 (- n i)))) 79 | (set! (board @ j @ (sub1 (- n i))) 80 | (board @ (sub1 (- n i)) @ (sub1 (- n j)))) 81 | (set! (board @ (sub1 (- n i)) @ (sub1 (- n j))) 82 | (board @ (sub1 (- n j)) @ i)) 83 | (set! (board @ (sub1 (- n j)) @ i) tmp)))) 84 | 85 | 86 | (define-fun U8 move-up ([Board board]) 87 | (define success := (U8 0)) 88 | (for ([x := (U8 0)] (< x (U8 SIZE)) (+=1 x)) 89 | (define sa-result := (slide-array (board @ x))) 90 | (set! success (bitwise-ior success sa-result))) 91 | (return success)) 92 | 93 | (define-fun+ U8 move-left ([Board b]) 94 | (rotate-board b) 95 | (define success (move-up b)) 96 | (rotate-board b) 97 | (rotate-board b) 98 | (rotate-board b) 99 | success) 100 | 101 | (define-fun+ U8 move-down ([Board b]) 102 | (rotate-board b) 103 | (rotate-board b) 104 | (define success (move-up b)) 105 | (rotate-board b) 106 | (rotate-board b) 107 | success) 108 | 109 | (define-fun+ U8 move-right ([Board b]) 110 | (rotate-board b) 111 | (rotate-board b) 112 | (rotate-board b) 113 | (define success (move-up b)) 114 | (rotate-board b) 115 | success) 116 | 117 | (define-fun U8 find-pair-down ([Board board]) 118 | (for ([x := (U8 0)] (< x (U8 SIZE)) (+=1 x)) 119 | (for ([y := (U8 0)] (< y (sub1 (U8 SIZE))) (+=1 y)) 120 | (when (= (board @ x @ y) (board @ x @ (add1 y))) 121 | (return 1)))) 122 | (return 0)) 123 | 124 | ;; The U8 here is a number, not a bool 125 | ;; XXX Maybe support boolean type so this is less confusing? stdbool? 126 | (define-fun U8 count-empty ([Board board]) 127 | (define count := (U8 0)) 128 | (for ([x := (U8 0)] (< x (U8 SIZE)) (+=1 x)) 129 | (for ([y := (U8 0)] (< y (U8 SIZE)) (+=1 y)) 130 | (when (zero? (board @ x @ y)) 131 | (+=1 count)))) 132 | (return count)) 133 | 134 | 135 | (define-fun U8 game-ended ([Board board]) 136 | ;; XXX Awkward because no ANF. Need can't put function call inside 137 | ;; predicate, so we need 2 conditional statements instead of an 'or' 138 | (define num-empty := (count-empty board)) 139 | (when (> num-empty (U8 0)) 140 | (return 0)) 141 | (define is-pair-down := (find-pair-down board)) 142 | (when is-pair-down 143 | (return 0)) 144 | (define void1 := (rotate-board board)) 145 | (define is-pair-down2 := (find-pair-down board)) 146 | (define ended := (not is-pair-down2)) 147 | (define void2 := (rotate-board board)) 148 | (define void3 := (rotate-board board)) 149 | (define void4 := (rotate-board board)) 150 | (return ended)) 151 | 152 | ;; XXX Issue with type of first cond case, I think related to 153 | ;; 'or' macro? 154 | #; 155 | (define-fun+ U8 game-ended ([Board b]) 156 | (cond [(or (not (zero? (count-empty b))) (find-pair-down b)) 0] 157 | [else 158 | (rotate-board b) 159 | (defined ended (not (find-pair-down b))) 160 | (rotate-board b) 161 | (rotate-board b) 162 | (rotate-board b) 163 | ended])) 164 | 165 | (define-extern-fun S32 rand () #:src (ExternSrc '() '("stdlib.h"))) 166 | 167 | (define-fun void add-random ([Board board]) 168 | (define x-lst : (array (* SIZE SIZE) U8)) 169 | (define y-lst : (array (* SIZE SIZE) U8)) 170 | (define len := (U8 0)) 171 | (for ([x := (U8 0)] (< x (U8 SIZE)) (+=1 x)) 172 | (for ([y := (U8 0)] (< y (U8 SIZE)) (+=1 y)) 173 | (when (zero? (board @ x @ y)) 174 | (set! (x-lst @ len) x) 175 | (set! (y-lst @ len) y) 176 | (+=1 len)))) 177 | (unless (zero? len) 178 | (define rand-ret-1 := (rand)) 179 | (define r := (% (rand-ret-1 : U8) len)) 180 | (define x := (x-lst @ r)) 181 | (define y := (y-lst @ r)) 182 | (define rand-ret-2 := (rand)) 183 | (define n : U8 := (add1 (/ (% (rand-ret-2 : U8) 10) 9))) 184 | (set! (board @ x @ y) n))) 185 | 186 | (define-fun void init-board ([Board board]) 187 | (for ([x := (U8 0)] (< x (U8 SIZE)) (+=1 x)) 188 | (for ([y := (U8 0)] (< y (U8 SIZE)) (+=1 y)) 189 | (set! (board @ x @ y) 0))) 190 | (define void1 := (add-random board)) 191 | (define void2 := (add-random board)) 192 | (define void3 := (add-random board)) 193 | (set! score 0)) 194 | 195 | (define-fun U8 step ([Board board] [S8 c]) 196 | (define success : U8) 197 | ;; This is another example of the difference between S-cond and E-cond 198 | ;; being annoying. We can't just say '(define success := (cond ...))' 199 | ;; because we call a function from within the cond stmt. ANF should fix this. 200 | (cond 201 | ;; left arrow 202 | [(= c 68) 203 | (define result := (move-left board)) 204 | (set! success result)] 205 | ;; right arrow 206 | [(= c 67) 207 | (define result := (move-right board)) 208 | (set! success result)] 209 | ;; up arrow 210 | [(= c 65) 211 | (define result := (move-up board)) 212 | (set! success result)] 213 | ;; down arrow 214 | [(= c 66) 215 | (define result := (move-down board)) 216 | (set! success result)] 217 | [else (set! success 0)]) 218 | (return success)) 219 | 220 | 221 | (define-prog 2048-prog 222 | (include-type Row) 223 | (include-type Board) 224 | (include-global score) 225 | (include-fun make-board) 226 | (include-fun init-board) 227 | (include-fun add-random) 228 | (include-fun game-ended) 229 | (include-fun step)) 230 | 231 | (module+ test 232 | (require chk) 233 | (define c-path (make-temporary-file "adqc~a.c")) 234 | (define o-path (make-temporary-file "adqc~a.o")) 235 | (unless (compile-obj 2048-prog c-path o-path 2048-h-path) 236 | (newline (current-error-port)) 237 | (define in (open-input-file c-path)) 238 | (for ([ch (in-port read-char in)]) 239 | (display ch (current-error-port))) 240 | (close-input-port in) 241 | (delete-file c-path) 242 | (delete-file o-path) 243 | (error "compile-obj failed (see stderr)")) 244 | (define cc (find-executable-path "cc")) 245 | ;; XXX There should be an interface for including obj files 246 | ;; when calling compile-exe so we don't have to call cc directly. 247 | (unless (system* cc "-Wall" "-Werror" "-o" 2048-exe-path 2048-c-path o-path) 248 | (delete-file c-path) 249 | (delete-file o-path) 250 | (error "call to cc failed (see stderr)")) 251 | (delete-file c-path) 252 | (delete-file o-path)) 253 | -------------------------------------------------------------------------------- /eval.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/contract/region 4 | racket/flonum 5 | racket/function 6 | racket/match 7 | racket/require 8 | racket/undefined 9 | threading 10 | (subtract-in "ast.rkt" "type.rkt") 11 | "type.rkt") 12 | 13 | (define current-globals (make-parameter #f)) 14 | 15 | (define (arithmetic-shift-left n m) (arithmetic-shift n m)) 16 | (define (arithmetic-shift-right n m) (arithmetic-shift n (- m))) 17 | (define (logical-shift-right n m) (quotient n (expt 2 m))) 18 | (define (!= a b) (not (= a b))) 19 | (define (fl-remainder a b) 20 | (- a (* (floor (/ a b)) b))) 21 | 22 | ;; Operation wrappers 23 | 24 | (define (signed->unsigned bits val) 25 | (modulo val (expt 2 bits))) 26 | 27 | (define (unsigned->signed bits val) 28 | (define val* (modulo val (expt 2 bits))) 29 | (if (< val* (expt 2 (sub1 bits))) 30 | val* 31 | (- val* (expt 2 bits)))) 32 | 33 | (define ((int-cast signed? bits) val) 34 | (if signed? 35 | (unsigned->signed bits val) 36 | (signed->unsigned bits val))) 37 | 38 | (define (((int-op signed?) op) a b) 39 | (match-define (Int a-signed? a-bits a-val) (unpack-MetaE a)) 40 | (match-define (Int b-signed? b-bits b-val) (unpack-MetaE b)) 41 | (unless (eq? a-signed? b-signed?) 42 | (error "Mismatched signs" a b)) 43 | (unless (= a-bits b-bits) 44 | (error "Mismatched bit widths" a b)) 45 | (define pre-cast (int-cast signed? a-bits)) 46 | (define post-cast (int-cast a-signed? a-bits)) 47 | (Int a-signed? a-bits (post-cast (op (pre-cast a-val) 48 | (pre-cast b-val))))) 49 | 50 | (define sint-op (int-op #t)) 51 | (define uint-op (int-op #f)) 52 | 53 | (define (((int-cmp signed?) op) a b) 54 | (match-define (Int a-signed? a-bits a-val) (unpack-MetaE a)) 55 | (match-define (Int b-signed? b-bits b-val) (unpack-MetaE b)) 56 | (unless (eq? a-signed? b-signed?) 57 | (error "Mismatched signs" a b)) 58 | (unless (= a-bits b-bits) 59 | (error "Mismatched bit widths" a b)) 60 | (define pre-cast (int-cast signed? a-bits)) 61 | (define res (op (pre-cast a-val) (pre-cast b-val))) 62 | (Int #t 32 (if res 1 0))) 63 | 64 | (define sint-cmp (int-cmp #t)) 65 | (define uint-cmp (int-cmp #f)) 66 | 67 | (define ((flo-op op) a b) 68 | (match-define (Flo a-bits a-val) (unpack-MetaE a)) 69 | (match-define (Flo b-bits b-val) (unpack-MetaE b)) 70 | (unless (= a-bits b-bits) 71 | (error 'flo-op "Mismatched bit widths" a b)) 72 | (Flo a-bits (op a-val b-val))) 73 | 74 | (define ((flo-cmp op) a b) 75 | (match-define (Flo a-bits a-val) (unpack-MetaE a)) 76 | (match-define (Flo b-bits b-val) (unpack-MetaE b)) 77 | (unless (= a-bits b-bits) 78 | (error 'flo-cmp "Mismatched bit widths" a b)) 79 | (Int #t 32 (if (op a-val b-val) 1 0))) 80 | 81 | (define ((ordered-op op) a b) 82 | (and (not (equal? a +nan.0)) 83 | (not (equal? b +nan.0)) 84 | (op a b))) 85 | 86 | (define ((unordered-op op) a b) 87 | (or (equal? a +nan.0) 88 | (equal? b +nan.0) 89 | (op a b))) 90 | 91 | (define ord-flo-cmp 92 | (λ~> ordered-op flo-cmp)) 93 | 94 | (define unord-flo-cmp 95 | (λ~> unordered-op flo-cmp)) 96 | 97 | (define bin-op-table 98 | (hasheq 'iadd (uint-op +) 99 | 'isub (uint-op -) 100 | 'imul (uint-op *) 101 | 'iudiv (uint-op quotient) 102 | 'isdiv (sint-op quotient) 103 | 'iurem (uint-op remainder) 104 | 'isrem (sint-op remainder) 105 | 'ishl (uint-op arithmetic-shift-left) 106 | 'ilshr (uint-op logical-shift-right) 107 | 'iashr (sint-op arithmetic-shift-right) 108 | 'ior (uint-op bitwise-ior) 109 | 'iand (uint-op bitwise-and) 110 | 'ixor (uint-op bitwise-xor) 111 | ;; ieq and ine technically aren't signed or unsigned, but we 112 | ;; use uint-cmp here because we only care if the results are 113 | ;; equal, which is unaffected by signed vs. unsigned. 114 | 'ieq (uint-cmp =) 115 | 'ine (uint-cmp !=) 116 | 'iugt (uint-cmp >) 117 | 'iuge (uint-cmp >=) 118 | 'iult (uint-cmp <) 119 | 'iule (uint-cmp <=) 120 | 'isgt (sint-cmp >) 121 | 'isge (sint-cmp >=) 122 | 'islt (sint-cmp <) 123 | 'isle (sint-cmp <=) 124 | 'fadd (flo-op +) 125 | 'fsub (flo-op -) 126 | 'fmul (flo-op *) 127 | 'fdiv (flo-op /) 128 | 'frem (flo-op fl-remainder) 129 | 'ffalse (flo-cmp (const #f)) 130 | 'ftrue (flo-cmp (const #t)) 131 | 'foeq (ord-flo-cmp =) 132 | 'fogt (ord-flo-cmp >) 133 | 'foge (ord-flo-cmp >=) 134 | 'folt (ord-flo-cmp <) 135 | 'fole (ord-flo-cmp <=) 136 | 'fone (ord-flo-cmp !=) 137 | 'ford (ord-flo-cmp (const #t)) 138 | 'fueq (unord-flo-cmp =) 139 | 'fugt (unord-flo-cmp >) 140 | 'fuge (unord-flo-cmp >=) 141 | 'fult (unord-flo-cmp <) 142 | 'fule (unord-flo-cmp <=) 143 | 'fune (unord-flo-cmp !=) 144 | 'funo (unord-flo-cmp (const #f)))) 145 | 146 | (define (type-cast ty v) 147 | (match-define (or (Int _ _ val) (Flo _ val)) 148 | (unpack-MetaE v)) 149 | (match ty 150 | [(IntT signed? bits) 151 | (define cast (int-cast signed? bits)) 152 | (define val* (inexact->exact (floor val))) 153 | (Int signed? bits (cast val*))] 154 | [(FloT bits) 155 | (define cast 156 | (match bits 157 | [32 real->single-flonum] 158 | [64 real->double-flonum])) 159 | (Flo bits (cast val))])) 160 | 161 | (define ((new-global! the-glob)) 162 | (define v (eval-init (hasheq) (Global-xi the-glob))) 163 | (hash-set! (current-globals) the-glob v) 164 | v) 165 | 166 | (define (path-read σ p) 167 | (define (rec p) (unbox (path-read σ p))) 168 | (match (unpack-MetaP p) 169 | [(Var x _) (hash-ref σ x)] 170 | [(and the-glob (Global _ xi)) 171 | (define globals (current-globals)) 172 | (hash-ref globals the-glob (new-global! the-glob))] 173 | [(Select p ie) (vector-ref (rec p) (Int-val (eval-expr σ ie)))] 174 | [(Field p f) (hash-ref (rec p) f)] 175 | [(Mode p m) (hash-ref (rec p) m)] 176 | [(? ExtVar?) 177 | (error 'path-read/ref "XXX Cannot interp external variables yet: ~e" p)])) 178 | 179 | (define (path-write! σ p v) 180 | (match (unpack-MetaP p) 181 | [(Var x _) 182 | (set-box! (hash-ref σ x) v)] 183 | [(and the-glob (Global _ xi)) 184 | (define globals (current-globals)) 185 | (set-box! (hash-ref globals the-glob (new-global! the-glob)) v)] 186 | [(Select p ie) 187 | (set-box! (vector-ref (unbox (path-read σ p)) (Int-val (eval-expr σ ie))) v)] 188 | [(Field p f) 189 | (set-box! (hash-ref (unbox (path-read σ p)) f) v)] 190 | [(Mode p m) 191 | (set-box! (hash-ref (unbox (path-read σ p)) m) v)] 192 | [(? ExtVar?) 193 | (error 'path-read/ref "XXX Cannot interp external variables yet: ~e" p)])) 194 | 195 | (define (eval-expr σ e) 196 | (define (rec e) (eval-expr σ e)) 197 | (match e 198 | [(? Int?) e] 199 | [(? Flo?) e] 200 | [(Read p) (unbox (path-read σ p))] 201 | [(Cast ty e) (type-cast ty (rec e))] 202 | [(BinOp op L R) 203 | ((hash-ref bin-op-table op) (rec L) (rec R))] 204 | [(LetE x xt xe be) 205 | (eval-expr (hash-set σ x (box (eval-expr σ xe))) be)] 206 | [(IfE ce te fe) 207 | (eval-expr σ (if (eval-expr-pred σ ce) te fe))] 208 | [(MetaE _ e) 209 | (eval-expr σ e)])) 210 | 211 | (define (eval-expr-pred σ pred) 212 | (not (zero? (Int-val (eval-expr σ pred))))) 213 | 214 | (define (hash-map-ht h f) 215 | (define hp (make-hasheq)) 216 | (for ([(k v) (in-hash h)]) 217 | (hash-set! hp k (f v))) 218 | hp) 219 | 220 | (define (type-zero ty) 221 | (match ty 222 | [(IntT signed? bits) (Int signed? bits 0)] 223 | [(FloT 32) (Flo 32 (real->single-flonum 0.0))] 224 | [(FloT 64) (Flo 64 (real->double-flonum 0.0))] 225 | [(ArrT dim ety) (build-vector dim (λ (_) (box (type-zero ety))))] 226 | [(RecT f->ty _ _) (hash-map-ht f->ty (λ (ty) (box (type-zero ty))))] 227 | [(UniT mode->ty _) (hash-map-ht mode->ty (λ (ty) (box (type-zero ty))))] 228 | ;; XXX Using an unboxed #f to represent void variables will cause 229 | ;; issues if we want to evaluate void functions later. What is 230 | ;; a reasonable racket value to return from an evaluated void function? 231 | [(or (VoiT) (AnyT)) #f] 232 | [(? ExtT?) (error 'type-zero "XXX Cannot interp external types yet: ~e" ty)])) 233 | 234 | (define (eval-init σ i) 235 | (match i 236 | [(UndI ty) (box (type-zero ty))] 237 | [(ConI e) (box (eval-expr σ e))] 238 | [(ZedI ty) (box (type-zero ty))] 239 | [(ArrI is) (box (list->vector (map (λ (i) (eval-init σ i)) is)))] 240 | [(RecI f->i) (box (hash-map-ht f->i (λ (i) (eval-init σ i))))] 241 | [(UniI m i) (box (make-hasheq (list (cons m (eval-init σ i)))))])) 242 | 243 | (define (eval-stmt γ σ s) 244 | (match s 245 | [(Skip _) σ] 246 | [(Fail m) (error 'Fail m)] 247 | [(Begin f s) 248 | (eval-stmt γ σ f) 249 | (eval-stmt γ σ s)] 250 | [(Assign p e) 251 | (path-write! σ p (eval-expr σ e))] 252 | [(If p t f) 253 | (eval-stmt γ σ (if (eval-expr-pred σ p) t f))] 254 | [(While p b) 255 | (when (eval-expr-pred σ p) 256 | (eval-stmt γ σ b) 257 | (eval-stmt γ σ s))] 258 | [(Jump l) 259 | ((hash-ref γ l))] 260 | [(Let/ec l b) 261 | (let/ec this-return 262 | (eval-stmt (hash-set γ l this-return) σ b))] 263 | [(Let x ty xi bs) 264 | (define xv (eval-init σ xi)) 265 | (eval-stmt γ (hash-set σ x xv) bs)] 266 | [(MetaS _ bs) 267 | (eval-stmt γ σ bs)] 268 | [(Call x ty f as bs) 269 | (define σ* 270 | (for/fold ([σ* (hasheq)]) 271 | ([a (in-list as)] [fa (in-list (Fun-args f))]) 272 | (match-define (Arg x ty m) fa) 273 | (match (unpack-any a) 274 | [(or (Read p) (? Path? p)) 275 | (match m 276 | ['copy 277 | (hash-set σ* x (box (unbox (path-read σ p))))] 278 | [(or 'ref 'read-only) 279 | (hash-set σ* x (path-read σ p))])] 280 | [(? Expr? e) 281 | (hash-set σ* x (box (eval-expr σ e)))]))) 282 | (define xv (eval-fun σ* f)) 283 | (eval-stmt γ (hash-set σ x (box xv)) bs)] 284 | [(Fail msg) 285 | (error 'eval-stmt msg)])) 286 | 287 | (define (eval-fun σ f) 288 | (match f 289 | [(? ExtFun?) (error 'eval-fun "XXX Cannot interp external functions yet: ~e" f)] 290 | [(MetaFun _ f) (eval-fun σ f)] 291 | [(IntFun as ret-x ret-ty ret-lab body) 292 | (define ret-x-b (eval-init (hasheq) (UndI ret-ty))) 293 | (let/ec this-return 294 | (eval-stmt (hasheq ret-lab this-return) (hash-set σ ret-x ret-x-b) body)) 295 | (unbox ret-x-b)])) 296 | 297 | (define (eval-program p n is) 298 | (define n->f (Program-name->fun p)) 299 | (parameterize ([current-globals (make-hasheq)]) 300 | (define f (hash-ref n->f n)) 301 | (define σ 302 | (for/fold ([σ (hasheq)]) 303 | ([i (in-list is)] [a (in-list (Fun-args f))]) 304 | (hash-set σ (Arg-x a) (eval-init (hasheq) i)))) 305 | (eval-fun σ f))) 306 | 307 | (define Value/c 308 | (or/c Int? Flo? vector? hash?)) 309 | 310 | (provide 311 | (contract-out 312 | [Value/c contract?] 313 | [eval-init 314 | (-> hash? Init? (box/c Value/c))] 315 | [eval-expr 316 | (-> hash? Expr? Value/c)] 317 | [eval-program 318 | (-> Program? string? (listof Init?) 319 | Value/c)])) 320 | -------------------------------------------------------------------------------- /ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/list 4 | racket/struct-info 5 | racket/syntax) 6 | racket/contract/base 7 | racket/match 8 | syntax/parse/define) 9 | 10 | (define float-bit-widths '(32 64)) 11 | (define integer-bit-widths '(8 16 32 64)) 12 | 13 | (begin-for-syntax 14 | (struct constructor (ctc name) 15 | #:property prop:struct-info 16 | (λ (this) 17 | (extract-struct-info (syntax-local-value (constructor-name this)))) 18 | #:property prop:match-expander 19 | (λ (this stx) 20 | (syntax-parse stx 21 | [(_ args:expr ...) 22 | #:with name (constructor-name this) 23 | (syntax/loc stx (name args ...))])) 24 | #:property prop:procedure 25 | (λ (this stx) 26 | (syntax-parse stx 27 | [(me args:expr ...) 28 | (syntax/loc stx (#%app me args ...))] 29 | [me:id 30 | #:with ctc (constructor-ctc this) 31 | #:with name (constructor-name this) 32 | (quasisyntax/loc stx 33 | (contract ctc name (syntax-source #'name) #'#,stx 'me #'name))])))) 34 | 35 | (define-syntax (struct+ stx) 36 | (syntax-parse stx 37 | [(_ name:id base:id meta-base:id unpack:id ([field:id ctc:expr] ...)) 38 | #:with name? (format-id #'name "~a?" #'name) 39 | #:with name?^ (generate-temporary #'name?) 40 | #:with (field-accessor ...) (for/list ([f (in-list (syntax->list #'(field ...)))]) 41 | (format-id f "~a-~a" #'name f)) 42 | #:with (field-accessor^ ...) (generate-temporaries #'(field-accessor ...)) 43 | #:with base? (format-id #'base "~a?" #'base) 44 | #:with meta-base? (format-id #'meta-base "~a?" #'meta-base) 45 | #:with meta-ctc #'(or/c name? meta-base?) 46 | #:with ctor-ctc #'(-> ctc ... meta-ctc) 47 | #:with ctor (generate-temporary #'name) 48 | (syntax/loc stx 49 | (begin 50 | (struct name base (field ...) #:transparent) 51 | (define-syntax ctor (constructor #'ctor-ctc #'name)) 52 | (define (name?^ v) 53 | (and (base? v) (name? (unpack v)))) 54 | (define (field-accessor^ v) 55 | (field-accessor (unpack v))) 56 | ... 57 | (provide 58 | (rename-out [ctor name]) 59 | (contract-out 60 | [rename name?^ name? predicate/c] 61 | [rename field-accessor^ field-accessor (-> meta-ctc ctc)] ...))))])) 62 | 63 | (define-simple-macro (define-unpacker name:id meta-type:id base-type?:id) 64 | (begin 65 | (define (name v) 66 | (match v 67 | [(meta-type _ v) (name v)] 68 | [(? base-type?) v])) 69 | (provide (contract-out [name (-> base-type? base-type?)])))) 70 | 71 | ;; This is a partial test, see 72 | ;; http://en.cppreference.com/w/c/language/identifier for the complete 73 | ;; rules. 74 | (define (c-identifier-string? x) 75 | (regexp-match? #rx"^[_a-zA-Z][a-zA-Z0-9_]*$" x)) 76 | 77 | (define current-cify-counter (make-parameter (box 0))) 78 | (define-syntax-rule (with-cify-counter . b) 79 | (parameterize ([current-cify-counter (box 0)]) . b)) 80 | (define (cify s) 81 | (define cify-counter (current-cify-counter)) 82 | (define which (unbox cify-counter)) 83 | (set-box! cify-counter (add1 which)) 84 | (format "_~a_~a" 85 | (regexp-replace* #rx"[^a-zA-Z0-9_]" (symbol->string s) "_") 86 | which)) 87 | 88 | ;; Legal things the right of -l in cc 89 | (define c-library-string? string?) 90 | ;; Legal things inside the <>s of an #include 91 | (define c-header-string? string?) 92 | 93 | (provide 94 | with-cify-counter 95 | (contract-out 96 | [c-identifier-string? (-> any/c boolean?)] 97 | [c-library-string? (-> any/c boolean?)] 98 | [c-header-string? (-> any/c boolean?)] 99 | [cify (-> symbol? c-identifier-string?)])) 100 | 101 | ;; Extern Source 102 | (struct ExternSrc (ls hs) #:transparent) 103 | 104 | (provide 105 | (contract-out 106 | [struct ExternSrc ([ls (listof c-library-string?)] 107 | [hs (listof c-header-string?)])])) 108 | 109 | ;; Types 110 | (struct Type () #:transparent) 111 | (struct IntT Type (signed? bits) #:transparent) 112 | (struct FloT Type (bits) #:transparent) 113 | (struct ArrT Type (dim ety) #:transparent) 114 | (struct RecT Type (field->ty field->c c-order) #:transparent) 115 | (struct UniT Type (mode->ty mode->c) #:transparent) 116 | (struct ExtT Type (src name) #:transparent) 117 | (struct VoiT Type () #:transparent) 118 | (struct AnyT Type () #:transparent) 119 | 120 | (define non-void-type? (and/c Type? (not/c VoiT?))) 121 | 122 | (provide 123 | (contract-out 124 | [non-void-type? predicate/c] 125 | [struct Type ()] 126 | [struct IntT ([signed? boolean?] 127 | [bits (apply or/c integer-bit-widths)])] 128 | [struct FloT ([bits (apply or/c float-bit-widths)])] 129 | [struct ArrT ([dim exact-nonnegative-integer?] [ety non-void-type?])] 130 | [struct RecT ([field->ty (hash/c symbol? non-void-type?)] 131 | [field->c (hash/c symbol? c-identifier-string?)] 132 | [c-order (listof symbol?)])] 133 | [struct UniT ([mode->ty (hash/c symbol? non-void-type?)] 134 | [mode->c (hash/c symbol? c-identifier-string?)])] 135 | [struct ExtT ([src ExternSrc?] [name string?])] 136 | [struct VoiT ()] 137 | [struct AnyT ()])) 138 | 139 | ;; Path 140 | (struct Path () #:transparent) 141 | (struct MetaP Path (m p) #:transparent) 142 | (provide 143 | (contract-out 144 | [struct Path ()] 145 | [struct MetaP ([m any/c] [p Path?])])) 146 | 147 | (define-unpacker unpack-MetaP MetaP Path?) 148 | (define-simple-macro (define-Path name:id ([field:id ctc:expr] ...)) 149 | (struct+ name Path MetaP unpack-MetaP ([field ctc] ...))) 150 | 151 | (define-Path Var ([x symbol?] [ty Type?])) 152 | (define-Path Global ([ty non-void-type?] [xi Init?])) 153 | (define-Path Select ([p Path?] [ie Expr?])) 154 | (define-Path Field ([p Path?] [f symbol?])) 155 | (define-Path Mode ([p Path?] [m symbol?])) 156 | (define-Path ExtVar ([src ExternSrc?] [name c-identifier-string?] [ty non-void-type?])) 157 | 158 | (define (Global*? x) 159 | (or (Global? x) 160 | (and (MetaP? x) (Global*? (MetaP-p x))))) 161 | 162 | ;; Expressions 163 | (struct Expr () #:transparent) 164 | (struct MetaE Expr (m e) #:transparent) 165 | (provide 166 | (contract-out 167 | [struct Expr ()] 168 | [struct MetaE ([m any/c] [e Expr?])])) 169 | 170 | (define-unpacker unpack-MetaE MetaE Expr?) 171 | (define-simple-macro (define-Expr name:id ([field:id ctc:expr] ...)) 172 | (struct+ name Expr MetaE unpack-MetaE ([field ctc] ...))) 173 | 174 | (define-Expr Int ([signed? boolean?] 175 | [bits (apply or/c integer-bit-widths)] 176 | [val exact-integer?])) 177 | (define-Expr Flo ([bits (apply or/c float-bit-widths)] 178 | [val (or/c single-flonum? double-flonum?)])) 179 | (define-Expr Cast ([ty Type?] [e Expr?])) 180 | (define-Expr Read ([p Path?])) 181 | (define-Expr BinOp ([op symbol?] [L Expr?] [R Expr?])) 182 | ;; DESIGN: We could instead make LamE and AppE then make expressions a 183 | ;; static simply-typed version of the lambda-calculus. I think this 184 | ;; would be overkill. We can do most of what we want with Racket 185 | ;; macros though. 186 | (define-Expr LetE ([x symbol?] [ty Type?] [xe Expr?] [be Expr?])) 187 | (define-Expr IfE ([ce Expr?] [te Expr?] [fe Expr?])) 188 | 189 | ;; Initializer 190 | (struct Init () #:transparent) 191 | (struct UndI Init (ty) #:transparent) 192 | (struct ConI Init (e) #:transparent) 193 | (struct ZedI Init (ty) #:transparent) 194 | (struct ArrI Init (is) #:transparent) 195 | (struct RecI Init (field->i) #:transparent) 196 | (struct UniI Init (mode i) #:transparent) 197 | 198 | (provide 199 | (contract-out 200 | [struct Init ()] 201 | [struct UndI ([ty Type?])] 202 | ;; DESIGN NOTE: It is unsafe for `e` to vary at runtime. We do not 203 | ;; protect against that possibility here, though, because the core 204 | ;; language is unsafe. 205 | [struct ConI ([e Expr?])] 206 | [struct ZedI ([ty Type?])] 207 | [struct ArrI ([is (listof Init?)])] 208 | [struct RecI ([field->i (hash/c symbol? Init?)])] 209 | [struct UniI ([mode symbol?] [i Init?])])) 210 | 211 | ;; Statements 212 | (struct Stmt () #:transparent) 213 | (struct MetaS Stmt (m bs) #:transparent) 214 | (provide 215 | (contract-out 216 | [struct Stmt ()] 217 | [struct MetaS ([m any/c] [bs Stmt?])])) 218 | 219 | (define-unpacker unpack-MetaS MetaS Stmt?) 220 | (define-simple-macro (define-Stmt name:id ([field:id ctc:expr] ...)) 221 | (struct+ name Stmt MetaS unpack-MetaS ([field ctc] ...))) 222 | 223 | (define-Stmt Skip ([comment (or/c #f string?)])) 224 | (define-Stmt Fail ([msg string?])) 225 | (define-Stmt Begin ([f Stmt?] [s Stmt?])) 226 | (define-Stmt Assign ([p Path?] [e Expr?])) 227 | (define-Stmt If ([p Expr?] [t Stmt?] [f Stmt?])) 228 | (define-Stmt While ([p Expr?] [body Stmt?])) 229 | (define-Stmt Jump ([label symbol?])) 230 | (define-Stmt Let/ec ([label symbol?] [body Stmt?])) 231 | (define-Stmt Let ([x symbol?] [ty Type?] [xi Init?] [bs Stmt?])) 232 | ;; DESIGN NOTE: `f` could be an `IntFun`, which includes `Stmt`, so 233 | ;; this is a mutually recursive definition. Alternatively, we could 234 | ;; treat functions like variables and have a name plus an environment 235 | ;; binding later in `Program`. 236 | (define-Stmt Call 237 | ([x symbol?] [ty Type?] [f Fun?] [as (listof (or/c Expr? Path?))] [bs Stmt?])) 238 | 239 | ;; Functions 240 | (struct Arg (x ty mode) #:transparent) 241 | (define mode/c (or/c 'read-only 'copy 'ref)) 242 | ;; read-only := it and no piece of it can be modified (could be 243 | ;; implemented as read-only or copy) 244 | 245 | ;; ref := the function receives a pointer and all changes are 246 | ;; reflected back to caller, as if the function were inlined. This 247 | ;; should only work if the argument is a path. 248 | 249 | ;; copy := the function receives a shallow copy that may be modified, 250 | ;; but changes are not visible. 251 | 252 | (struct Fun () #:transparent) 253 | (struct MetaFun Fun (m f) #:transparent) 254 | 255 | (define-unpacker unpack-MetaFun MetaFun Fun?) 256 | (define-simple-macro (define-Fun name:id ([field:id ctc:expr] ...)) 257 | (struct+ name Fun MetaFun unpack-MetaFun ([field ctc] ...))) 258 | 259 | ;; This definition is carefully chosen to be trivially inline-able. 260 | ;; but the compiler MAY turn it into an actual function call (perhaps 261 | ;; if it is used many times) 262 | (define-Fun IntFun ([args (listof Arg?)] 263 | [ret-x symbol?] [ret-ty Type?] 264 | [ret-lab symbol?] [body Stmt?])) 265 | (define-Fun ExtFun ([src ExternSrc?] 266 | [args (listof Arg?)] 267 | [ret-ty Type?] 268 | [name c-identifier-string?])) 269 | 270 | (define (Fun-args f) 271 | (match (unpack-MetaFun f) 272 | [(? IntFun? f) 273 | (IntFun-args f)] 274 | [(? ExtFun? f) 275 | (ExtFun-args f)])) 276 | 277 | (define (Fun-ret-ty f) 278 | (match (unpack-MetaFun f) 279 | [(? IntFun? f) 280 | (IntFun-ret-ty f)] 281 | [(? ExtFun? f) 282 | (ExtFun-ret-ty f)])) 283 | 284 | (provide 285 | (contract-out 286 | [struct Arg ([x symbol?] [ty non-void-type?] [mode mode/c])] 287 | [struct Fun ()] 288 | [struct MetaFun ([m any/c] [f Fun?])] 289 | [Fun-args (-> (or/c IntFun? ExtFun? MetaFun?) (listof Arg?))] 290 | [Fun-ret-ty (-> (or/c IntFun? ExtFun? MetaFun?) Type?)])) 291 | 292 | (define (IntFun*? x) 293 | (or (IntFun? x) 294 | (and (MetaFun? x) (IntFun*? (MetaFun-f x))))) 295 | 296 | (define (unpack-any v) 297 | (match v 298 | [(? Path?) (unpack-MetaP v)] 299 | [(? Expr?) (unpack-MetaE v)] 300 | [(? Stmt?) (unpack-MetaS v)] 301 | [(? Fun?) (unpack-MetaFun v)])) 302 | (provide 303 | (contract-out 304 | [unpack-any (-> (or/c Path? Expr? Stmt? Fun?) 305 | (or/c Path? Expr? Stmt? Fun?))])) 306 | 307 | (struct name-tag (n) #:transparent) 308 | (define (given-name v) 309 | (match v 310 | [(MetaFun (name-tag n) _) n] 311 | [(MetaFun _ f) (given-name f)] 312 | [(MetaP (name-tag n) _) n] 313 | [(MetaP _ p) (given-name p)] 314 | [(or (? Fun?) (? Path?)) #f])) 315 | (define (give-name v n) 316 | (cond [(Fun? v) (MetaFun (name-tag n) v)] 317 | [(Path? v) (MetaP (name-tag n) v)])) 318 | (provide 319 | (contract-out 320 | [given-name (-> (or/c Path? Fun?) (or/c symbol? #f))] 321 | [give-name (-> (or/c Path? Fun?) symbol? (or/c MetaP? MetaFun?))])) 322 | 323 | 324 | ;; Program 325 | (struct Program (name->global name->ty name->fun) #:transparent) 326 | 327 | (provide 328 | (contract-out 329 | [struct Program ([name->global (hash/c c-identifier-string? Global*?)] 330 | [name->ty (hash/c c-identifier-string? Type?)] 331 | [name->fun (hash/c c-identifier-string? IntFun*?)])])) 332 | -------------------------------------------------------------------------------- /type.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/struct-info 4 | racket/syntax) 5 | racket/contract/base 6 | racket/hash 7 | racket/match 8 | racket/set 9 | syntax/parse/define 10 | "ast.rkt" 11 | "print.rkt" 12 | "util.rkt") 13 | 14 | ;; Type for exceptions raised by the ADQC type checker. 15 | (struct exn:fail:adqc:type exn:fail ()) 16 | (provide (struct-out exn:fail:adqc:type)) 17 | 18 | (define (raise-adqc-type-error fmt args blame cc) 19 | (define out (open-output-string)) 20 | (print-ast blame out) 21 | (define msg (apply format fmt (snoc args (get-output-string out)))) 22 | (raise (exn:fail:adqc:type msg cc))) 23 | 24 | ;; XXX Maybe this isn't the best way to do this. My first instinct is to capture 25 | ;; the AST node which is creating the error and print it along with the error 26 | ;; message, but this may result in unreadable output for Let, LetE, and Call 27 | ;; nodes, as they contain the rest of the function as their body. Maybe have 28 | ;; different reporting schemes for syntax which makes declarations and has a body 29 | ;; (Let, LetE, Call, IntFun, etc?) and other types of syntax? 30 | (begin-for-syntax 31 | (define (make-reporter blame-ast-stx) 32 | (syntax-parser 33 | [(_ msg:str args:expr ...) 34 | (define msg-str (syntax->datum #'msg)) 35 | (define msg-full-str (string-append msg-str "\nBlaming AST: ~a")) 36 | (with-syntax ([msg-full (datum->syntax #'msg msg-full-str)]) 37 | (quasisyntax/loc this-syntax 38 | (raise-adqc-type-error 39 | msg-full (list args ...) #,blame-ast-stx 40 | (current-continuation-marks))))]))) 41 | (define-simple-macro (define-reporter name:id blame-ast:expr) 42 | (define-syntax name (make-reporter #'blame-ast))) 43 | 44 | (struct env-info (env) #:transparent) 45 | (struct type-info env-info (ty) #:transparent) 46 | 47 | (define i-arith-ops '(iadd isub imul iudiv isdiv iurem isrem ishl ilshr iashr iand ior ixor)) 48 | (define f-arith-ops '(fadd fsub fmul fdiv frem)) 49 | (define i-cmp-ops '(ieq ine iugt iuge iult iule isgt isge islt isle)) 50 | (define f-cmp-ops '(foeq fone fogt foge folt fole fueq fune 51 | fugt fuge fult fule ffalse ftrue ford funo)) 52 | 53 | (define (type=? L R) 54 | (or (AnyT? L) (AnyT? R) (equal? L R))) 55 | 56 | (define (union-subset? u ty) 57 | (match-define (UniT m->ty _) u) 58 | (for/or ([u-ty (in-hash-values m->ty)]) 59 | (cond [(type=? ty u-ty) #t] 60 | [(UniT? u-ty) (union-subset? u-ty ty)] 61 | [else #f]))) 62 | 63 | (define (resolve-type L R) 64 | (cond [(AnyT? L) R] 65 | [(AnyT? R) L] 66 | [(equal? L R) L] 67 | [else (cond [(and (UniT? L) (union-subset? L R)) L] 68 | [(and (UniT? R) (union-subset? R L)) R] 69 | [else (error 'resolve-type "type mismatch L: ~v R: ~v" L R)])])) 70 | (provide 71 | (contract-out 72 | [resolve-type (-> Type? Type? Type?)])) 73 | 74 | (define (env-union e0 . es) 75 | (apply hash-union e0 es #:combine resolve-type)) 76 | 77 | (define (IntT/any? v) 78 | (or (IntT? v) (AnyT? v))) 79 | 80 | (define (FloT/any? v) 81 | (or (FloT? v) (AnyT? v))) 82 | 83 | (define (expr-type-info e) 84 | (define-reporter report e) 85 | (match e 86 | [(MetaE (? type-info? ti) _) ti] 87 | [(MetaE _ e) (expr-type-info e)] 88 | [(Int signed? bits _) 89 | (type-info (hasheq) (IntT signed? bits))] 90 | [(Flo bits _) 91 | (type-info (hasheq) (FloT bits))] 92 | [(Cast to-ty e) 93 | (match-define (type-info from-env from-ty) 94 | (expr-type-info e)) 95 | (unless (or (ExtT? from-ty) (ExtT? to-ty)) 96 | (unless (or (IntT? from-ty) (FloT? from-ty)) 97 | (report "Cast: can't cast from non-numeric type ~v" from-ty)) 98 | (unless (or (IntT? to-ty) (FloT? to-ty)) 99 | (report "Cast: can't cast to non-numeric type ~v" to-ty))) 100 | (type-info from-env to-ty)] 101 | [(Read p) 102 | (path-type-info p)] 103 | [(BinOp op L R) 104 | (match-define (type-info L-env L-ty) 105 | (expr-type-info L)) 106 | (match-define (type-info R-env R-ty) 107 | (expr-type-info R)) 108 | (unless (type=? L-ty R-ty) 109 | (report "BinOp: LHS type ~v and RHS type ~v not equal" L-ty R-ty)) 110 | (define the-ty (resolve-type L-ty R-ty)) 111 | (when (or (set-member? i-arith-ops op) (set-member? i-cmp-ops op)) 112 | (unless (IntT/any? the-ty) 113 | (report "BinOp: integer op expects integral arguments, given ~v, ~v" 114 | L-ty R-ty))) 115 | (when (or (set-member? f-arith-ops op) (set-member? f-cmp-ops op)) 116 | (unless (FloT/any? the-ty) 117 | (report 118 | "BinOp: floating-point op expects floating-point arguments, given ~v, ~v" 119 | L-ty R-ty))) 120 | ;; XXX add logic for union types. 121 | (define env (env-union L-env R-env)) 122 | (cond [(or (set-member? i-arith-ops op) (set-member? f-arith-ops op)) 123 | (type-info env the-ty)] 124 | [(or (set-member? i-cmp-ops op) (set-member? f-cmp-ops op)) 125 | (type-info env (IntT #t 32))])] 126 | [(LetE x ty xe be) 127 | (match-define (type-info xe-env xe-ty) 128 | (expr-type-info xe)) 129 | (unless (equal? ty xe-ty) 130 | (report "LetE: declaration '~a' has type ~v but is initialized as type ~v" 131 | x ty xe-ty)) 132 | (match-define (type-info be-env be-ty) 133 | (expr-type-info be)) 134 | ;; If x is not referenced in 'be', x will not be in be-env. 135 | ;; In this case, return ty to avoid error. 136 | (define be-x-ty (hash-ref be-env x ty)) 137 | (unless (equal? ty be-x-ty) 138 | (report 139 | "LetE: declaration '~a' has type ~v but is referenced as type ~v in body" 140 | x ty be-x-ty)) 141 | (type-info be-env be-ty)] 142 | [(IfE ce te fe) 143 | (match-define (type-info ce-env ce-ty) 144 | (expr-type-info ce)) 145 | (unless (IntT/any? ce-ty) 146 | (report "IfE: predicate type ~v not integral" ce-ty)) 147 | (match-define (type-info te-env te-ty) 148 | (expr-type-info te)) 149 | (match-define (type-info fe-env fe-ty) 150 | (expr-type-info fe)) 151 | (unless (type=? te-ty fe-ty) 152 | (report "IfE: 'then' type ~v and 'else' type ~v not equal" te-ty fe-ty)) 153 | (define the-ty (resolve-type te-ty fe-ty)) 154 | (define env (env-union ce-env te-env fe-env)) 155 | (type-info env the-ty)])) 156 | 157 | (define (path-type-info p) 158 | (define-reporter report p) 159 | (match p 160 | [(MetaP (? type-info? ti) _) ti] 161 | [(MetaP _ p) (path-type-info p)] 162 | [(Var x ty) (type-info (hash x ty) ty)] 163 | [(Global ty _) (type-info (hash) ty)] 164 | [(ExtVar _ name ty) 165 | (define x (string->symbol name)) 166 | (type-info (hash x ty) ty)] 167 | [(Select p ie) 168 | (match-define (type-info ie-env ie-ty) 169 | (expr-type-info ie)) 170 | (unless (IntT/any? ie-ty) 171 | (report "Select: index type ~v not integral" ie-ty)) 172 | (match-define (type-info p-env (and (ArrT dim ety) p-ty)) 173 | (path-type-info p)) 174 | ;; XXX Only checks for bounds when `ie` is a constant expression. 175 | ;; Eventually, this code should use results from the verifier to 176 | ;; implement a stricter check. 177 | (define ie* (unpack-MetaE ie)) 178 | (when (Int? ie*) 179 | (define idx (Int-val ie*)) 180 | (unless (and (exact-nonnegative-integer? idx) (< idx dim)) 181 | (report "Select: index ~a out of bounds for ~v" idx p-ty))) 182 | (define env (env-union ie-env p-env)) 183 | (type-info env ety)] 184 | [(Field p f) 185 | (match-define (type-info p-env (RecT f->ty _ _)) 186 | (path-type-info p)) 187 | (type-info p-env (hash-ref f->ty f))] 188 | [(Mode p m) 189 | (match-define (type-info p-env (UniT m->ty _)) 190 | (path-type-info p)) 191 | (type-info p-env (hash-ref m->ty m))])) 192 | 193 | (define (stmt-env-info s) 194 | (define-reporter report s) 195 | (define (rec s) (stmt-env-info s)) 196 | (match s 197 | [(MetaS (? env-info? ei) _) ei] 198 | [(MetaS _ s) (stmt-env-info s)] 199 | [(? (or/c Skip? Fail? Jump?)) (env-info (hasheq))] 200 | [(Begin f s) 201 | (match-define (env-info f-env) (rec f)) 202 | (match-define (env-info s-env) (rec s)) 203 | (env-info (env-union f-env s-env))] 204 | [(Assign p e) 205 | (match-define (type-info p-env p-ty) 206 | (path-type-info p)) 207 | (match-define (type-info e-env e-ty) 208 | (expr-type-info e)) 209 | (unless (type=? p-ty e-ty) 210 | (report 211 | "Assign: path type ~v and expression type ~v not equal" 212 | p-ty e-ty)) 213 | (env-info (env-union p-env e-env))] 214 | [(If p t f) 215 | (match-define (type-info p-env p-ty) 216 | (expr-type-info p)) 217 | (match-define (env-info t-env) (rec t)) 218 | (match-define (env-info f-env) (rec f)) 219 | (unless (IntT/any? p-ty) 220 | (report "If: predicate type ~v not integral" p-ty)) 221 | (env-info (env-union p-env t-env f-env))] 222 | [(While p body) 223 | (match-define (type-info p-env p-ty) 224 | (expr-type-info p)) 225 | (unless (IntT/any? p-ty) 226 | (report "While: predicate type ~v not integral" p-ty)) 227 | (match-define (env-info body-env) (rec body)) 228 | (env-info (env-union p-env body-env))] 229 | [(Let/ec _ body) (rec body)] 230 | [(Let x ty xi bs) 231 | (check-init-type s ty xi) 232 | (match-define (env-info bs-env) (rec bs)) 233 | (define bs-x-ty (hash-ref bs-env x ty)) 234 | (unless (type=? ty bs-x-ty) 235 | (report 236 | "Let: declaration '~a' has type ~v but is referenced as type ~v in body" 237 | x ty bs-x-ty)) 238 | (env-info bs-env)] 239 | [(Call x ty f as bs) 240 | (match-define (or (IntFun f-as _ ret-ty _ _) (ExtFun _ f-as ret-ty _)) 241 | (unpack-MetaFun f)) 242 | (define f-as-length (length f-as)) 243 | (define as-length (length as)) 244 | (unless (= f-as-length as-length) 245 | (report "Call: given ~a arguments, expected ~a" as-length f-as-length)) 246 | (unless (equal? ret-ty ty) 247 | (report 248 | "Call: declaration '~a' has type ~v but is initialized as type ~v" 249 | x ret-ty ty)) 250 | (for ([a (in-list as)] [fa (in-list f-as)] [i (in-naturals 1)]) 251 | (define a-ty (type-info-ty 252 | (cond [(Expr? a) (expr-type-info a)] 253 | [(Path? a) (path-type-info a)]))) 254 | (unless (type=? a-ty (Arg-ty fa)) 255 | (report "Call: expected type ~v for argument ~a, given ~v" fa i a))) 256 | (match-define (env-info bs-env) (rec bs)) 257 | (define bs-x-ty (hash-ref bs-env x ty)) 258 | (unless (type=? ty bs-x-ty) 259 | (report 260 | "Call: declaration '~a' has type ~v but is referenced as type ~v in body" 261 | x ty bs-x-ty)) 262 | (env-info bs-env)])) 263 | 264 | ;; XXX Improve this, maybe check-init-type should instead be 265 | ;; init-type and just take an Init and return a type. That way 266 | ;; the calling function would be responsible for checking for 267 | ;; outer-level type mismatches and this function would only 268 | ;; error when internally inconsistent. 269 | (define (check-init-type outer-s ty i) 270 | (define-reporter report outer-s) 271 | (define (rec ty i) (check-init-type outer-s ty i)) 272 | (match i 273 | [(UndI u-ty) 274 | (unless (equal? ty u-ty) 275 | (report "UndI: type mismatch with ~v and ~v" ty u-ty))] 276 | [(ConI e) 277 | (match-define (type-info _ e-ty) (expr-type-info e)) 278 | (unless (equal? ty e-ty) 279 | (report "ConI: type mismatch with ~v and ~v" ty e-ty))] 280 | [(ZedI z-ty) 281 | (unless (equal? ty z-ty) 282 | (report "ZedI: type mismatch with ~v and ~v" ty z-ty))] 283 | [(ArrI is) 284 | (define is-len (length is)) 285 | (define ty-dim (ArrT-dim ty)) 286 | (unless (equal? is-len ty-dim) 287 | (report "ArrI: length mismatch, ~a != ~a" is-len ty-dim)) 288 | (for ([i (in-list is)]) 289 | (rec (ArrT-ety ty) i))] 290 | [(RecI f->i) 291 | (match-define (RecT f->ty _ _) ty) 292 | (for ([(f i) (in-hash f->i)]) 293 | (rec (hash-ref f->ty f) i))] 294 | [(UniI m i) 295 | (match-define (UniT m->ty _) ty) 296 | (rec (hash-ref m->ty m) i)])) 297 | 298 | (define (fun-type-info f) 299 | (define-reporter report f) 300 | (match f 301 | [(MetaFun (? type-info? ti) _) ti] 302 | [(MetaFun _ f) (fun-type-info f)] 303 | [(IntFun args ret-x ret-ty _ body) 304 | (match-define (env-info env) 305 | (stmt-env-info body)) 306 | (unless (VoiT? ret-ty) 307 | (define (ret-x-not-referenced!) 308 | (report "IntFun: return type declared as ~v, but no value is returned" 309 | ret-ty)) 310 | (define body-ret-x-ty (hash-ref env ret-x ret-x-not-referenced!)) 311 | (unless (equal? ret-ty body-ret-x-ty) 312 | (report 313 | "IntFun: return type declared as ~v but returns value of type ~v" 314 | ret-ty body-ret-x-ty))) 315 | (for ([a (in-list args)] [i (in-naturals 1)]) 316 | (match-define (Arg x ty _) a) 317 | (define body-x-ty (hash-ref env x ty)) 318 | (unless (equal? ty body-x-ty) 319 | (report 320 | "IntFun: argument ~a declared as type ~v but referenced as type ~v in body" 321 | i ty body-x-ty))) 322 | (type-info env ret-ty)] 323 | ;; XXX Should we somehow be tracking ExtFun declarations and making sure 324 | ;; that all ExtFuns which share 'name' are really equal? 325 | [(ExtFun _ args ret-ty _) (type-info (hasheq) ret-ty)])) 326 | 327 | (define-simple-macro (define-ensurer name:id meta-type info-proc) 328 | (define (name v) 329 | (let rec ([v* v]) 330 | (match v* 331 | [(meta-type (? env-info? info) _) info] 332 | [(meta-type _ v*) (rec v*)] 333 | [_ (meta-type (info-proc v*) v)])))) 334 | 335 | (define-ensurer ensure-expr-type MetaE expr-type-info) 336 | (define-ensurer ensure-path-type MetaP path-type-info) 337 | (define-ensurer ensure-stmt-env MetaS stmt-env-info) 338 | (define-ensurer ensure-fun-type MetaFun fun-type-info) 339 | 340 | (begin-for-syntax 341 | (struct typed-constructor (ctor ensure) 342 | #:property prop:struct-info 343 | (λ (this) 344 | (extract-struct-info 345 | (syntax-local-value (typed-constructor-ctor this)))) 346 | #:property prop:match-expander 347 | (λ (this stx) 348 | (syntax-parse stx 349 | [(_ args:expr ...) 350 | #:with ctor (typed-constructor-ctor this) 351 | (syntax/loc stx 352 | (ctor args ...))])) 353 | #:property prop:procedure 354 | (λ (this stx) 355 | (syntax-parse stx 356 | [me:id 357 | #:with ctor (typed-constructor-ctor this) 358 | #:with ensure (typed-constructor-ensure this) 359 | (quasisyntax/loc stx 360 | (contract 361 | (value-contract ctor) 362 | (λ args (ensure (apply ctor args))) 363 | (syntax-source #'ctor) #'#,stx 'me #'ctor))] 364 | [(me:id . args) 365 | (syntax/loc stx 366 | (#%app me . args))])))) 367 | 368 | (define-syntax (define-constructor stx) 369 | (syntax-parse stx 370 | [(_ name:id ensure) 371 | #:with name^ (generate-temporary #'name) 372 | (syntax/loc stx 373 | (begin 374 | (define-syntax name^ (typed-constructor #'name #'ensure)) 375 | (provide (rename-out [name^ name]))))])) 376 | 377 | (define-simple-macro (define-exprs name:id ...) 378 | (begin (define-constructor name ensure-expr-type) ...)) 379 | (define-exprs Int Flo Cast Read BinOp LetE IfE) 380 | 381 | (define-simple-macro (define-paths name:id ...) 382 | (begin (define-constructor name ensure-path-type) ...)) 383 | (define-paths Var Select Field Mode ExtVar) 384 | 385 | (define-simple-macro (define-stmts name:id ...) 386 | (begin (define-constructor name ensure-stmt-env) ...)) 387 | (define-stmts Skip Fail Begin Assign If While Jump Let/ec Let Call) 388 | 389 | (define-simple-macro (define-funs name:id ...) 390 | (begin (define-constructor name ensure-fun-type) ...)) 391 | (define-funs IntFun ExtFun) 392 | 393 | (define (expr-type e) 394 | (type-info-ty (expr-type-info e))) 395 | (define (path-type p) 396 | (type-info-ty (path-type-info p))) 397 | (define (fun-type f) 398 | (type-info-ty (fun-type-info f))) 399 | (provide 400 | (contract-out 401 | [expr-type (-> Expr? Type?)] 402 | [path-type (-> Path? Type?)] 403 | [fun-type (-> Fun? Type?)])) 404 | -------------------------------------------------------------------------------- /doc/ast.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require scribble/eval 3 | (for-label adqc 4 | racket/base 5 | racket/contract 6 | racket/list)) 7 | 8 | @title[#:tag "ast"]{AST} 9 | 10 | @(define the-eval (make-base-eval)) 11 | @(the-eval '(require adqc)) 12 | 13 | @defmodule[adqc/ast] 14 | 15 | @author[@author+email["Conor Finegan" "theconor4@gmail.com"]] 16 | 17 | AST nodes used in construction of @racketmodname[adqc] programs. 18 | 19 | @section{Types} 20 | 21 | @defstruct*[Type ()]{ 22 | All @racketmodname[adqc] types are derived from @racket[Type]. 23 | } 24 | 25 | @defstruct*[(IntT Type) ([signed? boolean?] [bits (or/c 8 16 32 64)])]{ 26 | A @racket[Type] representing a signed or unsigned integer value. 27 | } 28 | 29 | @defstruct*[(FloT Type) ([bits (or/c 32 64)])]{ 30 | A @racket[Type] represending a floating-point value. 31 | } 32 | 33 | @defstruct*[(ArrT Type) ([dim exact-nonnegative-integer?] 34 | [ety non-void-type?])]{ 35 | A @racket[Type] representing an array of length @racket[dim] containing values 36 | of type @racket[ety]. Arrays in @racketmodname[adqc] are reference types. 37 | } 38 | 39 | @defstruct*[(RecT Type) ([field->ty (hash/c symbol? non-void-type?)] 40 | [field->c (hash/c symbol? c-identifier-string?)] 41 | [c-order (listof symbol?)])]{ 42 | A @racket[Type] representing a record. Records in @racketmodname[adqc] are 43 | reference types, and are compiled into native C structs. The ordering of 44 | fields in the C struct can be controlled with @racket[c-order]. 45 | } 46 | 47 | @defstruct*[(UniT Type) ([mode->ty (hash/c symbol? non-void-type?)] 48 | [mode->c (hash/c symbol? c-identifier-string?)])]{ 49 | A @racket[Type] representing a union. Unions in @racketmodname[adqc] are 50 | reference types, and are compiled into native C unions. 51 | } 52 | 53 | @defstruct*[(ExtT Type) ([src ExternSrc?] [name string?])]{ 54 | A @racket[Type] representing an opaque type. The string provided for 55 | @racket[name] is emitted literally into the resulting C program. 56 | Programs that use @racket[ExtT] are considered unsafe. 57 | } 58 | 59 | @defstruct*[(VoiT Type) ()]{ 60 | A @racket[Type] that corresponds to C's @tt{void} type. Useful for 61 | declaring functions that return @tt{void}, and not much else. 62 | } 63 | 64 | @defstruct*[(AnyT Type) ()]{ 65 | A value of type @racket[AnyT] is considered valid for the purpose of type 66 | checking when compared to any other @racket[Type]. This is used to implement 67 | ANF support for language features that manipulate program control flow, such 68 | as @tt{error} and @tt{let/ec}. Most @racketmodname[adqc] programs will 69 | not need to explicitly declare variables of this type. 70 | } 71 | 72 | @defproc[(non-void-type? [v any/c]) boolean?]{ 73 | Equivalent to @racket[(and/c Type? (not/c VoiT?))]. 74 | } 75 | 76 | @section{Paths} 77 | 78 | A Path is a reference some previously declared value in memory. 79 | 80 | @defstruct*[Path ()]{ 81 | All @racketmodname[adqc] paths are derived from @racket[Path]. 82 | } 83 | 84 | @defstruct*[(MetaP Path) ([m any/c] [p Path?])]{ 85 | A "Meta Path" containing some metadata @racket[m], which describes a 86 | @racket[Path] @racket[p]. Multiple layers of nesting are allowed, so 87 | @racket[p] may itself be a @racket[MetaP]. 88 | } 89 | 90 | @defproc[(unpack-MetaP [p Path?]) Path?]{ 91 | Recursively removes metadata from @racket[p], returning the @racket[Path] 92 | within, with no metadata. 93 | } 94 | 95 | @defstruct*[(Var Path) ([x symbol?] [ty Type?])]{ 96 | A reference to a local variable with name @racket[x] and type @racket[ty]. 97 | } 98 | 99 | @defstruct*[(Global Path) ([ty non-void-type?] [xi Init?])]{ 100 | A globablly-accessable variable, analagous to a static global variable in C. 101 | Two references to a @racket[Global] are considered to reference the same 102 | variable in the resulting program when when they compare equal using 103 | @racket[eq?]. I.e., two @racket[Global]s can have the same @racket[ty] 104 | (be the same type) and @racket[xi] (be initialized to the same value) without 105 | necessarily referencing the same global variable, so @racket[equal?] should 106 | not be used to infer this. 107 | } 108 | 109 | @defstruct*[(Select Path) ([p Path?] [ie Expr?])]{ 110 | A @racket[Path] to a value stored in an array. The value stored at @racket[p] 111 | must be of type @racket[ArrT?], and the value produced by @racket[ie] must be 112 | of type @racket[IntT?]. 113 | } 114 | 115 | @defstruct*[(Field Path) ([p Path?] [f symbol?])]{ 116 | A @racket[Path] to a value stored in a field of a record. The value stored at 117 | @racket[p] must be of type @racket[RecT?], and @racket[f] must be a field in 118 | that record. 119 | } 120 | 121 | @defstruct*[(Mode Path) ([p Path?] [m symbol?])]{ 122 | A @racket[Path] to a union, the value of which will be interpreted according 123 | to mode @racket[m]. The value stored at @racket[p] must be of type 124 | @racket[UniT?], and @racket[m] must be a mode of that union. 125 | } 126 | 127 | @defstruct*[(ExtVar Path) ([src ExternSrc?] 128 | [name c-identifier-string?] 129 | [ty non-void-type?])]{ 130 | A @racket[Path] to an externally-defined variable, e.g., @tt{errno}. 131 | The string provided for @racket[name] is emitted literally into the resulting 132 | C program. Programs that use @racket[ExtVar] are considered unsafe. 133 | } 134 | 135 | @section{Expressions} 136 | 137 | Expressions produce a value and have no side effects, other than reading 138 | from memory. 139 | 140 | @defstruct*[Expr ()]{ 141 | All @racketmodname[adqc] expressions are derived from @racket[Expr]. 142 | } 143 | 144 | @defstruct*[(MetaE Expr) ([m any/c] [e Expr?])]{ 145 | A "Meta Expression" containing some metadata @racket[m], which describes an 146 | @racket[Expr] @racket[e]. Multiple layers of nesting are allowed, so 147 | @racket[e] may itself be a @racket[MetaE]. 148 | } 149 | 150 | @defproc[(unpack-MetaE [e Expr?]) Expr?]{ 151 | Recursively removes metadata from @racket[e], returning the @racket[Expr] 152 | within, with no metadata. 153 | } 154 | 155 | @defstruct*[(Int Expr) ([signed? boolean?] 156 | [bits (or/c 8 16 32 64)] 157 | [val exact-integer?])]{ 158 | An integer value, signed or unsigned. 159 | } 160 | 161 | @defstruct*[(Flo Expr) ([bits (or/c 32 64)] 162 | [val (or/c single-flonum? double-flonum?)])]{ 163 | An IEEE 754 floating point value. 164 | } 165 | 166 | @defstruct*[(Cast Expr) ([ty Type?] [e Expr?])]{ 167 | Casts @racket[e] to a new type. The types @racket[ty] and 168 | @racket[e] must be arithmetic (i.e., @racket[IntT?] or @racket[FloT?]). 169 | } 170 | 171 | @defstruct*[(Read Expr) ([p Path?])]{ 172 | Produces the value stored at @racket[p]. 173 | } 174 | 175 | @defstruct*[(BinOp Expr) ([op symbol?] [L Expr?] [R Expr?])]{ 176 | A binary operation with left-hand side @racket[L] and right-hand side 177 | @racket[R]. XXX: List of valid ops. 178 | } 179 | 180 | @defstruct*[(LetE Expr) ([x symbol?] [ty Type?] [xe Expr?] [be Expr?])]{ 181 | Like @racket[Let], but as an @racket[Expr]. The syntax produced by @racket[xe] 182 | is substituted literally for @racket[x] in @racket[be]. I.e., 183 | @tt{(let ([x (+ 1 2)]) (* x x))} is equivalent to @tt{(* (+ 1 2) (+ 1 2))}. 184 | } 185 | 186 | @defstruct*[(IfE Expr) ([ce Expr?] [te Expr?] [fe Expr?])]{ 187 | Like @racket[If], but as an @racket[Expr]. 188 | Equivalent to the ternary operator in C. 189 | } 190 | 191 | @section{Initializers} 192 | 193 | An initializer produces a value that is suitable for initializing a 194 | newly-declared variable. 195 | 196 | @defstruct*[Init ()]{ 197 | All @racketmodname[adqc] initializers are derived from @racket[Init]. 198 | } 199 | 200 | @defstruct*[(UndI Init) ([ty Type?])]{ 201 | Perform no initialization. This is equialent to to declaration like 202 | @tt{int x;} in C. 203 | } 204 | 205 | @defstruct*[(ConI Init) ([e Expr?])]{ 206 | Initialize with the value produced by @racket[e]. If @racket[e] contains 207 | any @racket[Read]s, then the resulting program is considered unsafe. 208 | } 209 | 210 | @defstruct*[(ZedI Init) ([ty Type?])]{ 211 | Initialize with zero. This is equivalent to @tt["{ 0 }"] when initializing 212 | a value of type @racket[ArrT?], @racket[RecT?], or @racket[UniT?] (an array, 213 | record, or union). 214 | } 215 | 216 | @defstruct*[(ArrI Init) ([is (listof Init?)])]{ 217 | Initialize an array. The value being initialized must be of type 218 | @racket[ArrT?], and length of @racket[is] must be equal to the length 219 | of the array being initialized. 220 | } 221 | 222 | @defstruct*[(RecI Init) ([field->i (hash/c symbol? Init?)])]{ 223 | Initialize a record. The value being initialized must be of type 224 | @racket[RecT?]. XXX: Does field->i need entry for every field? 225 | } 226 | 227 | @defstruct*[(UniI Init) ([mode symbol?] [i Init?])]{ 228 | Initialize a union. The value being initialized must be of type 229 | @racket[UniT?], and @racket[mode] must be a mode of that union. 230 | } 231 | 232 | @section{Statements} 233 | 234 | A statement does not produce a value, but instead has some side effect. 235 | 236 | @defstruct*[Stmt ()]{ 237 | All @racketmodname[adqc] statements are derived from @racket[Stmt]. 238 | } 239 | 240 | @defstruct*[(MetaS Stmt) ([m any/c] [bs Stmt?])]{ 241 | A "Meta Statement" containing some metadata @racket[m], which describes a 242 | @racket[Stmt] @racket[bs]. Multiple layers of nesting are allowed, so 243 | @racket[bs] may itself be a @racket[MetaS]. 244 | } 245 | 246 | @defproc[(unpack-MetaS [s Stmt?]) Stmt?]{ 247 | Recursively removes metadata from @racket[s], returning the @racket[Stmt] 248 | within, with no metadata. 249 | } 250 | 251 | @defstruct*[(Skip Stmt) ([comment (or/c #f string?)])]{ 252 | A null operation, or no-op. If @racket[comment] is not @racket[#f], then 253 | it is emitted into the resulting program as a comment. 254 | } 255 | 256 | @defstruct*[(Fail Stmt) ([msg string?])]{ 257 | Signal that some error has occurred. Currently, this prints @racket[msg] 258 | to @tt{stderr}, then calls @tt{exit(1)}. 259 | } 260 | 261 | @defstruct*[(Begin Stmt) ([f Stmt?] [s Stmt?])]{ 262 | Execute @racket[f], then @racket[s]. 263 | } 264 | 265 | @defstruct*[(Assign Stmt) ([p Path?] [e Expr?])]{ 266 | Assign a new value to a previously-declared variable. 267 | } 268 | 269 | @defstruct*[(If Stmt) ([p Expr?] [t Stmt] [f Stmt])]{ 270 | If @racket[p] is truthy (non-zero), then execute @racket[t]. Otherwise, 271 | execute @racket[f]. The @racket[Expr] @racket[p] must produce a value 272 | of type @racket[IntT?]. Equivalent to an @tt{if} statement in C. 273 | } 274 | 275 | @defstruct*[(While Stmt) ([p Expr?] [body Stmt?])]{ 276 | Executes @racket[body] as long as @racket[p] is truthy (non-zero). The 277 | @racket[Expr] @racket[p] must produce a value of type @racket[IntT?]. 278 | Equivalent to a @tt{while} statement in C. 279 | } 280 | 281 | @defstruct*[(Jump Stmt) ([label symbol?])]{ 282 | Jump to @racket[label]. Equivalent to @tt{goto} in C. 283 | } 284 | 285 | @defstruct*[(Let/ec Stmt) ([label symbol?] [body Stmt?])]{ 286 | Execute @racket[body]. Within @racket[body], @racket[Jump]ing to 287 | @racket[label] wil skip the rest of @racket[body]. Like @racket[let/ec] 288 | in Racket, but without a return value. 289 | } 290 | 291 | @defstruct*[(Let Stmt) ([x symbol?] [ty Type?] [xi Init?] [bs Stmt?])]{ 292 | Declares a new variable. Within the body statement @racket[bs], @racket[x] 293 | refers to a @racket[Var] of type @racket[ty], initialized with @racket[xi]. 294 | Equivalent to a local variable declaration in C. 295 | } 296 | 297 | @defstruct*[(Call Stmt) ([x symbol?] 298 | [ty Type?] 299 | [f Fun?] 300 | [as (listof (or/c Expr? Path?))] 301 | [bs Stmt?])]{ 302 | Invokes the function @racket[f] with arguments @racket[as], storing the 303 | result in a new @racket[Var] named @racket[x]. Works similarly to 304 | @racket[Let], creating a new variable that can be referenced within 305 | @racket[body]. 306 | } 307 | 308 | @section{Functions} 309 | 310 | A function, which can be invoked through @racket[Call]. 311 | 312 | @defstruct*[Fun ()]{ 313 | All @racketmodname[adqc] functions are derived from @racket[Fun]. 314 | } 315 | 316 | @defstruct*[(MetaFun Fun) ([m any/c] [f Fun?])]{ 317 | A "Meta Function" containing some metadata @racket[m], which describes an 318 | @racket[Fun] @racket[f]. Multiple layers of nesting are allowed, so 319 | @racket[f] may itself be a @racket[MetaFun]. 320 | } 321 | 322 | @defproc[(unpack-MetaFun [f Fun?]) Fun?]{ 323 | Recursively removes metadata from @racket[f], returning the @racket[Fun] 324 | within, with no metadata. 325 | } 326 | 327 | @defstruct*[(IntFun Fun) ([args (listof Arg?)] 328 | [ret-x symbol?] 329 | [ret-ty Type?] 330 | [ret-lab symbol?] 331 | [body Stmt?])]{ 332 | An "Internal Function". Functions written in @racketmodname[adqc] are compiled 333 | into these. Functions in @racketmodname[adqc] convey their return value by 334 | declaring a variable @racket[ret-x] to hold it, and return by @racket[Jump]ing 335 | to the label @racket[ret-lab]. This enables easily inlining an @racket[IntFun] 336 | by transforming it int an equivalent @racket[Let/ec]. 337 | } 338 | 339 | @defstruct*[(ExtFun Fun) ([src ExternSrc?] 340 | [args (listof Arg?)] 341 | [ret-ty Type?] 342 | [name c-identifier-string?])]{ 343 | An "External Function" that references some externally-defined native function, 344 | e.g., @tt{exit} or @tt{write}. Programs that use @racket[ExtFun] are considered 345 | unsafe. 346 | } 347 | 348 | @defstruct*[Arg ([x symbol?] 349 | [ty non-void-type?] 350 | [mode (or/c 'read-only 'copy 'ref)])]{ 351 | An argument in a function declaration. Specifies the name, @racket[x], 352 | of the argument, as well as it's type, and whether it is to be passed by 353 | value (@racket['copy]), reference (@racket['ref]), or immutable reference 354 | (@racket['read-only]). 355 | 356 | Arrays, records, and unions are always passed by reference, even if 357 | @racket['copy] is specified for @racket[mode]. Types smaller than a pointer 358 | will be passed by value if @racket['read-only] is specified for @racket[mode], 359 | as an optimization. Immutability is still enforced. 360 | } 361 | 362 | @defproc[(Fun-args [f (or/c IntFun? ExtFun?)]) (listof Arg?)]{ 363 | Returns a list containing the arguments for @racket[f]. This is defined for 364 | convenience and works with both @racket[IntFun] and @racket[ExtFun]. 365 | } 366 | 367 | @defproc[(Fun-ret-ty [f (or/c IntFun? ExtFun?)]) Type?]{ 368 | Returns the return type of @racket[f]. This is defined for convenience and 369 | works with both @racket[IntFun] and @racket[ExtFun]. 370 | } 371 | 372 | @section{Program} 373 | 374 | @defstruct*[Program ([name->global (hash/c c-identifier-string? Global?)] 375 | [name->ty (hash/c c-identifier-string? Type?)] 376 | [name->fun (hash/c c-identifier-string IntFun?)])]{ 377 | A whole @racketmodname[adqc] program. @racket[name->global], 378 | @racket[name->ty], and @racket[name->fun] refer to public global variables, 379 | type declarations, and funcions respectively. 380 | } 381 | 382 | @section{Misc} 383 | 384 | @defproc[(c-identifier-string? [v any/c]) boolean?]{ 385 | Predicate returns @racket[#t] if @racket[v] is a valid identifier string in C. 386 | This is a partial test. 387 | } 388 | 389 | @defproc[(c-library-string? [v any/c]) boolean?]{ 390 | Predicate returns @racket[#t] if @racket[v] is a valid name for a C library, 391 | meaning that it would be valid to the right of @tt{-l} in @tt{cc}. 392 | Currently this is equivalent to @racket[string?]. 393 | } 394 | 395 | @defproc[(c-header-string? [v any/c]) boolean?]{ 396 | Predicate returns @racket[#t] if @racket[v] is a valid name 397 | for C header file, meaning that it would be valid inside the 398 | @tt{< >}s of an @tt{#include}. Currently this is equivalent 399 | to @racket[string?]. 400 | } 401 | 402 | @defproc[(cify [s symbol?]) c-identifier-string?]{ 403 | Sanitizes a variable name by removing from it any characters which are 404 | not valid in a C identifier, and appending it with a unique number. These 405 | numbers are monotonically increasing, although this counter can be reset 406 | using @racket[with-cify-counter]. Note that although the argument @racket[s] 407 | is a @racket[symbol?], the return value is a @racket[string?]. 408 | } 409 | 410 | @defform[(with-cify-counter body ...+)]{ 411 | Calls to @racket[cify] within @racket[body] will use a new counter when 412 | generating unique variable names, starting at @racket[0]. 413 | } 414 | 415 | @defstruct*[ExternSrc ([ls (listof c-library-string?)] 416 | [hs (listof c-header-string?)])]{ 417 | Represents an external code source, with @racket[ls] being a list of 418 | libraries to link against, and @racket[hs] being a list of header files 419 | to include. 420 | } 421 | 422 | @defproc[(give-name [v (or/c Path? Fun?)] [n symbol?]) (or/c MetaP? MetaFun?)]{ 423 | Attaches metadata to @racket[v] which suggests to the compiler that 424 | @racket[n] should be used as the name for @racket[v] in the output 425 | program. The name @racket[n] is not emitted literally in the output 426 | program - it is still uniquified through @racket[cify]. 427 | } 428 | 429 | @defproc[(given-name [v (or/c Path? Fun?)]) (or/c symbol? #f)]{ 430 | Returns the name previously given to @racket[v] through @racket[give-name], 431 | or @racket[#f] if @racket[v] was not previously given a name. 432 | } 433 | 434 | @defproc[(unpack-any [v (or/c Path? Expr? Stmt? Fun?)]) 435 | (or/c Path? Expr? Stmt? Fun?)]{ 436 | Calls @racket[unpack-MetaP], @racket[unpack-MetaE], @racket[unpack-MetaS], 437 | or @racket[unpack-MetaFun] depending on the type of the argument. Defined 438 | for convenience. 439 | } 440 | -------------------------------------------------------------------------------- /compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require data/queue 3 | graph 4 | racket/contract/base 5 | racket/format 6 | racket/function 7 | racket/list 8 | racket/match 9 | racket/set 10 | racket/string 11 | racket/system 12 | "ast.rkt" 13 | "print.rkt" 14 | (only-in "type.rkt" expr-type)) 15 | 16 | ;; XXX Read through https://queue.acm.org/detail.cfm?id=3212479 and 17 | ;; see if there are any changes we should have to our language 18 | ;; model. I think a lot of our choices are good because we don't make 19 | ;; promises about memory. 20 | 21 | 22 | (struct ret-info (x lab) #:transparent) 23 | 24 | (define current-ref-vars (make-parameter #f)) 25 | (define current-ret-info (make-parameter #f)) 26 | (define current-headers (make-parameter #f)) 27 | (define current-libs (make-parameter #f)) 28 | (define current-fun (make-parameter #f)) 29 | (define current-fun-queue (make-parameter #f)) 30 | (define current-fun-graph (make-parameter #f)) 31 | ;; Σ is a renaming environment for public functions 32 | (define current-Σ (make-parameter #f)) 33 | (define current-type-queue (make-parameter #f)) 34 | (define current-type-graph (make-parameter #f)) 35 | (define current-type-table (make-parameter #f)) 36 | (define current-globals (make-parameter #f)) 37 | 38 | (define (include-src! src) 39 | (match-define (ExternSrc ls hs) src) 40 | (for ([l (in-list ls)]) 41 | (set-add! (current-libs) l)) 42 | (for ([h (in-list hs)]) 43 | (set-add! (current-headers) h))) 44 | 45 | (define math-h (ExternSrc '("m") '("math.h"))) 46 | (define stdio-h (ExternSrc '() '("stdio.h"))) 47 | (define stdlib-h (ExternSrc '() '("stdlib.h"))) 48 | (define stdint-h (ExternSrc '() '("stdint.h"))) 49 | 50 | (define ((c-op op) ρ a b) 51 | (define a* (compile-expr ρ a)) 52 | (define b* (compile-expr ρ b)) 53 | (list* "(" a* " " op " " b* ")")) 54 | 55 | (define ((c-unord-op op) ρ a b) 56 | (include-src! math-h) 57 | (define a* (compile-expr ρ a)) 58 | (define b* (compile-expr ρ b)) 59 | (list* "(isnan(" a* ") || isnan(" b* ") || (" a* " " op " " b* "))")) 60 | 61 | (define ((c-fun ty->name src) ρ a b) 62 | (include-src! src) 63 | (define a* (compile-expr ρ a)) 64 | (define b* (compile-expr ρ b)) 65 | (define ty (expr-type a)) 66 | (define name* (hash-ref ty->name ty)) 67 | (list* "(" name* "(" a* ", " b* "))")) 68 | 69 | (define (compile-fone ρ a b) 70 | (include-src! math-h) 71 | (define a* (compile-expr ρ a)) 72 | (define b* (compile-expr ρ b)) 73 | (list* "(!isnan(" a* ") && !isnan(" b* ") && (" a* " != " b* "))")) 74 | 75 | (define (compile-ford ρ a b) 76 | (include-src! math-h) 77 | (define a* (compile-expr ρ a)) 78 | (define b* (compile-expr ρ b)) 79 | (list* "(!isnan(" a* ") && !isnan(" b* "))")) 80 | 81 | (define (compile-funo ρ a b) 82 | (include-src! math-h) 83 | (define a* (compile-expr ρ a)) 84 | (define b* (compile-expr ρ b)) 85 | (list* "(isnan(" a* ") || isnan(" b* "))")) 86 | 87 | (define bin-op-table 88 | (hasheq 'iadd (c-op "+") 89 | 'isub (c-op "-") 90 | 'imul (c-op "*") 91 | 'iudiv (c-op "/") 92 | 'isdiv (c-op "/") 93 | 'iurem (c-op "%") 94 | 'isrem (c-op "%") 95 | 'ishl (c-op "<<") 96 | 'ilshr (c-op ">>") 97 | 'iashr (c-op ">>") 98 | 'iand (c-op "&") 99 | 'ior (c-op "|") 100 | 'ixor (c-op "^") 101 | 'fadd (c-op "+") 102 | 'fsub (c-op "-") 103 | 'fmul (c-op "*") 104 | 'fdiv (c-op "/") 105 | 'frem (c-fun (hash (FloT 32) "fmodf" (FloT 64) "fmod") math-h) 106 | 'ieq (c-op "==") 107 | 'ine (c-op "!=") 108 | 'iugt (c-op ">") 109 | 'iuge (c-op ">=") 110 | 'iult (c-op "<") 111 | 'iule (c-op "<=") 112 | 'isgt (c-op ">") 113 | 'isge (c-op ">=") 114 | 'islt (c-op "<") 115 | 'isle (c-op "<=") 116 | 'foeq (c-op "==") 117 | 'fone compile-fone 118 | 'fogt (c-op ">") 119 | 'foge (c-op ">=") 120 | 'folt (c-op "<") 121 | 'fole (c-op "<=") 122 | 'fueq (c-unord-op "==") 123 | ;; Note: behavior of C's != operator is unordered. 124 | 'fune (c-op "!=") 125 | 'fugt (c-unord-op ">") 126 | 'fuge (c-unord-op ">=") 127 | 'fult (c-unord-op "<") 128 | 'fule (c-unord-op "<=") 129 | 'ffalse (const "(0)") 130 | 'ftrue (const "(1)") 131 | 'ford compile-ford 132 | 'funo compile-funo 133 | )) 134 | 135 | (define (compile-type ty) 136 | (define (rec ty) (compile-type ty)) 137 | (match ty 138 | [(? VoiT?) "void"] 139 | [(IntT signed? bits) 140 | (list* (if signed? "" "u") "int" (~a bits) "_t")] 141 | [(FloT bits) 142 | (match bits 143 | [32 "float"] 144 | [64 "double"])] 145 | [(ArrT dim ety) 146 | (list* (rec ety) "*")] 147 | [(or (? RecT?) (? UniT?)) 148 | (define type-table (current-type-table)) 149 | (define (new-type!) 150 | (match-define (or (RecT ?->ty _ _) (UniT ?->ty _)) ty) 151 | (for ([ty* (in-hash-values ?->ty)]) 152 | (when (or (RecT? ty*) (UniT? ty*)) 153 | (add-directed-edge! (current-type-graph) ty* ty))) 154 | (define x (cify (match ty 155 | [(? RecT?) 'rec] 156 | [(? UniT?) 'uni]))) 157 | (enqueue! (current-type-queue) ty) 158 | (hash-set! type-table ty x) 159 | x) 160 | (hash-ref type-table ty new-type!)] 161 | [(ExtT src name) 162 | (include-src! src) 163 | name])) 164 | 165 | (define (compile-type/ref ty x) 166 | (match ty 167 | [(or (? IntT?) (? FloT?)) 168 | (define ref-vars (current-ref-vars)) 169 | ;; current-ref-vars will be #f if we are compiling a global 170 | ;; variable (this function will be called from outside compile-fun). 171 | (list* (compile-type ty) 172 | (and ref-vars (set-member? ref-vars x) "*"))] 173 | [(or (? ArrT?) (? VoiT?)) 174 | (compile-type ty)] 175 | [(or (? RecT?) (? UniT?) (? ArrT?)) 176 | (list* (compile-type ty) "*")])) 177 | 178 | (define (compile-path ρ path) 179 | (define (rec path) (compile-path ρ path)) 180 | (match (unpack-MetaP path) 181 | [(Var x ty) 182 | (values (hash-ref ρ x) ty)] 183 | [(and the-glob (Global ty _)) 184 | (define globals (current-globals)) 185 | (define (new-global!) 186 | (define x (cify 'glob)) 187 | (hash-set! globals the-glob x) 188 | x) 189 | (values (hash-ref globals the-glob new-global!) ty)] 190 | [(Select path ie) 191 | (define-values (p-ast pty) (rec path)) 192 | (match-define (ArrT _ ety) pty) 193 | (values (list* "(" p-ast "[" (compile-expr ρ ie) "])") 194 | ety)] 195 | [(Field path f) 196 | (define-values (p-ast pty) (rec path)) 197 | (match-define (RecT f->ty f->c _) pty) 198 | ;; XXX This is kind of hacky, treating arrays as a special 199 | ;; case where we use . instead of -> ...or maybe C just 200 | ;; has weird syntax and is this complexity isn't incidental. 201 | ;; We may have to revist this if more complex programs force 202 | ;; us to change the way value vs. reference types work. 203 | (define op (if (Select? (unpack-MetaP path)) "." "->")) 204 | (values (list* "(" p-ast op (hash-ref f->c f) ")") 205 | (hash-ref f->ty f))] 206 | [(Mode path m) 207 | (define-values (p-ast pty) (rec path)) 208 | (match-define (UniT m->ty m->c) pty) 209 | (define op (if (Select? (unpack-MetaP path)) "." "->")) 210 | (values (list* "(" p-ast op (hash-ref m->c m) ")") 211 | (hash-ref m->ty m))] 212 | [(ExtVar src n ty) 213 | (include-src! src) 214 | (values n ty)])) 215 | 216 | (define (compile-path/deref ρ path) 217 | (define-values (ast ty) (compile-path ρ path)) 218 | ;; ast will be x* if path is an int or float ref. 219 | (define ref? (set-member? (current-ref-vars) ast)) 220 | (values (if ref? (list* "(*" ast ")") ast) 221 | ty)) 222 | 223 | (define (compile-expr ρ e) 224 | (define (rec e) (compile-expr ρ e)) 225 | (match e 226 | [(Int signed? bits val) 227 | (list* "((" (compile-type (IntT signed? bits)) ")" (~a val) ")")] 228 | [(Flo bits val) 229 | (define val* (cond [(equal? val +nan.0) 230 | (include-src! math-h) 231 | "NAN"] 232 | [(single-flonum? val) 233 | (~a (real->double-flonum val))] 234 | [else (~a val)])) 235 | (list* "((" (compile-type (FloT bits)) ")" val* ")")] 236 | [(Cast ty e) 237 | ;; XXX Only for int/float types? 238 | (list* "((" (compile-type ty) ")" (rec e) ")")] 239 | [(Read path) 240 | (match-define-values (ast _) 241 | (compile-path/deref ρ path)) 242 | ast] 243 | [(BinOp op L R) 244 | (define op-fn (hash-ref bin-op-table op)) 245 | (op-fn ρ L R)] 246 | [(LetE x _ xe be) 247 | ;; DESIGN: We ignore xt because x does not become a real thing in 248 | ;; C (because we can't make it.) If/when we compile to LLVM, we 249 | ;; will be able to make it something and it will be useful. 250 | (compile-expr (hash-set ρ x (compile-expr ρ xe)) be)] 251 | [(IfE ce te fe) 252 | (list* "(" (rec ce) " ? " (rec te) " : " (rec fe) ")")] 253 | [(MetaE _ e) 254 | (rec e)])) 255 | 256 | (define (compile-decl ty name [val #f]) 257 | (define assign (and val (list* " = " val))) 258 | (match ty 259 | [(or (? VoiT?) (? AnyT?)) #f] 260 | [(or (? IntT?) (? FloT?) (? ArrT?) (? RecT?) (? UniT?)) 261 | (list* (compile-type/ref ty name) " " name assign ";")] 262 | [(ExtT src ext) 263 | (include-src! src) 264 | (list* ext " " name assign ";")])) 265 | 266 | (define (compile-storage ty name [val #f]) 267 | (define assign (and val (list* " = " val))) 268 | (match ty 269 | [(or (? IntT?) (? FloT?) (? RecT?) (? UniT?)) 270 | (list* (compile-type ty) " " name assign ";")] 271 | [(ArrT dim ety) 272 | (list* (compile-type ety) " " name "[" (~a dim) "]" assign ";")] 273 | [(ExtT src ext) 274 | (include-src! src) 275 | (list* ext " " name assign ";")] 276 | )) 277 | 278 | ;; returns (values storage-ast x-init-ast) 279 | ;; storage-ast is #f if no storage is required 280 | (define (compile-storage/init ty xi [val #f]) 281 | (cond [(and (or (ArrT? ty) (RecT? ty) (UniT? ty)) (not (ConI? xi))) 282 | ;; XXX Better name? 283 | (define storage-x (cify 'mem)) 284 | (values (list* (compile-storage ty storage-x val)) 285 | (cond [(ArrT? ty) storage-x] 286 | [else (list* "(&" storage-x ")")]))] 287 | [else (values #f val)])) 288 | 289 | (define (compile-init ρ ty i) 290 | (define (rec i) (compile-init ρ ty i)) 291 | (match i 292 | [(UndI ty) #f] 293 | [(ConI e) (compile-expr ρ e)] 294 | [(ZedI ty) (type-zero ty)] 295 | [(ArrI is) 296 | (match-define (ArrT _ ety) ty) 297 | (list* "{ " 298 | (add-between 299 | (for/list ([i (in-list is)]) 300 | (compile-init ρ ety i)) 301 | ", ") 302 | " }")] 303 | [(RecI f->i) 304 | (match-define (RecT f->ty _ c-order) ty) 305 | (list* "{ " 306 | (add-between 307 | (for/list ([f (in-list c-order)]) 308 | (compile-init ρ (hash-ref f->ty f) (hash-ref f->i f))) 309 | ", ") 310 | " }")] 311 | [(UniI m i) 312 | (match-define (UniT m->ty m->c) ty) 313 | (define ie (compile-init ρ (hash-ref m->ty m) i)) 314 | (list* "{ ." (hash-ref m->c m) " = " ie " }")])) 315 | 316 | (define (type-zero ty) 317 | (match ty 318 | [(IntT signed? bits) 319 | (compile-expr (hasheq) (Int signed? bits 0))] 320 | [(FloT bits) 321 | (compile-expr (hasheq) (Flo bits 0.0))] 322 | [(or (? ArrT?) (? RecT?) (? UniT?)) "{ 0 }"] 323 | ;; XXX: ExtT 324 | )) 325 | 326 | ;; XXX make sure that comment lines don't end in backslash 327 | ;; so that real code isn't accidentally commented out. 328 | (define (compile-comment cstr) 329 | (add-between 330 | (for/list ([c (in-list (string-split cstr "\n"))]) 331 | (list* "// " c)) 332 | ind-nl)) 333 | 334 | (define (VoiT/any? v) 335 | (or (VoiT? v) (AnyT? v))) 336 | 337 | (define (compile-stmt γ ρ s) 338 | (define (rec s) (compile-stmt γ ρ s)) 339 | (match s 340 | [(Skip c) 341 | (and c (compile-comment c))] 342 | [(Fail m) 343 | ;; XXX Ensure (~v m) is valid C string (maybe turn into a literal 344 | ;; array at top-level?) 345 | (include-src! stdio-h) 346 | (include-src! stdlib-h) 347 | (list* "fprintf(stderr, " (~v m) ");" ind-nl 348 | "exit(1);")] 349 | [(Assign path e) 350 | (define-values (path-ast path-ty) (compile-path/deref ρ path)) 351 | (cond [(or (VoiT/any? path-ty) (VoiT/any? (expr-type e))) #f] 352 | [else (list* path-ast " = " (compile-expr ρ e) ";")])] 353 | [(Begin f s) 354 | (cond [(and (Skip? f) (not (Skip-comment f))) (rec s)] 355 | [(and (Skip? s) (not (Skip-comment s))) (rec f)] 356 | [else (list* (rec f) ind-nl (rec s))])] 357 | [(If pred t f) 358 | (define pred-ast 359 | (cond [(and (Read? pred) 360 | (let ([path (Read-p pred)]) 361 | (or (Var? path) (Global? path)))) 362 | (list* "(" (compile-expr ρ pred) ")")] 363 | [else (compile-expr ρ pred)])) 364 | (define tail 365 | (cond [(If? f) (list* " else " (rec f))] 366 | [(and (Skip? f) (not (Skip-comment f))) #f] 367 | [else (list* " else {" ind++ ind-nl 368 | (rec f) 369 | ind-- ind-nl "}")])) 370 | (list* "if " pred-ast " {" ind++ ind-nl 371 | (rec t) 372 | ind-- ind-nl "}" tail)] 373 | [(While pred b) 374 | (list* "while " (compile-expr ρ pred) " {" ind++ ind-nl 375 | (rec b) 376 | ind-- ind-nl "}")] 377 | [(Jump l) 378 | (define ret-info (current-ret-info)) 379 | (define l* (hash-ref γ l)) 380 | (if (and ret-info (equal? l* (ret-info-lab ret-info))) 381 | (list* "return " (ret-info-x ret-info) ";") 382 | (list* "goto " l* ";"))] 383 | [(Let/ec l b) 384 | (define cl (cify l)) 385 | (list* (compile-stmt (hash-set γ l cl) ρ b) ind-nl 386 | cl ":")] 387 | [(Let x ty xi bs) 388 | (define-values (storage-ast x-init-ast) 389 | (compile-storage/init ty xi (compile-init ρ ty xi))) 390 | (define x* (cify x)) 391 | (list* (and storage-ast (list* storage-ast ind-nl)) 392 | (compile-decl ty x* x-init-ast) ind-nl 393 | (compile-stmt γ (hash-set ρ x x*) bs))] 394 | [(MetaS _ s) 395 | (compile-stmt γ ρ s)] 396 | [(Call x ty f as bs) 397 | (define Σ (current-Σ)) 398 | (define f* (unpack-MetaFun f)) 399 | (define (new-fun!) 400 | (define fun-name (cify 'fun)) 401 | (hash-set! Σ f* fun-name) 402 | (enqueue! (current-fun-queue) f*) 403 | fun-name) 404 | (define fun-name 405 | (match f* 406 | [(ExtFun src _ _ name) 407 | (include-src! src) 408 | name] 409 | [(? IntFun?) 410 | (add-directed-edge! (current-fun-graph) f* (current-fun)) 411 | (hash-ref Σ f* new-fun!)])) 412 | ;; XXX Awkward to calculate these for each function call as well as 413 | ;; inside of compile-fun. 414 | (define ref-args 415 | (for/fold ([out (set)]) ([a (in-list (Fun-args f*))]) 416 | (match-define (Arg x ty mode) a) 417 | (if (and (or (IntT? ty) (FloT? ty)) (eq? mode 'ref)) 418 | (set-add out x) 419 | out))) 420 | (define args-ast 421 | (add-between 422 | ;; var-* is argument being passed 423 | ;; arg-* relates to what the function expects of its arguments 424 | (for/list ([var (in-list as)] 425 | [arg (in-list (Fun-args f*))]) 426 | (match (unpack-any var) 427 | [(or (Read path) (? Path? path)) 428 | (match-define-values (var-ast _) 429 | (compile-path ρ path)) 430 | (define var-is-ref? (set-member? (current-ref-vars) var-ast)) 431 | (define arg-is-ref? (set-member? ref-args (Arg-x arg))) 432 | (define-values (deref-var? take-var-addr?) 433 | (cond [(eq? var-is-ref? arg-is-ref?) 434 | (values #f #f)] 435 | [(and var-is-ref? (not (arg-is-ref?))) 436 | (values #t #f)] 437 | [(and (not var-is-ref?) arg-is-ref?) 438 | (values #f #t)])) 439 | (cond [deref-var? 440 | (list* "(*" var-ast ")")] 441 | [take-var-addr? 442 | (list* "(&" var-ast ")")] 443 | [else var-ast])] 444 | [(? Expr?) (compile-expr ρ var)])) 445 | ", ")) 446 | (define x* (cify x)) 447 | (define invoke-ast (list* fun-name "(" args-ast ")")) 448 | (define call-ast 449 | (cond [(VoiT? ty) (list* invoke-ast ";")] 450 | [else (compile-decl ty x* invoke-ast)])) 451 | (define body-ast (compile-stmt γ (hash-set ρ x x*) bs)) 452 | (list* call-ast ind-nl 453 | body-ast)])) 454 | 455 | (define (compile-fun mf) 456 | (define f (unpack-MetaFun mf)) 457 | (match-define (IntFun as ret-x ret-ty ret-lab body) f) 458 | ;; XXX Instead of using catch->log->raise here, make a new exn 459 | ;; type that is a tuple of the blamed function and the inner exn. 460 | (define (print-fun!) 461 | (newline (current-error-port)) 462 | (print-ast f (current-error-port)) 463 | (newline (current-error-port))) 464 | (parameterize ([current-fun f]) 465 | (with-handlers ([exn:fail? (λ (e) (print-fun!) (raise e))]) 466 | (define fun-name (hash-ref (current-Σ) f)) 467 | (define-values (ρ ref-args) 468 | (for/fold ([ρ (hasheq)] [ref-args (set)]) 469 | ([a (in-list as)]) 470 | (match-define (Arg x ty mode) a) 471 | (define x* (cify x)) 472 | (values (hash-set ρ x x*) 473 | (cond [(and (or (IntT? ty) (FloT? ty)) (eq? mode 'ref)) 474 | (set-add ref-args x*)] 475 | [else ref-args])))) 476 | (define ret-x* (cify ret-x)) 477 | (define ret-lab* (cify ret-lab)) 478 | (define γ (hasheq ret-lab ret-lab*)) 479 | (parameterize ([current-ret-info (ret-info ret-x* ret-lab*)] 480 | [current-ref-vars ref-args]) 481 | (define args-ast 482 | (add-between 483 | (for/list ([a (in-list as)]) 484 | (match-define (Arg x ty _) a) 485 | (define x* (hash-ref ρ x)) 486 | (list* (compile-type/ref ty x*) " " (hash-ref ρ x))) 487 | ", ")) 488 | (define decl-part 489 | (list* (compile-type/ref ret-ty ret-x*) " " fun-name "(" args-ast ")")) 490 | (define defn-part 491 | (list* decl-part "{" ind++ ind-nl 492 | (compile-decl ret-ty ret-x*) ind-nl 493 | (compile-stmt γ (hash-set ρ ret-x ret-x*) body) 494 | ind-- ind-nl "}" ind-nl)) 495 | (values decl-part defn-part))))) 496 | 497 | (define (compile-program prog) 498 | (match-define (Program n->g n->ty n->f) prog) 499 | (when (check-duplicates (hash-values n->g) eq?) 500 | (error 'compile-program 501 | "multiple public names reference the same global variable")) 502 | ;; Setup Σ and fun-queue 503 | (define Σ (make-hash (for/list ([(x f) (in-hash n->f)]) 504 | (cons (unpack-MetaFun f) x)))) 505 | (define pub-funs (list->set (hash-keys Σ))) 506 | (define fun-queue (make-queue)) 507 | (for ([f (in-hash-keys Σ)]) 508 | (enqueue! fun-queue f)) 509 | ;; Setup type-table and type-queue 510 | (define type-table (make-hash (for/list ([(n ty) (in-hash n->ty)]) 511 | (cons ty n)))) 512 | (define type-queue (make-queue)) 513 | (for ([ty (in-hash-keys type-table)]) 514 | (enqueue! type-queue ty)) 515 | ;; Setup globals 516 | (define globals (make-hasheq)) 517 | (for ([(n g) (in-hash n->g)]) 518 | (hash-set! globals g n)) 519 | (with-cify-counter 520 | (parameterize ([current-fun-queue fun-queue] 521 | [current-fun-graph (unweighted-graph/directed empty)] 522 | [current-Σ Σ] 523 | [current-type-queue type-queue] 524 | [current-type-graph (unweighted-graph/directed empty)] 525 | [current-type-table type-table] 526 | [current-globals globals]) 527 | ;; Functions 528 | (define pub-fun-decls (make-queue)) 529 | (define f->ast 530 | (for/hash ([f (in-queue fun-queue)]) 531 | (define static? (not (set-member? pub-funs f))) 532 | (define-values (decl-ast defn-ast) (compile-fun f)) 533 | (unless static? 534 | (enqueue! pub-fun-decls (list* decl-ast ";"))) 535 | (values f (list* (and static? "static ") defn-ast ind-nl)))) 536 | (define fun-graph (current-fun-graph)) 537 | (define funs-ast 538 | (list* 539 | (for/list ([f (in-list (tsort fun-graph))]) 540 | (hash-ref f->ast f)) 541 | (for/list ([f (in-set pub-funs)] 542 | #:when (not (has-vertex? fun-graph f))) 543 | (hash-ref f->ast f)))) 544 | (define pub-funs-ast (add-between (queue->list pub-fun-decls) ind-nl)) 545 | ;; Globals 546 | (define pub-globals (hash-values n->g)) 547 | (define pub-global-decls (make-queue)) 548 | (define globals-ast 549 | (for/list ([(g x) (in-hash globals)]) 550 | (match-define (Global ty xi) (unpack-MetaP g)) 551 | (define-values (storage-ast x-init-ast) 552 | (compile-storage/init ty xi (compile-init (hasheq) ty xi))) 553 | (when (set-member? pub-globals g) 554 | (enqueue! pub-global-decls (list* "extern " (compile-decl ty x)))) 555 | (list* (and storage-ast (list* storage-ast ind-nl)) 556 | (compile-decl ty x x-init-ast) ind-nl))) 557 | (define pub-globals-ast (add-between (queue->list pub-global-decls) ind-nl)) 558 | ;; Types 559 | (define root-types (queue->list (current-type-queue))) 560 | (define ty->ast 561 | (for/hash ([ty (in-queue (current-type-queue))]) 562 | (define x (hash-ref (current-type-table) ty)) 563 | (define ast 564 | (match ty 565 | [(? ArrT?) 566 | (list* "typedef " (compile-type ty) " " x ";" ind-nl)] 567 | [(RecT f->ty f->c c-order) 568 | (list* "typedef struct {" ind++ ind-nl 569 | (add-between 570 | (for/list ([f (in-list c-order)]) 571 | (compile-decl (hash-ref f->ty f) (hash-ref f->c f))) 572 | ind-nl) 573 | ind-- ind-nl "} " x ";" ind-nl)] 574 | [(UniT m->ty m->c) 575 | (list* "typedef union {" ind++ ind-nl 576 | (add-between 577 | (for/list ([(m ty) (in-hash m->ty)]) 578 | (compile-storage ty (hash-ref m->c m))) 579 | ind-nl) 580 | ind-- ind-nl "} " x ";" ind-nl)])) 581 | (values ty ast))) 582 | ;; XXX Maybe have c-part include h-part instead of duplicating type decls? 583 | (define pub-types-ast 584 | (add-between 585 | (for/list ([ty (in-hash-values n->ty)]) 586 | (hash-ref ty->ast ty)) 587 | ind-nl)) 588 | (define types-ast 589 | (list* (for/list ([ty (in-list (tsort (current-type-graph)))]) 590 | (hash-ref ty->ast ty)) 591 | (for/list ([ty (in-list root-types)] 592 | #:when (not (has-vertex? (current-type-graph) ty))) 593 | (hash-ref ty->ast ty)) 594 | (for/list ([(n ty) (in-hash n->ty)]) 595 | (define def-n (hash-ref type-table ty)) 596 | (and (not (string=? def-n n)) 597 | (list* "typedef " def-n " " n ";" ind-nl))))) 598 | ;; Headers 599 | (define headers-ast (for/list ([h (in-set (current-headers))]) 600 | (list* "#include <" h ">" ind-nl))) 601 | (define c-part 602 | (list* headers-ast ind-nl 603 | types-ast ind-nl 604 | globals-ast ind-nl 605 | funs-ast)) 606 | (define h-part 607 | (list* pub-types-ast ind-nl ind-nl 608 | pub-globals-ast ind-nl ind-nl 609 | pub-funs-ast ind-nl)) 610 | (values h-part c-part)))) 611 | 612 | ;; Display code 613 | 614 | (struct ind-token ()) 615 | (define ind-nl (ind-token)) 616 | (define ind++ (ind-token)) 617 | (define ind-- (ind-token)) 618 | (define ind-lvl (box 0)) 619 | 620 | (define (idisplay v) 621 | (match v 622 | [(== ind-nl) 623 | (newline) 624 | (for ([i (in-range (unbox ind-lvl))]) 625 | (display #\space))] 626 | [(== ind++) 627 | (set-box! ind-lvl (+ (unbox ind-lvl) 2))] 628 | [(== ind--) 629 | (set-box! ind-lvl (- (unbox ind-lvl) 2))] 630 | [_ (display v)])) 631 | 632 | (define (tree-for f t) 633 | (match t 634 | [(or (? void?) #f '()) (void)] 635 | [(cons a d) (tree-for f a) (tree-for f d)] 636 | [x (f x)])) 637 | 638 | (define (compile-binary extra-args prog c-path out-path [h-path #f]) 639 | (parameterize ([current-libs (mutable-set)] 640 | [current-headers (mutable-set)]) 641 | (include-src! stdint-h) 642 | (define-values (h-part c-part) (compile-program prog)) 643 | (with-output-to-file c-path #:mode 'text #:exists 'replace 644 | (λ () (tree-for idisplay c-part))) 645 | (when h-path 646 | (with-output-to-file h-path #:mode 'text #:exists 'replace 647 | (λ () (tree-for idisplay h-part)))) 648 | (define libs (for/list ([l (in-set (current-libs))]) 649 | (format "-l~a" l))) 650 | (define args 651 | (list* 652 | ;; error on any warning, except for... 653 | "-Wall" "-Werror" 654 | ;; Too pedantic, maybe we should have our own warning for this 655 | "-Wno-unused-variable" 656 | ;; We don't emit unused functions so all this flag does is 657 | ;; complain about unused functions in util.h. 658 | "-Wno-unused-function" 659 | "-o" out-path "-xc" c-path libs)) 660 | (apply system* (find-executable-path "cc") (append extra-args args)))) 661 | 662 | (define (compile-library prog c-path out-path [h-path #f]) 663 | (compile-binary '("-shared" "-fPIC") prog c-path out-path h-path)) 664 | 665 | (define (compile-exe prog c-path out-path [h-path #f]) 666 | (compile-binary '() prog c-path out-path h-path)) 667 | 668 | (define (compile-obj prog c-path out-path [h-path #f]) 669 | (compile-binary '("-c") prog c-path out-path h-path)) 670 | 671 | (provide 672 | (contract-out 673 | [compile-library (->* (Program? path? path?) (path?) boolean?)] 674 | [compile-exe (->* (Program? path? path?) (path?) boolean?)] 675 | [compile-obj (->* (Program? path? path?) (path?) boolean?)])) 676 | -------------------------------------------------------------------------------- /t/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/syntax) 4 | adqc 5 | chk 6 | racket/match 7 | racket/stxparam 8 | syntax/parse/define) 9 | 10 | ;; This assumes the same representation used by the evaluator for data types. 11 | (define (raw-value ty v) 12 | (match ty 13 | [(? IntT?) (Int-val v)] 14 | [(? FloT?) (Flo-val v)] 15 | [(RecT f->ty _ c-order) 16 | (for/list ([f (in-list c-order)]) 17 | (raw-value (hash-ref f->ty f) (unbox (hash-ref v f))))] 18 | [(ArrT dim ety) 19 | (for/vector #:length dim ([v* (in-vector v)]) 20 | (raw-value ety (unbox v*)))] 21 | ;; XXX Structs and Unions. 22 | )) 23 | 24 | (define current-invert? (make-parameter #f)) 25 | (define-syntax-rule (! . b) 26 | (parameterize ([current-invert? #t]) . b)) 27 | 28 | (define ((print-src! c-path) _) 29 | (define in (open-input-file c-path)) 30 | (for ([ch (in-port read-char in)]) 31 | (display ch (current-error-port))) 32 | (newline (current-error-port)) 33 | (close-input-port in)) 34 | 35 | (define (TProg1* stx the-p the-cp c-path n args-i expect-ans-i) 36 | ;; Get type info for args and ans. 37 | (define the-fun (unpack-MetaFun (hash-ref (Program-name->fun the-p) n))) 38 | (match-define (IntFun (list (Arg _ arg-tys _) ...) _ ans-ty _ _) 39 | the-fun) 40 | (define args (for/list ([ai (in-list args-i)]) 41 | (unbox (eval-init (hash) ai)))) 42 | (define eval-expect-ans (unpack-MetaE 43 | (unbox (eval-init (hash) expect-ans-i)))) 44 | (define eval-ans #f) 45 | (define comp-ans #f) 46 | (define (print-the-fun! _) 47 | (print-ast the-fun (current-error-port)) 48 | (newline (current-error-port))) 49 | (with-chk ([chk-inform! print-the-fun!]) 50 | (chk #:t (#:src stx (set! eval-ans (unpack-MetaE 51 | (eval-program the-p n args-i))))) 52 | (when eval-ans 53 | (chk (#:src stx eval-ans) (#:src stx eval-expect-ans)))) 54 | (unless the-cp 55 | (chk #:t (set! the-cp (link-program the-p c-path)))) 56 | (when the-cp 57 | (with-chk ([chk-inform! (print-src! c-path)]) 58 | ;; XXX Once linked-program-write exists, we can automatically 59 | ;; convert arguments into the data layout expected by linked-program-run. 60 | (define comp-args (for/list ([a (in-list args)] 61 | [ty (in-list arg-tys)]) 62 | (raw-value ty a))) 63 | (chk #:t (#:src stx 64 | (set! comp-ans (linked-program-run the-cp n comp-args)))) 65 | (when comp-ans 66 | (define comp-expect-ans (raw-value ans-ty eval-ans)) 67 | (define comp-ans* (linked-program-read the-cp comp-ans)) 68 | (if (current-invert?) 69 | (chk #:! (#:src stx comp-ans*) 70 | (#:src stx comp-expect-ans)) 71 | (chk (#:src stx comp-ans*) 72 | (#:src stx comp-expect-ans))))))) 73 | 74 | (define-syntax (TProg1 stx) 75 | (syntax-parse stx 76 | [(_ the-p:id the-cp:id c-path . t) 77 | #:with (n:expr (~and arg-e (~not (~datum =>))) ... (~datum =>) ans) #'t 78 | (syntax/loc stx 79 | (TProg1* #'t the-p the-cp c-path n (list (I arg-e) ...) (I ans)))])) 80 | (define-syntax (TProgN stx) 81 | (syntax-parse stx 82 | [(_ the-p:id t ...) 83 | (syntax/loc stx 84 | (with-temp-files (c-path bin-path) 85 | (define the-cp #f) 86 | (chk #:t (#:stx #,stx (set! the-cp (link-program the-p c-path bin-path)))) 87 | (TProg1 the-p the-cp c-path . t) ...))])) 88 | (define-syntax (TProg stx) 89 | (syntax-parse stx 90 | [(_ p-body ... #:tests t ...) 91 | (syntax/loc stx 92 | (let ([the-p #f]) 93 | (chk #:t (#:stx #,stx (set! the-p (Prog p-body ...)))) 94 | (TProgN the-p t ...)))])) 95 | (define-syntax (TS stx) 96 | (syntax-parse stx 97 | [(_ the-s ans) 98 | #:with f (generate-temporary) 99 | (syntax/loc stx 100 | (let* ([ans-e (E ans)] [ans-ty (expr-type ans-e)]) 101 | (TProg (define-fun #,ans-ty f () the-s) 102 | #:tests [(symbol->string 'f) => ans])))])) 103 | (define-simple-macro (TE the-e ans) 104 | (TS the-e ans)) 105 | 106 | (define-simple-macro (TT the-ast) 107 | (chk #:x the-ast exn:fail:adqc:type?)) 108 | (define-simple-macro (TTE the-e) 109 | (TT (E the-e))) 110 | (define-simple-macro (TTS the-s) 111 | (TT (S the-s))) 112 | (define-simple-macro (TTN expect-ty the-n ...+) 113 | (begin 114 | (chk #:x (E (let ([x : expect-ty := #,(N the-n)]) x)) exn:fail?) 115 | ...)) 116 | 117 | (provide TProg1 TProgN TProg TS TE TT TTE TTS TTN) 118 | 119 | (module+ test 120 | (chk* 121 | (TE (S64 5) (S64 5)) 122 | (TS (let ([x : S64 := (S64 5)]) x) (S64 5)) 123 | (TE (iadd (S64 5) (S64 6)) (S64 11)) 124 | (TS (begin (define x : S64 := (S64 5)) 125 | (define y : S64 := (S64 6)) 126 | (iadd x y)) (S64 11)) 127 | (TE (isub (S64 6) (S64 5)) (S64 1)) 128 | (TE (imul (S64 3) (S64 4)) (S64 12)) 129 | (TE (iudiv (U64 100) (U64 10)) (U64 10)) 130 | (TE (isdiv (S64 13) (S64 4)) (S64 3)) 131 | (TE (isdiv (S64 12) (S64 4)) (S64 3)) 132 | (TE (isrem (S64 12) (S64 5)) (S64 2)) 133 | (TE (iurem (U64 105) (U64 10)) (U64 5)) 134 | (TE (ishl (S64 2) (S64 1)) (S64 4)) 135 | (TE (iashr (S64 4) (S64 1)) (S64 2)) 136 | (TE (iashr (S8 -128) (S8 2)) (S8 -32) ) 137 | (TE (ilshr (U8 16) (U8 2)) (U8 4)) 138 | (TE (ior (S64 1) (S64 2)) (S64 3)) 139 | (TE (ior (U8 1) (U8 2)) (U8 3)) 140 | (TE (iand (S64 3) (S64 1)) (S64 1)) 141 | (TE (iand (U8 3) (U8 1)) (U8 1)) 142 | (TE (ixor (S64 3) (S64 2)) (S64 1)) 143 | (TE (ixor (U8 3) (U8 2)) (U8 1)) 144 | ;; Integer comparison 145 | (TE (ieq (S64 1) (S64 1)) (S32 1)) 146 | (TE (ieq (S64 -1) (S64 2)) (S32 0)) 147 | (TE (ieq (S64 -2) (S64 -2)) (S32 1)) 148 | (TE (ieq (S64 1) (S64 2)) (S32 0)) 149 | (TE (ine (S64 1) (S64 2)) (S32 1)) 150 | (TE (ine (S64 1) (S64 1)) (S32 0)) 151 | (TE (ine (S64 -2) (S64 5)) (S32 1)) 152 | (TE (ine (S64 -2) (S64 -2)) (S32 0)) 153 | (TE (iugt (U8 5) (U8 4)) (S32 1)) 154 | (TE (iugt (U8 4) (U8 5)) (S32 0)) 155 | (TE (isgt (S8 1) (S8 0)) (S32 1)) 156 | (TE (isgt (S8 0) (S8 1)) (S32 0)) 157 | (TE (isgt (S8 0) (S8 -1)) (S32 1)) 158 | (TE (iuge (U8 1) (U8 1)) (S32 1)) 159 | (TE (isge (S8 1) (S8 1)) (S32 1)) 160 | (TE (isge (S8 1) (S8 -1))(S32 1)) 161 | (TE (iult (U8 4) (U8 5)) (S32 1)) 162 | (TE (iult (U8 5) (U8 4)) (S32 0)) 163 | (TE (islt (S8 0) (S8 1)) (S32 1)) 164 | (TE (islt (S8 1) (S8 0)) (S32 0)) 165 | (TE (islt (S8 -1) (S8 0))(S32 1)) 166 | (TE (iule (U8 1) (U8 1)) (S32 1)) 167 | (TE (isle (S8 1) (S8 1)) (S32 1)) 168 | (TE (isle (S8 -1) (S8 1)) (S32 1)) 169 | ;; Floating point arithmetic 170 | (TE (fadd (F64 2.0) (F64 1.5)) (F64 3.5)) 171 | (TE (fsub (F64 6.1) (F64 0.1)) (F64 6.0)) 172 | (TE (fmul (F64 1.5) (F64 1.5)) (F64 2.25)) 173 | (TE (fdiv (F64 9.0) (F64 1.5)) (F64 6.0)) 174 | (TE (frem (F64 5.3) (F64 2.0)) (F64 1.2999999999999998)) 175 | ;; Floating point comparisons 176 | (TE (ffalse (F64 +nan.0) (F64 +nan.0)) (S32 0)) 177 | (TE (ftrue (F64 +nan.0) (F64 +nan.0)) (S32 1)) 178 | (TE (foeq (F64 1.0) (F64 1.0)) (S32 1)) 179 | (TE (foeq (F64 1.0) (F64 2.0)) (S32 0)) 180 | (TE (foeq (F64 1.0) (F64 +nan.0)) (S32 0)) 181 | (TE (fogt (F64 1.0) (F64 0.0)) (S32 1)) 182 | (TE (fogt (F64 0.0) (F64 1.0)) (S32 0)) 183 | (TE (fogt (F64 1.0) (F64 +nan.0)) (S32 0)) 184 | (TE (foge (F64 1.0) (F64 1.0)) (S32 1)) 185 | (TE (foge (F64 0.0) (F64 1.0)) (S32 0)) 186 | (TE (foge (F64 1.0) (F64 +nan.0)) (S32 0)) 187 | (TE (folt (F64 0.0) (F64 1.0)) (S32 1)) 188 | (TE (folt (F64 1.0) (F64 0.0)) (S32 0)) 189 | (TE (folt (F64 1.0) (F64 +nan.0)) (S32 0)) 190 | (TE (fole (F64 1.0) (F64 1.0)) (S32 1)) 191 | (TE (fole (F64 1.0) (F64 0.0)) (S32 0)) 192 | (TE (fole (F64 1.0) (F64 +nan.0)) (S32 0)) 193 | (TE (fone (F64 1.0) (F64 1.0)) (S32 0)) 194 | (TE (fone (F64 0.0) (F64 1.0)) (S32 1)) 195 | (TE (fone (F64 1.0) (F64 +nan.0)) (S32 0)) 196 | (TE (ford (F64 1.0) (F64 1.0)) (S32 1)) 197 | (TE (ford (F64 1.0) (F64 +nan.0)) (S32 0)) 198 | (TE (fueq (F64 1.0) (F64 1.0)) (S32 1)) 199 | (TE (fueq (F64 0.0) (F64 1.0)) (S32 0)) 200 | (TE (fueq (F64 1.0) (F64 +nan.0)) (S32 1)) 201 | (TE (fugt (F64 1.0) (F64 0.0)) (S32 1)) 202 | (TE (fugt (F64 0.0) (F64 1.0)) (S32 0)) 203 | (TE (fugt (F64 1.0) (F64 +nan.0)) (S32 1)) 204 | (TE (fuge (F64 1.0) (F64 1.0)) (S32 1)) 205 | (TE (fuge (F64 0.0) (F64 1.0)) (S32 0)) 206 | (TE (fuge (F64 1.0) (F64 +nan.0)) (S32 1)) 207 | (TE (fult (F64 0.0) (F64 1.0)) (S32 1)) 208 | (TE (fult (F64 1.0) (F64 0.0)) (S32 0)) 209 | (TE (fult (F64 1.0) (F64 +nan.0)) (S32 1)) 210 | (TE (fule (F64 1.0) (F64 1.0)) (S32 1)) 211 | (TE (fule (F64 1.0) (F64 0.0)) (S32 0)) 212 | (TE (fule (F64 1.0) (F64 +nan.0)) (S32 1)) 213 | (TE (fune (F64 0.0) (F64 1.0)) (S32 1)) 214 | (TE (fune (F64 1.0) (F64 1.0)) (S32 0)) 215 | (TE (fune (F64 1.0) (F64 +nan.0)) (S32 1)) 216 | (TE (fueq (F64 1.0) (F64 1.0)) (S32 1)) 217 | (TE (fueq (F64 0.0) (F64 1.0)) (S32 0)) 218 | (TE (fueq (F64 1.0) (F64 +nan.0)) (S32 1)) 219 | (TE (funo (F64 1.0) (F64 +nan.0)) (S32 1)) 220 | (TE (funo (F64 1.0) (F64 2.0)) (S32 0)) 221 | ;; Smart ops 222 | (TE (+ (S32 2) (S32 3)) (S32 5)) 223 | (TE (+ (F32 2.0f0) (F32 2.5f0)) (F32 4.5f0)) 224 | (TE (+ (F64 2.5) (F64 2.0)) (F64 4.5)) 225 | (TE (- (S32 5)) (S32 -5)) 226 | (TE (- (S32 8) (S32 9)) (S32 -1)) 227 | (TE (- (F32 4.5f0) (F32 2.0f0)) (F32 2.5f0)) 228 | (TE (- (F64 4.5) (F64 2.0)) (F64 2.5)) 229 | (TE (* (S32 2) (S32 3)) (S32 6)) 230 | (TE (* (F32 2.0f0) (F32 1.5f0)) (F32 3.0f0)) 231 | (TE (* (F64 2.0) (F64 1.5)) (F64 3.0)) 232 | (TE (/ (S32 -9) (S32 3)) (S32 -3)) 233 | (TE (/ (U32 9) (U32 3)) (U32 3)) 234 | (TE (/ (F32 3.0f0) (F32 1.5f0)) (F32 2.0f0)) 235 | (TE (/ (F64 3.0) (F64 1.5)) (F64 2.0)) 236 | (TE (% (S32 9) (S32 5)) (S32 4)) 237 | (TE (% (F32 5.3f0) (F32 2.0f0)) (F32 1.3000002f0)) 238 | (TE (% (F64 5.3) (F64 2.0)) (F64 1.2999999999999998)) 239 | (TE (<< (S32 1) (S32 1)) (S32 2)) 240 | (TE (>> (S32 -2) (S32 1)) (S32 -1)) 241 | (TE (>> (U32 2) (U32 1)) (U32 1)) 242 | (TE (bitwise-ior (S32 1) (S32 2)) (S32 3)) 243 | (TE (bitwise-ior (U32 1) (U32 2)) (U32 3)) 244 | (TE (bitwise-and (S32 3) (S32 1)) (S32 1)) 245 | (TE (bitwise-and (U32 3) (U32 1)) (U32 1)) 246 | (TE (bitwise-xor (S32 3) (S32 2)) (S32 1)) 247 | (TE (bitwise-xor (U32 3) (U32 2)) (U32 1)) 248 | (TE (= (S32 5) (S32 5)) (S32 1)) 249 | (TE (= (F32 5.0f0) (F32 5.0f0)) (S32 1)) 250 | (TE (= (F64 5.0) (F64 5.0)) (S32 1)) 251 | (TE (!= (S32 5) (S32 5)) (S32 0)) 252 | (TE (!= (F32 5.0f0) (F32 5.0f0)) (S32 0)) 253 | (TE (!= (F64 5.0) (F64 5.0)) (S32 0)) 254 | (TE (< (S32 2) (S32 3)) (S32 1)) 255 | (TE (< (F32 2.0f0) (F32 3.0f0)) (S32 1)) 256 | (TE (< (F64 2.0) (F64 3.0)) (S32 1)) 257 | (TE (<= (S32 2) (S32 3)) (S32 1)) 258 | (TE (<= (F32 2.0f0) (F32 3.0f0)) (S32 1)) 259 | (TE (<= (F64 2.0) (F64 3.0)) (S32 1)) 260 | (TE (> (S32 2) (S32 3)) (S32 0)) 261 | (TE (> (F32 2.0f0) (F32 3.0f0)) (S32 0)) 262 | (TE (> (F64 2.0) (F64 3.0)) (S32 0)) 263 | (TE (>= (S32 2) (S32 3)) (S32 0)) 264 | (TE (>= (F32 2.0f0) (F32 3.0f0)) (S32 0)) 265 | (TE (>= (F64 2.0) (F64 3.0)) (S32 0)) 266 | (TE (add1 (S32 3)) (S32 4)) 267 | (TE (add1 (F32 3.0f0)) (F32 4.0f0)) 268 | (TE (add1 (F64 3.0)) (F64 4.0)) 269 | (TE (sub1 (S32 3)) (S32 2)) 270 | (TE (sub1 (F32 3.0f0)) (F32 2.0f0)) 271 | (TE (sub1 (F64 3.0)) (F64 2.0)) 272 | (TE (and) (S8 1)) 273 | (TE (and (S32 2)) (S32 2)) 274 | (TE (and (S32 1) 2) (S32 2)) 275 | (TE (and (S32 0) 2) (S32 0)) 276 | (TE (or) (S8 0)) 277 | (TE (or (S32 5)) (S32 5)) 278 | (TE (or (S32 0) 0 (if 0 1 2)) (S32 2)) 279 | (TE (or (S32 0) 5) (S32 5)) 280 | (TS (let ([x : S32 := (S32 1)]) (+=1 x) x) (S32 2)) 281 | (TS (let ([x : F32 := (F32 1f0)]) (+=1 x) x) (F32 2f0)) 282 | (TS (let ([x : F64 := (F64 1.0)]) (+=1 x) x) (F64 2.0)) 283 | (TS (let ([x : S32 := (S32 2)]) (-=1 x) x) (S32 1)) 284 | (TS (let ([x : F32 := (F32 2f0)]) (-=1 x) x) (F32 1f0)) 285 | (TS (let ([x : F64 := (F64 2.0)]) (-=1 x) x) (F64 1.0)) 286 | ;; Cast 287 | (TE ((S8 23) : U32) (U32 23)) 288 | (TE (let ([x : S8 := (S8 23)]) (x : U32)) (U32 23)) 289 | (TE ((F64 23.3) : F32) (F32 23.3f0)) 290 | (TE ((F64 23.3) : S32) (S32 23)) 291 | (TE ((S32 23) : F64) (F64 23.0)) 292 | ;; Simple unions 293 | (TE (let ([x : (union a S32 b S64) := (union a (S32 5))]) 294 | (iadd (x as a) (S32 5))) 295 | (S32 10)) 296 | ;; XXX How to test Fail? 297 | 298 | (TS (let ([x : S64 := (S64 1)]) 299 | (void) 300 | x) 301 | (S64 1)) 302 | (TS (let ([x : S64 := (S64 1)]) 303 | {x <- (S64 5)} 304 | x) 305 | (S64 5)) 306 | (TS (let ([x : S64 := (S64 1)]) 307 | {x <- (iadd (S64 5) (S64 6))} 308 | x) 309 | (S64 11)) 310 | (TS (begin (define x : S64 := (S64 0)) 311 | (define y : S64 := (S64 0)) 312 | {x <- (S64 1)} {y <- (S64 2)} 313 | (iadd x y)) 314 | (S64 3)) 315 | (TS (begin (define x : S64 := (S64 0)) 316 | (define y : S64 := (S64 0)) 317 | (if (ieq (S64 0) (S64 0)) 318 | {x <- (S64 1)} 319 | {y <- (S64 2)}) 320 | (iadd x y)) 321 | (S64 1)) 322 | (TS (begin (define x : S64 := (S64 0)) 323 | (define y : S64 := (S64 0)) 324 | (if (ieq (S64 0) (S64 1)) 325 | {x <- (S64 1)} 326 | {y <- (S64 2)}) 327 | (iadd x y)) 328 | (S64 2)) 329 | (TS (begin (define x : S64 := (S64 0)) 330 | (while (islt x (S64 5)) 331 | {x <- (iadd x (S64 1))}) 332 | x) 333 | (S64 5)) 334 | (TS (begin (define x : S64 := (S64 0)) 335 | (define y : S64 := (S64 0)) 336 | (while (islt x (S64 5)) 337 | {y <- (iadd y x)} 338 | {x <- (iadd x (S64 1))}) 339 | y) 340 | (S64 (+ (+ (+ (+ (+ 0 0) 1) 2) 3) 4))) 341 | 342 | (TS (begin 343 | (define x : S32 := (S32 0)) 344 | (define y : S32 := (S32 1)) 345 | (set! x (S32 0)) 346 | (void) 347 | (unless (ieq x (S32 0)) 348 | (error "The world is upside-down!")) 349 | (let/ec end 350 | (assert! #:dyn #:msg "y is positive" 351 | (iult (S32 0) y)) 352 | (if (ieq (S32 5) (S32 6)) 353 | (set! x (S32 1)) 354 | (set! y (S32 2))) 355 | (when (ieq y (S32 2)) 356 | (set! x (S32 1)) 357 | (end)) 358 | (while (iult x (S32 6)) 359 | (set! x (iadd x (S32 1))))) 360 | (set! y (S32 42)) 361 | (iadd x y)) 362 | (S32 43)) 363 | 364 | (TS (begin 365 | (define x : U32 := (U32 0)) 366 | {x <- (U32 100)} 367 | x) 368 | (U32 100)) 369 | (TS (return (if (islt (U32 5) (U32 6)) 370 | (iadd (S64 2) (S64 3)) 371 | (isub (S64 5) (S64 6)))) 372 | (S64 5)) 373 | (TS (return (let ([x : U32 := (U32 5)]) 374 | (iadd x (U32 1)))) 375 | (U32 6)) 376 | 377 | (TS (begin (define my-array : (array 3 U32) := (array (U32 0) (U32 1) (U32 2))) 378 | (iadd (my-array @ (U32 0)) 379 | (iadd (my-array @ (U32 1)) 380 | (my-array @ (U32 2))))) 381 | (U32 (+ 0 1 2))) 382 | (TS (begin (define a : (array 3 U32) := (array (U32 0) (U32 1) (U32 2))) 383 | ((a @ (U32 0)) <- (U32 3)) 384 | (a @ (U32 0))) 385 | (U32 3)) 386 | (TS (begin (define y : S32 := (S32 5)) 387 | (define my-array : (array 3 S32) := (zero (array 3 S32))) 388 | {y <- (iadd y (my-array @ (U32 2)))} 389 | y) 390 | (S32 5)) 391 | ;; ABI for array arguments 392 | ;; XXX Can't trivially convert vector -> array for ABI right now. 393 | #; 394 | (TProg (define-fun (foo [arr : (array 3 S64)]) : S64 395 | (define a : S64 := (arr @ (U32 0))) 396 | (define b : S64 := (arr @ (U32 1))) 397 | (define c : S64 := (arr @ (U32 2))) 398 | (iadd a (iadd b c))) 399 | #:tests ["foo" (array (S64 2) (S64 3) (S64 4)) => (S64 9)]) 400 | ;; Callee takes an array as an argument, assigns to it 401 | (TProg (define-fun S64 bar ([(array 3 S64) arr]) 402 | ((arr @ (U32 0)) <- (S64 3)) 403 | (S64 0)) 404 | (define-fun S64 foo () 405 | (define arr : (array 3 S64) := (array (S64 0) (S64 1) (S64 2))) 406 | (define z : S64 := bar <- arr) 407 | (arr @ (U32 0))) 408 | #:tests ["foo" => (S64 3)]) 409 | (TProg (define-fun S64 bar ([S64 m]) 410 | (iadd m (S64 1))) 411 | (define-fun S64 foo ([S64 n]) 412 | (define a : S64 := bar <- n) 413 | a) 414 | #:tests ["foo" (S64 5) => (S64 6)]) 415 | ;; Callee takes an integer argument by reference, assigns to it 416 | (let ([bar (F S64 ([#:ref S64 m]) 417 | (set! m (iadd m (S64 1))) 418 | (S64 1))]) 419 | (TProg (define-fun S64 foo ([S64 n]) 420 | (define a : S64 := bar <- n) 421 | n) 422 | #:tests ["foo" (S64 5) => (S64 6)])) 423 | (TProg (define-fun S64 bar ([#:ref S64 m]) 424 | (set! m (iadd m (S64 1))) 425 | (S64 1)) 426 | (define-fun S64 foo ([S64 n]) 427 | (define a : S64 := bar <- n) 428 | n) 429 | #:tests ["foo" (S64 5) => (S64 6)]) 430 | ;; Private function 431 | (let ([c-add1 (F S32 ([S32 n]) (iadd n (S32 1)))]) 432 | (TProg (define-fun S32 foo ([S32 x]) 433 | (define r : S32 := c-add1 <- x) 434 | r) 435 | #:tests ["foo" (S32 5) => (S32 6)])) 436 | ;; Globals 437 | (TProg (define-global x : S32) 438 | (define-fun S32 foo () 439 | (set! x (S32 5)) 440 | (return x)) 441 | #:tests ["foo" => (S32 5)]) 442 | (TProg (define-global x : S32) 443 | (define-fun S32 set_x () 444 | (set! x (S32 5)) 445 | (return 0)) 446 | (define-fun S32 plus_x ([S32 n]) 447 | (+ n x)) 448 | (define-fun S32 go () 449 | (define z := set_x <-) 450 | (define n := plus_x <- (S32 3)) 451 | n) 452 | #:tests ["go" => (S32 8)]) 453 | (TProg (define-global x := (S32 5)) 454 | (define-fun S32 plus_x ([S32 n]) 455 | (+ n x)) 456 | #:tests ["plus_x" (S32 3) => (S32 8)]) 457 | (TProg (define-global x : S32 := 5) 458 | (define-fun S32 plus_x ([S32 n]) 459 | (+ n x)) 460 | #:tests ["plus_x" (S32 2) => (S32 7)]) 461 | (TProg (define-global arr : (array 3 S32) := (array (S32 0) (S32 0) (S32 0))) 462 | (define-fun S32 set_arr () 463 | (set! (arr @ 0) (S32 2)) 464 | (set! (arr @ 1) (S32 3)) 465 | (set! (arr @ 2) (S32 4)) 466 | (return 0)) 467 | (define-fun S32 arr_sum () 468 | (+ (arr @ 0) (+ (arr @ 1) (arr @ 2)))) 469 | (define-fun S32 go () 470 | (define x := set_arr <-) 471 | (define y := arr_sum <-) 472 | y) 473 | #:tests ["go" => (S32 9)]) 474 | (TProg (define-type arr_t (array 3 S32)) 475 | (define-global arr := (arr_t (S32 1) (S32 2) (S32 3))) 476 | (define-fun S32 foo () 477 | (+ (arr @ 0) (+ (arr @ 1) (arr @ 2)))) 478 | #:tests ["foo" => (S32 6)]) 479 | (TProg (define-type Coord (record x S32 y S32)) 480 | (define-global crd : Coord := (Coord (S32 0) (S32 0))) 481 | (define-fun S32 set_crd () 482 | (set! (crd -> x) 2) 483 | (set! (crd -> y) 3) 484 | (return 0)) 485 | (define-fun S32 crd_sum () 486 | (+ (crd -> x) (crd -> y))) 487 | (define-fun S32 go () 488 | (define x := set_crd <-) 489 | (define y := crd_sum <-) 490 | (return y)) 491 | #:tests ["go" => (S32 5)]) 492 | ;; XXX Issue with evaling unions makes 2nd test fail. 493 | ;; How to handle unions being ref'd as different types 494 | ;; in evaluator? 495 | (TProg (define-type Num (union i S32 f F32)) 496 | (define-global n := (Num #:i (S32 0))) 497 | (define-fun S32 set_i () 498 | (set! (n as i) (S32 5)) 499 | (return 0)) 500 | (define-fun S32 go_i () 501 | (define z := set_i <-) 502 | (n as i)) 503 | (define-fun S32 set_f () 504 | (set! (n as f) (F32 2.5f0)) 505 | (return 0)) 506 | (define-fun F32 go_f () 507 | (define z := set_f <-) 508 | (n as f)) 509 | #:tests ["go_i" => (S32 5)] #;["go_f" => (F32 2.5f0)]) 510 | ;; Structs 511 | (let ([Coord (T (record x S64 y S64))]) 512 | (TS (begin (define c : #,Coord := (record x (S64 5) y (S64 4))) 513 | (c -> x)) 514 | (S64 5)) 515 | (TS (begin (define c : #,Coord := (record x (S64 1) y (S64 2))) 516 | ((c -> x) <- (S64 3)) 517 | (c -> x)) 518 | (S64 3)) 519 | (TProg (define-fun S64 bar ([#,Coord c]) 520 | (c -> y)) 521 | (define-fun S64 foo ([S64 n]) 522 | (define p : #,Coord := (record x (S64 0) y n)) 523 | (define m : S64 := bar <- p) 524 | m) 525 | #:tests ["foo" (S64 4) => (S64 4)]) 526 | ;; Duplicate public type 527 | (TProg (include-type "Coord1" Coord) 528 | (include-type "Coord2" Coord) 529 | (define-fun S64 foo ([S64 n] [S64 m]) 530 | (define c : #,Coord := (record x n y m)) 531 | (iadd (c -> x) (c -> y))) 532 | #:tests ["foo" (S64 2) (S64 3) => (S64 5)]) 533 | ;; XXX Can't return structs by pointer while they're compiled on stack. 534 | #; 535 | (TProg (define-fun (foo) : #,Coord 536 | (define c : #,Coord := (record x (S64 1) y (S64 2))) 537 | c) 538 | #:tests ["foo" => (record x (S64 1) y (S64 2))]) 539 | ;; Fails with following sterr: 540 | ;; 541 | ;; SIGSEGV MAPPER si_code 1 fault on addr 0x1 542 | ;; Aborted (core dumped) 543 | ;; 544 | ;; Cause seems to be passing a record (struct) as an argument. 545 | #; 546 | (TProg (define-fun (foo [c : #,Coord]) : S64 547 | (c -> x)) 548 | #:tests ["foo" (record x (S64 1) y (S64 2)) => (S64 1)]) 549 | ) 550 | ;; Test for F-expander syntax 551 | (TProg (define-fun S32 plus1 ([S32 n]) 552 | (+ n 1)) 553 | (define-fun S32 go () 554 | (define x := (plus1 (S32 5))) 555 | x) 556 | #:tests ["go" => (S32 6)]) 557 | (TProg (define-fun S32 square ([S32 n]) 558 | (* n n)) 559 | (define-fun S32 go () 560 | (define x : S32 := (square (S32 5))) 561 | x) 562 | #:tests ["go" => (S32 25)]) 563 | ;; Check for false positives on the type checker 564 | (TTN S8 128 -129) 565 | (TTN U8 256 -1) 566 | (TTN S16 (expt 2 15) (sub1 (- (expt 2 15)))) 567 | (TTN U16 (expt 2 16) -1) 568 | (TTN S32 (expt 2 31) (sub1 (- (expt 2 31)))) 569 | (TTN U32 (expt 2 32) -1) 570 | (TTN S64 (expt 2 63) (sub1 (- (expt 2 63)))) 571 | (TTN U64 (expt 2 64) -1) 572 | (TTE (iadd (S32 5) (S64 5))) 573 | (TTE (fadd (S32 5) (S32 1))) 574 | (TTE (iadd (F32 5f0) (S32 2))) 575 | (TTE (let ([x : S32 := (S64 5)]) x)) 576 | (TTE ((S32 5) : (array 1 S32))) 577 | (TTE (iadd (F32 5f0) (F32 6F0))) 578 | (TTE (fadd (S32 5) (S32 6))) 579 | (TTE (let ([x : S32 := (S64 5)]) x)) 580 | (TTE (if (F32 2.3f0) (S32 1) (S32 2))) 581 | (TTE (if (S32 0) (S16 1) (U32 2))) 582 | (TTS (let ([x : S32 := (S32 1)]) 583 | (x <- (U64 2)))) 584 | (TTS (let ([x : (array 2 S32) := (array (S32 0) (S32 1))]) 585 | ((x @ 0) <- (U64 2)))) 586 | (TTS (if (F32 2.3f0) (void) (void))) 587 | (TTS (while (F32 23.f0) (void))) 588 | (TTS (let ([x : (array 2 S32) := (array (S32 0) (S32 1))]) 589 | (while x (void)))) 590 | (TTS (let ([x : S32 := (U64 5)]) (void))) 591 | (TTS (let ([x : (union a S32 b S64) := (S32 6)]) (void))) 592 | (TTS (let ([x : (array 2 S32) := (array (S32 1) (S32 2) (S32 3))]) (void))) 593 | (let ([square (F S32 ([S32 n]) (imul n n))]) 594 | (TTS (let ([x : S32 := square <- (S32 5) (S32 6)]) (void))) 595 | (TTS (let ([x : S64 := square <- (S32 5)]) (void))) 596 | (TTS (let ([x : S32 := square <- (S64 5)]) (void))) 597 | (TTS (let ([x : S32 := square <- (S32 5)]) 598 | (x <- (S64 10))))) 599 | (TT (F S32 ([S32 n]) 600 | ((imul n n) : S64))) 601 | ;; ANF 602 | (syntax-parameterize ([F-body-default (make-rename-transformer #'S+)]) 603 | (define-fun S32 square ([S32 n]) 604 | (* n n)) 605 | (define-type Coord (record x S32 y S32)) 606 | (define-type Int/Flo (union i S32 f F32)) 607 | (TS (+ (S32 2) (S32 3)) (S32 5)) 608 | (TS (- (S32 5)) (S32 -5)) 609 | (TS (- (S32 5) (S32 2)) (S32 3)) 610 | (TS (* (S32 5) (S32 4)) (S32 20)) 611 | (TS (/ (S32 9) (S32 3)) (S32 3)) 612 | (TS (% (S32 9) (S32 5)) (S32 4)) 613 | (TS (<< (S32 1) (S32 1)) (S32 2)) 614 | (TS (>> (S32 -2) (S32 1)) (S32 -1)) 615 | (TS (bitwise-ior (S32 1) (S32 2)) (S32 3)) 616 | (TS (bitwise-and (S32 1) (S32 3)) (S32 1)) 617 | (TS (bitwise-xor (S32 3) (S32 2)) (S32 1)) 618 | (TS (= (S32 5) (S32 5)) (S32 1)) 619 | (TS (!= (S32 5) (S32 5)) (S32 0)) 620 | (TS (< (S32 2) (S32 3)) (S32 1)) 621 | (TS (<= (S32 2) (S32 3)) (S32 1)) 622 | (TS (> (S32 2) (S32 3)) (S32 0)) 623 | (TS (>= (S32 2) (S32 3)) (S32 0)) 624 | (TS (add1 (S32 1)) (S32 2)) 625 | (TS (sub1 (S32 2)) (S32 1)) 626 | (TS (let ([x (S32 2)] [y (S32 3)]) 627 | (if (< x y) (+ x y) (error "x not less than y\n"))) 628 | (S32 5)) 629 | (TProg (define-fun S32 foo ([S32 x]) 630 | (let/ec (esc S32) 631 | (if (< x 0) (esc x) (+ x (S32 2))))) 632 | #:tests 633 | ["foo" (S32 -1) => (S32 -1)] 634 | ["foo" (S32 1) => (S32 3)]) 635 | (TProg (define-fun S32 foo ([S32 x]) 636 | (let/ec (esc S32) 637 | (let ([y (S32 2)]) 638 | (if (< x 0) 639 | (esc x) 640 | (let ([z (S32 3)]) 641 | (* (+ x y) z)))))) 642 | #:tests 643 | ["foo" (S32 -1) => (S32 -1)] 644 | ["foo" (S32 1) => (S32 9)]) 645 | (TS (let ([n (S32 1)]) 646 | (void) n) 647 | (S32 1)) 648 | (TS (let ([n (S32 1)]) 649 | (set! n (S32 5)) n) 650 | (S32 5)) 651 | (TS (let ([n (S32 1)]) 652 | (set! n 5) n) 653 | (S32 5)) 654 | (TS (let ([x (S32 5)]) (square x)) (S32 25)) 655 | (TS (let ([c (Coord (S32 2) (S32 3))]) 656 | (* (c -> x) (c -> y))) 657 | (S32 6)) 658 | (TS (let ([n (Int/Flo #:i (S32 5))]) (n as i)) (S32 5)) 659 | (TS (let ([n (Int/Flo #:i (S32 1))] [c (Coord (S32 2) (S32 3))]) 660 | (+ (n as i) (* (c -> x) (c -> y)))) 661 | (S32 7)) 662 | (TS (let ([n (let ([x (S32 2)] [c (Coord (S32 2) (S32 1))]) 663 | (+ x (+ (c -> x) (c -> y))))]) 664 | (let ([m (Int/Flo #:i n)]) 665 | (+ (m as i) (S32 1)))) 666 | (S32 6)) 667 | (TS #,(values '() (E (S32 5))) (S32 5)) 668 | (TS (+ (S32 2) #,(values '() (E (S32 3)))) (S32 5)) 669 | (TS (and) (S8 1)) 670 | (TS (and (S32 2)) (S32 2)) 671 | (TS (and (S32 1) 2) (S32 2)) 672 | (TS (and (S32 0) 2) (S32 0)) 673 | (TS (or) (S8 0)) 674 | (TS (or (S32 5)) (S32 5)) 675 | (TS (or (S32 0) 0 (if 0 1 2)) (S32 2)) 676 | (TS (or (S32 0) 5) (S32 5)) 677 | ) 678 | )) 679 | --------------------------------------------------------------------------------