├── .gitignore ├── Carrot.scm ├── README.md ├── bin ├── carrot-compile.scm ├── carrot-read.scm ├── carrot-type.scm └── carrot-vm.scm ├── compilers ├── to-carrot-vm.scm └── to-js.scm ├── docs ├── SECD-implementation.md ├── bench-result.md ├── carrot.png ├── carrot1.png └── krivine-memo.scm ├── examples ├── Y-combinator.nadeko ├── coffee-cup.carrot ├── concatenative.nadeko ├── fact.nadeko ├── prelude.nadeko ├── primes.nadeko ├── srfi-1.nadeko ├── tarai.nadeko └── test.nadeko ├── install.sh ├── lib ├── CarrotVM.scm ├── Check.scm ├── DataTypes.scm ├── Read.scm ├── Type.scm └── util.scm ├── old ├── Compiler.scm ├── K-Compiler.scm ├── Krivine.scm └── SECD.scm └── tests └── srfi-1.scm /.gitignore: -------------------------------------------------------------------------------- 1 | \.\#* 2 | -------------------------------------------------------------------------------- /Carrot.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env gosh 2 | 3 | ;;;; Carrot ;;;; 4 | ;;; 2012 Minori Yamashita ;;add your name here 5 | 6 | (add-load-path "./lib/" :relative) 7 | (add-load-path "./compilers/" :relative) 8 | 9 | (use Util) 10 | (use to-carrot-vm) 11 | (use CarrotVM) 12 | (use Type) 13 | (use Read) 14 | (use DataTypes) 15 | (use gauche.parseopt) 16 | 17 | ;;; REPL ;;; 18 | (define (REPL exprs*types*genmap ctr) 19 | ;;(p (hash-table->alist (caddr exprs*types*genmap))) 20 | (format #t "carrot ~S> " ctr) 21 | (flush) 22 | (let* ([expr (read)] 23 | [res (read-s-exprs (list expr) exprs*types*genmap)] 24 | [exprs-ht (fst res)] 25 | [types-ht (snd res)] 26 | [genmap (thd res)] 27 | [checked-p*t (acquire-checked-program res)] 28 | [checked-p (fst checked-p*t)] 29 | [main-t (snd checked-p*t)]) 30 | (unless checked-p 31 | (print "Skipping execution due to one or more type errors _(′︿‵｡_)") 32 | (hash-table-delete! exprs-ht (get-main-name genmap)) 33 | (hash-table-delete! types-ht (get-main-name genmap)) 34 | (hash-table-delete! genmap 'main) 35 | (REPL res (+ ctr 1))) 36 | (format #t " ;=> ~A :: ~S\n\n" 37 | (fmt (CarrotVM (compile checked-p) (get-main-name genmap))) 38 | (type->data main-t)) 39 | (hash-table-delete! exprs-ht (get-main-name genmap)) 40 | (hash-table-delete! types-ht (get-main-name genmap)) 41 | (hash-table-delete! genmap 'main) 42 | (REPL res (inc ctr)))) ;loop with new global-environment 43 | 44 | (define banner 45 | " ---------------------- 46 | | CARROT 2.2.0 | 47 | ---------------------- 48 | https://github.com/ympbyc/Carrot\n") 49 | 50 | (define (main args) 51 | (print banner) 52 | (format #t "Loading ~S ... done\n" (cons "examples/prelude.nadeko" (cdr args))) 53 | (let* ([fnames (cons "examples/prelude.nadeko" (cdr args))] 54 | [exprs*types*genmap (triple (make-hash-table 'eq?) 55 | (make-hash-table 'eq?) 56 | (make-hash-table 'eq?))] 57 | [exprs*types*genmap 58 | (fold (fn [fname exprs*types*genmap] 59 | (load-file fname exprs*types*genmap)) 60 | exprs*types*genmap 61 | fnames)]) 62 | (print (sort (map symbol->string (hash-table-keys (thd exprs*types*genmap))))) 63 | (newline) 64 | (REPL exprs*types*genmap 0))) 65 | 66 | ;;string * {types} -> ({types} . typed-expr) 67 | (define (load-file fname exprs*types*genmap) 68 | (call-with-input-file fname 69 | (fn [file-port] 70 | (let* ([exprs*types*genmap 71 | (read-s-exprs (read-list file-port) 72 | exprs*types*genmap)] 73 | ;;[checks? (type-check exprs*types*genmap)] 74 | ) 75 | (p (acquire-checked-program exprs*types*genmap)) 76 | exprs*types*genmap)))) 77 | 78 | (define (read-list port) 79 | (let ((exp (read port))) 80 | (if (eof-object? exp) '() 81 | (cons exp (read-list port))))) 82 | 83 | ;; avoid printing closures 84 | (define (fmt data) 85 | (if (is-a? data ) 86 | (format "#,(function ~A)" (name data)) 87 | data)) 88 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Carrot 2 | ====== 3 | 4 | Dec 2012 Minori Yamashita 5 | 6 | 7 | ```lisp 8 | ;;./Carrot.scm examples/srfi-1.nadeko 9 | 10 | (-> (Y (^ f (cons 1 (cons 1 (zipWith f + (cdr f)))))) 11 | -> (take 8) 12 | -> reverse 13 | <- (foldl (comp (comp ++ (++ " : ")) num->str) "")) 14 | ``` 15 | 16 | 17 | 18 | **Check out Carrot 2 (also WIP) too** 19 | 20 | 21 | Installation 22 | ------------ 23 | 24 | + Install gauche http://practical-scheme.net/gauche/index.html 25 | + Clone this repository 26 | 27 | REPL 28 | ---- 29 | 30 | ### To run the VM at the bleeding edge 31 | 32 | ``` 33 | ./Carrot.scm examples/srfi-1.scm 34 | ``` 35 | 36 | 37 | The language 38 | ------------ 39 | 40 | This section specifies the language Carrot. 41 | Carrot is a powerful functional programming language designed to be extremely simple and portable. 42 | 43 | ### Comments 44 | 45 | Characters in a line after semicolon are treated as comments 46 | 47 | **code 0** *comments* 48 | 49 | ``` 50 | ;this is a comment 51 | "this is not a comment" ;this is a comment 52 | ``` 53 | 54 | ### Primitive values **(Expression)** 55 | 56 | Primitive values are values that evaluates to itself. They include numbers, characters, strings, symbols and so on. 57 | Implementations must provide at least the following primitives: 58 | 59 | + Strings 60 | + Numbers 61 | + Symbols 62 | 63 | **code 1** *examples of primitive values* 64 | 65 | ```lisp 66 | "abcd" ;string 67 | 1 ;number 68 | 'foo ;symbol 69 | ``` 70 | 71 | ### Identifiers **(Expression)** 72 | 73 | Identifiers are symbols that are or to be bound to another value. They are used to name functions, and as parameters of functions. 74 | An identifier consists of one or more non-whitespace charactors. Some combinations are reserved as they are syntactic forms. 75 | 76 | **code 2** *examples of identifiers* 77 | 78 | ```lisp 79 | aaa 80 | -he-lo- 81 | 82 | @#=~ 83 | ``` 84 | 85 | Implementations SHOULD allow every character that is not used for literals to be used to construct identifiers. 86 | 87 | ### Lambda expressions **(Expression)** 88 | 89 | Lambda expressions create closures. Closures are objects that when applied to a value evaluate another value. They are basically, functions carrying its own environment with it. 90 | 91 | Lambda expressions have the syntactic form 92 | (^ *identifier ...* *expression*) 93 | Where *identifier ...* is replaced with an arbitrary number of identifiers, and *expression* is replaced with an actual expression. 94 | *identifier* is a parameter that gets bound to a value(actualy a thunk as we see later) when the closure is applied to arguments. 95 | 96 | **code 3** *lambda expressions* 97 | 98 | ```lisp 99 | (^ x (* x x)) ;;A 100 | 101 | (^ a b c (* a (+ b c))) ;;B 102 | ``` 103 | 104 | The expression A, when applied, computes the squared value of a given number. 105 | The expression B, when applied, performs a simple arithmetic operations on three numbers. 106 | Note that the expression B is semantically the same as the following expression. 107 | 108 | **code 4** *explicit currying* 109 | 110 | ```lisp 111 | (^ a (^ b (^ c (* a (+ b c))))) ;;C 112 | ``` 113 | 114 | In fact, Carrot interprets the code B as C. 115 | We will discuss the significance of it later. 116 | 117 | 118 | ### Definition (Statement) 119 | 120 | The expression 121 | (= (*name* *type* ...) *[identifier ...]* *expression*) 122 | or 123 | (=u (*name* *type* ...) *[identifier ...]* *expression*) 124 | Binds the *expression* to the *name*. 125 | If one or more parameters( *identifier ...* ) are given, they can be used in the *expression* to refer to the values the function is applied to. `=u` directs the compiler not to type-check the function body. 126 | 127 | Multiple functions can share a name. In which case their types must differ. 128 | 129 | **code 5** *defining a `map` function* 130 | 131 | ```lisp 132 | (= (map (List a) (Fn a b) (List b)) 133 | xs f 134 | (nil? xs nil 135 | (cons (f (car xs)) 136 | (map (cdr xs) f)))) 137 | ``` 138 | 139 | Implementations SHOULD implement tail call otimization. 140 | 141 | ### Application (Expression) 142 | 143 | Functions(closures) can be applied to arguments. The application begins with an open paren, then the function, followed by a sequence of arguments, and ends with an corresponding close paren. 144 | 145 | **code 6** *applying `map` function to a list* 146 | 147 | ```lisp 148 | (map listX functionX) ;;A 149 | 150 | (map (take integers 5) (+ 2)) ;;B 151 | ``` 152 | 153 | In the expression A, the map function defined in code 5 is applied to two arguments; listX and functionX assuming they are defined elsewhere. 154 | This fills the parameter slots of the map function meaning that listX gets bound to xs and functionX gets bound to f. The expression inside map is then evaluated using both listX and functionX. Eventually the evaluation completes; producing a value(in this case a new list). 155 | 156 | + Carrot uses call-by-need evaluation strategy (although the implementation is incomplete). 157 | + Every function is curried. 158 | 159 | Implementations SHOLD implement "call-by-need" instead of "call-by-name". 160 | 161 | 162 | Type System 163 | ----------- 164 | 165 | Carrot's type system is aimed to check if the programme's intention was consistent throughout the program. The type system is unique and somewhat criptic at first sight: 166 | 167 | ### How to Type Expressions 168 | 169 | The syntactic form `=` gives types to identifiers. 170 | 171 | ```lisp 172 | ;; typing primitive values 173 | (= (name String) "Rikka") 174 | 175 | ;; typing composit values 176 | (= (names (List String)) (cons "Rikka" (cons "Kozue" (cons "Kamome" nil)))) 177 | 178 | ;; typing functions 179 | (= (second (List a) a) ;; ( ... ) 180 | xs ;; parameter... 181 | (car (cdr xs))) ;; expression 182 | ``` 183 | 184 | ### Twisted Algebraic Data Type 185 | 186 | Carrot has no data structures except for closures, yet the type system is rich enough to express something like algebraic data types. Use `=u` for constructors instead of `=`. 187 | 188 | ```lisp 189 | ;; Lists 190 | (=u (cons a (List a) (List a)) 191 | x xs f (f x xs)) 192 | (=u (nil (List a)) 'nil) 193 | (= (car (List a) a) 194 | xs (xs true)) 195 | (= (cdr (List a) (List a)) 196 | xs (xs false)) 197 | ``` 198 | 199 | ### Things Start to Get Odd 200 | 201 | Carrot's runtime values are completely **untyped** (not even dynamicaly typed). As a consequence, Carrot's types are completely independent from its underlying implementation. 202 | 203 | ```lisp 204 | ;;invisible container 205 | 206 | (=u (box a (Box a)) 207 | x x) ;; a boxed value's internal representation is the value itself 208 | (=u (takeout (Box a) a) 209 | x x) ;; just return what gets passed in 210 | 211 | (box 7) ;;=> 7 212 | (takeout 7) ;;=> TYPE ERROR! 213 | (takeout (box 7)) ;;=> 7 214 | ``` 215 | 216 | Statically-Resolved MultiMethods 217 | --------------------------------- 218 | 219 | Carrot supports multimethods. Because Carrot's runtime values are untyped, methods have to be selected at compile-time. 220 | 221 | ```lisp 222 | (=u (dog Dog) :dog) 223 | (=u (cat Cat) :cat) 224 | 225 | (= (talk Dog String) _ "bow-wow") 226 | (= (talk Cat String) _ "meoooow") 227 | 228 | (talk cat) 229 | ``` 230 | 231 | Current implementation can't dispatch on generic types like `(List a)`. 232 | 233 | S-expression without paren hell 234 | ------------------------------- 235 | 236 | Carrot's default currying policy togather with lazyness gave us an unexpected gift -- Reduced use of parentheses. 237 | 238 | Because the arguments are delayed automaticaly, we can implement booleans as functions. 239 | 240 | ```lisp 241 | (= (true Bool) t e t) 242 | (= (false Bool) t e e) 243 | 244 | ;scheme 245 | (if (eq? a b) "equal" "not equal") 246 | 247 | ;carrot 248 | (=? a b "equal" "not equal") 249 | ``` 250 | 251 | 267 | 268 | Pipeline operator in F#, and Synthread in Clojure are useful tool to avoid nesting of function calls. In Carrot, `->` can be used to compose functions left to right so it reads similarly to the synthread. 269 | 270 | `->` is just a `(Fn b c) -> (Fn a b) -> c` function. 271 | 272 | ```lisp 273 | (-> 1 274 | -> (+ 2) 275 | -> (* 3) 276 | -> num->str 277 | <- (flip ++ " = nine")) 278 | 279 | ;;is equivalent to 280 | (++ (num->str (* (+ 1 2) 3)) " = nine") 281 | 282 | 283 | (-> nil 284 | -> (acons :name "立華") 285 | -> (acons :favorite "ツナ") 286 | -> (acons :job "ネットワークエンジニア") 287 | <- (^ rikka (+++ (pull (assq :job rikka)) 288 | (pull (assq :name rikka)) 289 | (pull (assq :favorite rikka))))) 290 | ``` 291 | 292 | I/O 293 | --- 294 | 295 | I/O in lazy languages are hard because the order of evaluation is not lexical, and if the return value of an I/O operation does not affect the overall result, the operation itself gets ommited. To go around this problem, Haskell uses what's called an IO Monad. IO Monad is a way to construct a computation, and sideeffects don't happen while the program is being evaluated. 296 | Carrot takes a saner approach than that. It uses what we call a timed-io. Every sideeffectful function F takes an additional argument time X, and F that usually return `()` instead return a time Y. By giving Y to another sideeffectful function G, a clear relation between F and G gets formed so Carrot can figure out the evaluation order. 297 | Every sideeffectful function may cache its results based on the time so it works fine even with call-by-name strategy. 298 | 299 | ```lisp 300 | (-> (print 0 "Hi! What's your name?") 301 | -> read 302 | -> (^ name (print 1 (+++ "Nice to meet you, " name ". What do you like?"))) 303 | -> read 304 | id (^ thing (print 2 (++ thing "? I like that, too!")))) 305 | ``` 306 | 307 | Macros 308 | ------ 309 | 310 | There is no macro mechanism built in to Carrot at this stage partly because there's littele need for it. 311 | 312 | 313 | What's Coming or How to contribute 314 | ---------------------------------- 315 | 316 | Here are the list of features I intend to implement but haven't due to current dayjob situations (or because I'm flirting with Common Lisp all the time). I would love if someboday takes a shot at some of these. Be sure to email me (ympbyc at gmail) I'm lazy on github. 317 | 318 | #### Call-by-Name Macro 319 | 320 | Because Carrot is call-by-name, macro effect can be achieved with an operator which tells the compiler to suppress the evaluation of its operand. Type signature might be a good place to do this. 321 | 322 | ```scm 323 | (= (example AST AST AST) x y 324 | "We'll also need a way to construct lists more easily") 325 | ``` 326 | 327 | #### Proper Multimethod 328 | 329 | Current implementation can't dispatch on composit datatypes. To make this work, some sort of templating mechanism is needed. You'll know what I mean if you try. 330 | 331 | #### Lambda Folding and Constant Folding 332 | 333 | Like Common Lisp compiler 334 | 335 | #### Emacs SLIME support 336 | 337 | 338 | 339 | 340 | Influenced by 341 | -------------- 342 | 343 | Carrot is influenced by the following languages 344 | 345 | + Haskell - for lazyness and currying 346 | + Scheme - for syntax and actors 347 | + Io - for simplicity 348 | + Smalltalk-72 - for messaging notation 349 | + Clojure 350 | 351 | License 352 | ------- 353 | 354 | MIT 355 | 356 | CHANGELOG 357 | --------- 358 | 359 | ### 1/22/2014 360 | 361 | Statically-selected multimethod 362 | 363 | ### 1/4/2014 364 | 365 | Integrated a type system. 366 | 367 | ### 11/17/2013 368 | 369 | Krivine VM is replaced by S Machine described in http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR581 370 | 371 | ### 9/26/2013 372 | 373 | A huge change in syntax. 374 | 375 | + `(:= (fname param ...) expr)` is replaced by `(= fname param ... expr)` 376 | + `(:= (name) const)` is replaced by `(= name const)` 377 | + `(-> (param ...) expr)` is replaced by `(^ param ... expr)` 378 | + `=` for equality check is replaced by `=?` 379 | 380 | All the examples and tests are up to date with this change. 381 | -------------------------------------------------------------------------------- /bin/carrot-compile.scm: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/gosh 2 | 3 | (add-load-path "../lib/" :relative) 4 | (add-load-path "../compilers/" :relative) 5 | (add-load-path "/usr/local/share/Carrot/2.2.0/lib/" :absolute) 6 | (add-load-path "/usr/local/share/Carrot/2.2.0/compilers/" :absolute) 7 | 8 | (use Util) 9 | (use DataTypes) 10 | 11 | (define (main args) 12 | (let* ([compiler-name (cadr args)] 13 | [exprs*t (read)]) 14 | (format (standard-error-port) 15 | "Compiling your carrot ~A...\n" compiler-name) 16 | (load (str compiler-name ".scm")) 17 | (let1 res (eval `(compile ,(fst exprs*t)) 18 | (find-module (string->symbol compiler-name))) 19 | (cond [(hash-table? res) 20 | (display (write-hash-table res))] 21 | [string? res (display res)])))) 22 | -------------------------------------------------------------------------------- /bin/carrot-read.scm: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/gosh 2 | 3 | (add-load-path "../lib/" :relative) 4 | (add-load-path "/usr/local/share/Carrot/2.2.0/lib/" :absolute) 5 | 6 | (use DataTypes) 7 | (use Read) 8 | 9 | (define banner 10 | " 11 | ---------------------- 12 | | CARROT 2.2.0 | 13 | ---------------------- 14 | https://github.com/ympbyc/Carrot 15 | 16 | Reading your carrot... 17 | ") 18 | 19 | (define (read-list port) 20 | (let ((exp (read port))) 21 | (if (eof-object? exp) '() 22 | (cons exp (read-list port))))) 23 | 24 | (define (main _) 25 | (let* ([program (read-list (standard-input-port))] 26 | [_ (format (standard-error-port) banner)] 27 | [exprs*types*genmap 28 | (read-s-exprs* program 29 | (make-hash-table 'eq?) 30 | (make-hash-table 'eq?) 31 | (make-hash-table 'eq?))]) 32 | (display 33 | (triple (write-hash-table (fst exprs*types*genmap)) 34 | (write-hash-table (snd exprs*types*genmap)) 35 | (write-hash-table (thd exprs*types*genmap)))))) 36 | -------------------------------------------------------------------------------- /bin/carrot-type.scm: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/gosh 2 | 3 | (add-load-path "../lib/" :relative) 4 | (add-load-path "/usr/local/share/Carrot/2.2.0/lib/" :absolute) 5 | 6 | (use DataTypes) 7 | (use Type) 8 | 9 | (define (main _) 10 | (let* ([exprs*types*genmap (read)] 11 | [_ (format (standard-error-port) "Type-checking your carrot...\n")] 12 | [exprs*t (acquire-checked-program exprs*types*genmap)]) 13 | (display 14 | (pair (write-hash-table (fst exprs*t)) 15 | (snd exprs*t))))) 16 | -------------------------------------------------------------------------------- /bin/carrot-vm.scm: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/gosh 2 | 3 | (add-load-path "../lib/" :relative) 4 | (add-load-path "/usr/local/share/Carrot/2.2.0/lib/" :absolute) 5 | 6 | (use DataTypes) 7 | (use CarrotVM) 8 | 9 | (define message "Executing your carrot on CarrotVM 10 | 11 | ;=> ") 12 | 13 | (define (main args) 14 | (let* ([exprs-ht (read)]) 15 | (format (standard-error-port) message) 16 | (print 17 | (CarrotVM exprs-ht 'main)))) 18 | -------------------------------------------------------------------------------- /compilers/to-carrot-vm.scm: -------------------------------------------------------------------------------- 1 | ;;;; Carrot -> CarrotVM instruction ;;;; 2 | ;;; 2012 Minori Yamashita ;;add your name here 3 | ;;; 4 | 5 | (add-load-path "../lib/" :relative) 6 | 7 | (define-module to-carrot-vm 8 | (export compile) 9 | (use srfi-1) 10 | (use DataTypes) 11 | (use Util) 12 | 13 | ;;; Compiler ;;; 14 | 15 | 16 | ;;compile :: {name => expr} -> {name => k-expr} 17 | ;; (= ( ) ) 18 | (define (compile exprs-ht) 19 | (alist->hash-table 20 | (hash-table-map exprs-ht 21 | (fn [k expr] (cons k (make 22 | :expr (expand-expr expr '()) 23 | :env '() 24 | :name k)))))) 25 | 26 | 27 | ;; (^ x y z exp) -> (^ x (^ y (^ z exp))) 28 | (define (curry-lambda params expr) 29 | (if (null? params) 30 | expr 31 | (make 32 | :parameter (car params) 33 | :expression (curry-lambda (cdr params) expr)))) 34 | 35 | 36 | (define (appv? ag env) 37 | (and (eq? (class-of ag) ) 38 | (member (var ag) env))) 39 | 40 | 41 | ;; (f x y z) -> (((f x) y) z) 42 | (define (expand-app f args env) 43 | (if (null? args) 44 | f 45 | (let ([ag (expand-expr (car args) env)]) 46 | (expand-app (make (if (appv? ag env) ) 47 | :operator f :operand ag) 48 | (cdr args) 49 | env)))) 50 | 51 | (define (expand-expr expr env) 52 | ;;(p (show-typed-expr tx)) 53 | (cond 54 | [(and (symbol? expr) (member expr env)) 55 | (make :var expr)] 56 | 57 | [(symbol? expr) 58 | (make :var expr)] 59 | 60 | [(string? expr) 61 | (make :val expr)] 62 | 63 | [(atom? expr) 64 | (make :val expr)] 65 | 66 | [(quote-expr? expr) 67 | (make :val expr)] 68 | 69 | ;;(^ x M) 70 | [(lambda-expr? expr) 71 | (let ([params (drop-right (cdr expr) 1)]) 72 | (curry-lambda params 73 | (expand-expr (last expr) 74 | (append env params))))] 75 | 76 | ;;(** + M L) 77 | [(native-expr? expr) 78 | (expand-app (make :procedure (cadr expr)) 79 | (cddr expr) env)] 80 | 81 | [else 82 | ;;(f a b c) 83 | (let ([exp (macroexpand expr)]) 84 | (expand-app (expand-expr (car exp) env) 85 | (cdr exp) env))]))) 86 | -------------------------------------------------------------------------------- /compilers/to-js.scm: -------------------------------------------------------------------------------- 1 | ;;;; Carrot -> JS 2 | ;;; 2014 Minori Yamashita 3 | ;;; 4 | 5 | (define-module to-js 6 | (export compile) 7 | (use srfi-1) 8 | (use Util) 9 | (use DataTypes) 10 | 11 | (define (compile exprs-ht) 12 | (str 13 | (fold (fn [name*expr js-src] 14 | (let ([name (car name*expr)] 15 | [expr (cdr name*expr)]) 16 | (str js-src 17 | "var " (compatible-symbol name) 18 | " = " 19 | (if (lambda-expr? expr) 20 | (compile-function expr '()) 21 | (thunk (compile-expr expr '()))) 22 | ";\n"))) 23 | "" 24 | (hash-table->alist exprs-ht)) 25 | js-prelude 26 | "console.log(main());")) 27 | 28 | (define (compile-function fn env) 29 | (let1 params (butlast (cdr fn)) 30 | (if (null? params) 31 | (compile-expr (last fn) env) 32 | (str (compatible-symbol (car params)) 33 | " => " (compile-function (cons '^ (cddr fn)) 34 | (cons (car params) env)))))) 35 | 36 | (define (compile-funcall f args env) 37 | (if (null? args) f 38 | (compile-funcall (str f "(" 39 | (thunk (compile-expr (car args) env)) ")") 40 | (cdr args) env))) 41 | 42 | (define (compile-nativecall f args env) 43 | (if (null? args) f 44 | (compile-nativecall (str f "(" 45 | (compile-expr (car args) env) ")") 46 | (cdr args) env))) 47 | 48 | (define (compatible-symbol sym) 49 | (replace-incompatible-chars (symbol->string sym))) 50 | 51 | (define (replace-incompatible-chars str) 52 | (let* ([str (regexp-replace-all #/-/ str "_")] 53 | [str (regexp-replace-all #/!/ str "_BANG_")] 54 | [str (regexp-replace-all #/\?/ str "_Q_")] 55 | [str (regexp-replace-all #/\*/ str "_STAR_")] 56 | [str (regexp-replace-all #// str "_GT_")] 58 | [str (regexp-replace-all #/\// str "_SLASH_")] 59 | [str (regexp-replace-all #/\+/ str "_SUM_")] 60 | [str (regexp-replace-all #/=/ str "_EQ_")] 61 | [str (regexp-replace-all #/%/ str "_PERC_")] 62 | [str (regexp-replace-all #/^false$/ str "_FALSE_")] 63 | [str (regexp-replace-all #/^true$/ str "_TRUE_")] 64 | [str (regexp-replace-all #/^if$/ str "_IF_")] 65 | [str (regexp-replace-all #/^delete$/ str "_DELETE_")]))) 66 | 67 | 68 | (define (thunk exp) 69 | (str "() => " exp)) 70 | 71 | 72 | (define (compile-expr expr env) 73 | (cond 74 | [(and (symbol? expr) 75 | (member expr env)) 76 | (str (compatible-symbol expr) "()")] 77 | 78 | [(symbol? expr) (compatible-symbol expr)] 79 | 80 | [(or (string? expr) (keyword? expr) (char? expr)) 81 | (str "'" (regexp-replace-all #/\n/ 82 | (regexp-replace-all 83 | (string->regexp "'") (str expr) "") 84 | "\\\\n") "'")] 85 | 86 | [(atom? expr) (str expr)] 87 | 88 | [(quote-expr? expr) 89 | (str "'(quote " (cadr expr) ")'")] 90 | 91 | [(lambda-expr? expr) 92 | (compile-function expr env)] 93 | 94 | [(native-expr? expr) 95 | (compile-nativecall (compile-expr (cadr expr) env) (cddr expr) env)] 96 | 97 | [else ;;funcall 98 | (compile-funcall (compile-expr (car expr) env) (cdr expr) env)])) 99 | 100 | 101 | 102 | 103 | (define js-prelude " 104 | var c_equal_Q_ = x => y => { if (x == y) return _TRUE_; else return _FALSE_; }; 105 | var c__LT_ = x => y => { if (x < y) return _TRUE_; else return _FALSE_; }; 106 | var c__GT_ = x => y => { if (x > y) return _TRUE_; else return _FALSE_; }; 107 | var c__LT__EQ_ = x => y => { if (x <= y) return _TRUE_; else return _FALSE_; }; 108 | var c__GT__EQ = x => y => { if (x >= y) return _TRUE_; else return _FALSE_; }; 109 | var c__SUM_ = x => y => x + y; 110 | var c__ = x => y => x - y; 111 | var c__STAR_ = x => y => x * y; 112 | var c__SLASH_ = x => y => x / y; 113 | var c__PERC_ = x => y => x % y; 114 | var c_string_append = x => y => x + y; 115 | var number__GT_string = x => '' + x 116 | var keyword__GT_string = x => x; 117 | var timed_print = t => s => { console.log(s); return t + 1; }; 118 | var read = t => prompt() 119 | ")) 120 | -------------------------------------------------------------------------------- /docs/SECD-implementation.md: -------------------------------------------------------------------------------- 1 | Sections below this line talks about the internal mechanism of the implementation written by Minori Yamashita. The internal mechanism may differ significantly between implementations as long as it maintain the specified external behaviour. 2 | 3 | VM - SECD Machine 4 | ----------------- 5 | 6 | Nadeko uses a custum implementation of the SECD virtual machine. SECD machine is a VM designed specifically to host functional programming languages and well suits Nadeko. 7 | 8 | ### Stacks 9 | 10 | SECD machine has four stacks. S, E, C, and D. 11 | 12 | S - Stack - is used as a workspace for the current computation. 13 | E - Environment - is used to store the current local environment. 14 | C - Code - holds the pending instructions to be computed. 15 | D - Dump - is used as a call frame. when applying a function, we store the current S, E, C to Dump. 16 | 17 | Nadeko adds one slot G which maintains the global environment. 18 | 19 | ### Instructions 20 | 21 | #### ldc - stack-constant 22 | Cons the argument onto the stack. 23 | 24 | ``` 25 | (S E ((_ const) . C) D G) 26 | ((const . S) E C D G) 27 | ``` 28 | 29 | #### ld - ref-arg 30 | Cons the bound value of the argument onto the stack. 31 | 32 | ``` 33 | (S E ((_ var) . C) D G) 34 | (((lookup var) . S) E C D G) 35 | ``` 36 | 37 | #### ldf - stack-closure 38 | Creates a closure from its parameter name, code, and the current E. 39 | Cons it onto the stack. 40 | 41 | ``` 42 | (S E ((_ param code) . C) D) 43 | (((closure param code E) . S) E C D) 44 | ``` 45 | 46 | #### ap - app 47 | Apply the closure at (car S) to the argument at (cadr S) 48 | Dump current (cddr S), E, C. Empty S. Cons param-arg pair onto E. let C be the code inside the closure. 49 | 50 | ``` 51 | (((closure param code env) . arg . S) E ((_) . D) G) 52 | (() ((param . arg) . env) code ((S E C) . D) G) 53 | ``` 54 | 55 | #### ret - restore 56 | Restore S, E, C from D. cons previous (car S) onto S. 57 | 58 | ``` 59 | ((retVal . S) E ((_) . C) ((s e c) . D) G) 60 | ((retVal . s) e c D G) 61 | ``` 62 | 63 | #### def - def 64 | Cons the pair of the argument and (car S) onto G 65 | 66 | ``` 67 | ((val . S) E ((_ symbol) . C) D G) 68 | (S E C D ((symbol val) . G)) 69 | ``` 70 | 71 | #### freeze - freeze 72 | Creates a thunk and cons it onto the stack. 73 | 74 | ``` 75 | (S E ((_ code) . C) D G) 76 | (((thunk code E) . S) E C D G) 77 | ``` 78 | 79 | #### thaw - thaw 80 | Evaluates the code inside the thunk in its environment. 81 | Creates a call frame like app. 82 | 83 | ``` 84 | (((thunk code env) . S) E ((_) . C) D G) 85 | (() env code ((S E C) . D) G) 86 | ``` 87 | 88 | #### stop - stop 89 | Stops the Machine and return the value at the top of the stack 90 | 91 | ``` 92 | ((retVal . S) E C D G) 93 | retVal 94 | ``` 95 | 96 | #### primitive - primitive 97 | Apply host-language's function to the stack 98 | 99 | 100 | 101 | Compiler 102 | -------- 103 | 104 | Here are some examples showing SECD instructions that can be obtained by compiling Nadeko programs. 105 | 106 | ### function calls 107 | 108 | **code 1** *Nadeko source* 109 | 110 | ```lisp 111 | (integers -take 5 -map (* 2) -fold + 0) 112 | ``` 113 | 114 | This Nadeko code gets compiled into the following SECD instructions. 115 | 116 | **code 2** *code 1 compiled into SECD instruction* 117 | 118 | ```lisp 119 | ( 120 | (freeze ((stack-constant 0) (restore))) ;; 0 121 | (freeze ((ref-arg +) (thaw) (restore))) ;; + 122 | (freeze ((ref-arg -fold) (thaw) (restore))) ;; -fold 123 | (freeze ( 124 | (freeze ((stack-constant 2) (restore))) 125 | (ref-arg *) 126 | (thaw) 127 | (app) 128 | (restore))) ;; (* 2) 129 | (freeze ((ref-arg -map) (thaw) (restore))) ;; -map 130 | (freeze ((stack-constant 5) (restore))) ;; 5 131 | (freeze ((ref-arg -take) (thaw) (restore))) ;; -take 132 | (ref-arg integers) ;; integers 133 | (thaw) 134 | (app) 135 | (app) 136 | (app) 137 | (app) 138 | (app) 139 | (app) 140 | (app) 141 | (stop) 142 | ) 143 | ``` 144 | 145 | When applying a function to its argument, the argument and the function 146 | have to be consed onto the `Stack` in respective order. Then an application instruction appear and β-reduction occurs. 147 | 148 | **code 3** *typical application instructions* 149 | 150 | ```lisp 151 | (stack-constant 1) 152 | (stack-closure x ((ref-arg x) (restore))) 153 | (app) 154 | ``` 155 | 156 | Nadeko is a lazily evaluated language so the argument to the function have to be frozen(i.e. turned into a thunk or promise). `freeze` instruction performs such an operation. 157 | `thaw` reverses the `freeze` operation; it evaluates the code inside the frozen thunk in the environment it got frozen. 158 | 159 | **code 4** *application instructions with lazy evaluation* 160 | 161 | ```lisp 162 | (freeze ((stack-constant 1) (restore))) 163 | (stack-closure x ((ref-arg x) (thaw) (restore))) 164 | (app) 165 | ``` 166 | 167 | ### defining functions 168 | 169 | ```lisp 170 | (:= (add x y) (+ x y)) 171 | ``` 172 | 173 | ```lisp 174 | ( 175 | (freeze ( 176 | (stack-closure x ( 177 | (stack-closure y ( 178 | (freeze ((ref-arg y) (thaw) (restore))) 179 | (freeze ((ref-arg x) (thaw) (restore))) 180 | (ref-arg +) 181 | (thaw) 182 | (app) 183 | (app) 184 | (restore))) 185 | (restore))) 186 | (restore))) 187 | (def add) 188 | (stop) 189 | ) 190 | ``` 191 | 192 | ### currying 193 | Currying can be achieved by recursively compiling the lambda expression created with its (cdr params). 194 | 195 | Multi-arg application can be achieved by recursively compiling the arguments and delaying them, stack them in reverse order, stack the closure, and add the same number of (app) as arguments. -------------------------------------------------------------------------------- /docs/bench-result.md: -------------------------------------------------------------------------------- 1 | Bench Result 2 | ============ 3 | 4 | ## Fibonacci List 5 | 6 | ``` 7 | time echo '(Y (-> (f) (cons 1 (zipWith f + (cdr f)) -cons 1)) -take 10 -reverse -fold (compose (compose ++ (++ ",")) show) "")' | gosh Nadeko.scm -l=examples/srfi-1.nadeko 8 | ``` 9 | 10 | ### With SECD VM 11 | gosh Nadeko.scm -l=examples/srfi-1.nadeko 4.53s user 0.02s system 99% cpu 4.548 total 12 | 13 | 14 | ### With Krivine's Machine 15 | gosh Nadeko.scm -l=examples/srfi-1.nadeko 2.38s user 0.01s system 99% cpu 2.396 total 16 | 17 | ### With Krivine's Machine Extended with proper support for primitives 18 | gosh Nadeko.scm -l=examples/srfi-1.nadeko 1.76s user 0.01s system 99% cpu 1.773 total 19 | 20 | ## Tarai 21 | 22 | ### Nadeko 23 | 24 | code 25 | 26 | ```lisp 27 | (:= (tarai x y z) 28 | (<= x y y 29 | (tarai (tarai (- x 1) y z) 30 | (tarai (- y 1) z x) 31 | (tarai (- z 1) x y)))) 32 | (** time (tarai 18 9 0)) 33 | ``` 34 | 35 | result 36 | 37 | ```lisp 38 | ;(time (get-constant (car p-args))) 39 | ; real 0.062 40 | ; user 0.060 41 | ; sys 0.010 42 | ``` -------------------------------------------------------------------------------- /docs/carrot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ympbyc/Carrot/c5258a878864fa4c91727c99820d8348185c84e7/docs/carrot.png -------------------------------------------------------------------------------- /docs/carrot1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ympbyc/Carrot/c5258a878864fa4c91727c99820d8348185c84e7/docs/carrot1.png -------------------------------------------------------------------------------- /docs/krivine-memo.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;; N[n] = ACCESS(n); CONTINUE 3 | ;; N[λa] = GRAB; N[a] 4 | ;; N[b a] = CLOSURE(N[a]); N[b] 5 | ;; 6 | ;; M := x | M_1 M_2 | λx.M 7 | ;; (M N, S, E) -> (M, (S,(N,E)), E) 8 | ;; (λM, (S,N), E) -> (M, S, (E,N)) 9 | ;; (i+1, S, (E,N)) -> (i, S, E) 10 | ;; (0, S, (E_1 (M, E_2))) -> (M, S, E_2) 11 | ;;To evaluate an application M N, the K-machine builds a closure made of the argument N 12 | ;;and the current environment E in the stack and proceeds with the reduction of the function 13 | ;;M. This is the first characteristic of the K-machine: a closure is built in constant time and includes the complete current environment. 14 | ;;The evaluation of a λ-abstraction places the argument (the stack’s top element) in the environment and proceeds with the body of the function. This is the second and more important characteristic of the K-machine: it strives not to build closures for functions. Other 15 | ;;abstract machines return functions as closures before applying them. 16 | ;;The evaluation of a variable i amounts to following i links to find the corresponding closure in the environment. The closure’s components become the current code and environment. 17 | ;;; 18 | 19 | ;((-> (a b (** + a b))) 5 6) 20 | ( 21 | (,CLOSURE ((,STOP))) 22 | (,CLOSURE ( 23 | (,GRAB a) 24 | (,GRAB b) 25 | (,PMARK) 26 | (,CLOSURE ((,PRIMITIVE +) (,CONTINUE))) 27 | (,ACCESS a) 28 | (,ACCESS b) 29 | (,CONTINUE))) 30 | (,DEFINE +) 31 | (,CLOSURE ((,CONSTANT 5) (,CONTINUE))) 32 | (,CLOSURE ((,CONSTANT 6) (,CONTINUE))) 33 | (,ACCESS +) 34 | (,CONTINUE) 35 | ) 36 | 37 | 38 | ;( 39 | ; (:= (+ a b) (** + a b)) 40 | ; (:= (x) 7) 41 | ; (+ x 6) 42 | ;) 43 | ( 44 | (,CLOSURE ((,STOP))) 45 | (,CLOSURE ( 46 | (,GRAB a) 47 | (,GRAB b) 48 | (,PMARK) 49 | (,CLOSURE ((,PRIMITIVE +) (,CONTINUE))) 50 | (,ACCESS a) 51 | (,ACCESS b) 52 | (,CONTINUE))) 53 | (,DEFINE +) 54 | (,CLOSURE ((,CONSTANT 7) (,CONTINUE))) 55 | (,DEFINE x) 56 | (,CLOSURE ((,ACCESS x) (,CONTINUE))) 57 | (,CLOSURE ((,CONSTANT 6) (,CONTINUE))) 58 | (,ACCESS +) 59 | (,CONTINUE) 60 | ) 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | x, y, z ∈ Var 69 | M, N ∈ Exp 70 | Exp := x | (M N) | λx.M 71 | 72 | 73 | Krivine: State -> State 74 | State = Clos * Stack 75 | Env = Var -> Clos 76 | Clos = Exp * Env 77 | Stack = [Clos] 78 | 79 | 80 | VAR Rule 81 | -------- 82 | 83 | (defliteral (Clos x y) 84 | {x y}) 85 | 86 | (define (Krivine closure stack) 87 | (case (closure stack) 88 | [({x Env}, Stack) 89 | (Krivine (get Env x) Stack)] 90 | 91 | [({(M N) Env}, Stack) 92 | (Krivine {M Env} (cons {N Env} Stack))] 93 | 94 | [({(^ x M) Env} (c . Stack)) 95 | (Krivine {M (cons (x . c) Env)} Stack)])) 96 | -------------------------------------------------------------------------------- /examples/Y-combinator.nadeko: -------------------------------------------------------------------------------- 1 | (-> (^ f (cons 1 (zipWith f + (cdr f)) -cons 1)) 2 | -> Y 3 | -> (take 10) 4 | -> reverse 5 | <- (fold (compose (compose ++ (++ ",")) num->str) "")) 6 | -------------------------------------------------------------------------------- /examples/coffee-cup.carrot: -------------------------------------------------------------------------------- 1 | (synonym CupState (Option Number)) 2 | (= (cup Number CupState) x (some x)) 3 | (= (broken-cup CupState) none) 4 | 5 | (synonym CupEvent (Pair Keyword Number)) ;;;shame/// 6 | (= (fill Number CupEvent) x (pair :fill x)) 7 | (= (spill Number CupEvent) x (pair :spill x)) 8 | (= (drop-cup CupEvent) (pair :drop 0)) 9 | 10 | (= (next-cup-state CupEvent CupState CupState) 11 | ce cs 12 | (opt>>= cs 13 | (^ x (=? (fst ce) :fill (cup (+ x (snd ce))) 14 | (=? (fst ce) :spill (cup (- x (snd ce))) 15 | broken-cup))))) 16 | 17 | (= (example-cup-events (List CupEvent)) 18 | (-> nil 19 | -> (cons (spill 8)) 20 | -> (cons (fill 10)) 21 | ;; -> (cons drop-cup) 22 | -> (cons (spill 40)) 23 | <- (cons (fill 20)))) 24 | 25 | 26 | (= (example-main Number) 27 | (/> (foldl next-cup-state (cup 100) example-cup-events) 28 | (^ cs (none? cs (print 0 "The cup is broken") 29 | (print 0 (+++ "The cup has " (num->str (pull cs)) "ml of coffee")))))) 30 | -------------------------------------------------------------------------------- /examples/concatenative.nadeko: -------------------------------------------------------------------------------- 1 | 2 | ;;; this example no longer works 3 | 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Minori Yamashita 2013 7 | ;; Concatenative style 8 | ;; 9 | ;; inspired by factjor https://github.com/brandonbloom/factjor 10 | 11 | (= 18 | ( stk 19 | (number? => (cat (cons => stk)) 20 | (cat (=> stk))))) 21 | 22 | (= cat/two-arg op stk ;( a b -- c ) 23 | (cons (op (cadr stk) (car stk)) (cddr stk))) 24 | 25 | (= cat/+ (cat/two-arg +)) 26 | (= cat/- (cat/two-arg -)) 27 | (= cat/* (cat/two-arg *)) 28 | (= cat// (cat/two-arg /)) 29 | 30 | (= cat/read stk (cons (** read) stk)) 31 | (= cat/print stk (** print (car stk) (cdr stk))) 32 | 33 | ;;Stack manipulation words 34 | (= dup stk ;( a -- a a ) 35 | (cons (car stk) stk)) 36 | (= drop stk ;( a -- ) 37 | (cdr stk)) 38 | (= swap stk ;( a b -- b a) 39 | (cons (cadr stk) (cons (car stk) (cddr stk)))) 40 | (= over stk ;( a b -- a b a) 41 | (cons (car stk) (cons (cadr stk) (cons (car stk) (cddr stk))))) 42 | (= rot stk ;( a b c -- b c a) 43 | (cons (cadr stk) (cons (caddr stk) (cons (car stk) (cdddr stk))))) 44 | (= nip stk ;( a b -- b) 45 | (compose drop swap)) 46 | (= tuck stk ;( a b -- b a b) 47 | (compose over swap)) 48 | 49 | (= cat/run (cat nil)) 50 | 51 | ;example 52 | ;(car (cat/run 5 6 cat/+ 7 cat/+ 8 9 cat/+ cat/+ 'end)) ;=> 35 53 | 54 | ;(cat/run 5 10 (quote- 2 cat/+) dip 'end) 55 | -------------------------------------------------------------------------------- /examples/fact.nadeko: -------------------------------------------------------------------------------- 1 | (= (fact Number Number) 2 | n 3 | (=? n 0 1 4 | (* n (fact (- n 1))))) 5 | 6 | (fact 100) 7 | -------------------------------------------------------------------------------- /examples/prelude.nadeko: -------------------------------------------------------------------------------- 1 | ;;bool 2 | (synonym Bool (Fn a a a)) 3 | (synonym Map (lambda [a b] `(List (Pair ,a ,b)))) 4 | 5 | (= (true Bool) t e t) 6 | (= (false Bool) t e e) 7 | (= (not Bool Bool) 8 | bool (bool false true)) 9 | (= (if Bool a a a) bool bool) 10 | 11 | ;;function 12 | (= (comp (Fn b c) (Fn a b) a c) 13 | f g x (f (g x))) 14 | (= (compose (Fn b c) (Fn a b) a c) comp) 15 | (= (flip (Fn a b c) b a c) 16 | f x y (f y x)) 17 | 18 | (= (id a a) x x) 19 | (= (/> a (Fn a b) b) 20 | x f (f x)) 21 | (= (-> a (Fn b c) (Fn a b) c) 22 | x f g (f (g x))) 23 | (= (<- a a) x x) 24 | ;;e.g. (-> 2 -> (+ 1) -> (+ 4) -> (+ 3) <- (+ 6)) 25 | 26 | 27 | ;;tuple 28 | (=u (pair a b (Pair a b)) 29 | x y f (f x y)) 30 | (= (fst (Pair a b) a) t (t (^ x _ x))) 31 | (= (snd (Pair a b) b) t (t (^ _ y y))) 32 | 33 | ;;list 34 | (=u (cons a (List a) (List a)) 35 | x y f (f x y)) 36 | (=u (nil (List a)) 'nil) 37 | (= (car (List a) a) xs (xs (^ x _ x))) 38 | (= (cdr (List a) (List a)) xs (xs (^ _ xs xs))) 39 | (= (nil? (List a) Bool) xs (=? nil xs)) 40 | 41 | 42 | ;; option 43 | (=u (some a (Option a)) x x) 44 | (=u (none (Option a)) 'nil) 45 | (=u (some? (Option a) Bool) x (not (=? x 'nil))) 46 | (=u (none? (Option a) Bool) x (=? x 'nil)) 47 | (= (pull (Option a) a) x x) 48 | (= (opt>>= (Option a) (Fn a (Option a)) (Option a)) 49 | opt f (none? opt none (f (pull opt)))) 50 | 51 | 52 | ;;Y-combinator 53 | ;;(= (Y (Fn a a) a) x (x (Y x))) 54 | ;;(Y (^ f f)) ;now f refers to the function itself 55 | (= (Y (Fn a a) a) 56 | f ((^ x (f (x x))) (^ x (f (x x))))) 57 | 58 | ;;predicates -- ideally, we don't need these 59 | (= (string? _ Bool) _ false) 60 | (= (string? String Bool) _ true) 61 | (= (number? _ Bool) _ false) 62 | (= (number? Number Bool) _ true) 63 | (= (keyword? _ Bool) _ false) 64 | (= (keyword? Keyword Bool) _ true) 65 | (= (list? _ Bool) _ false) 66 | (= (list? (List a) Bool) _ true) 67 | 68 | ;;show -- example of a generic function 69 | (= (show String String) x x) 70 | (= (show Number String) num->str) 71 | (= (show Keyword String) x (++ ":" (kw->str x))) 72 | (= (show Symbol String) x (** symbol->string x)) 73 | (= (show (List Number) String) 74 | xs 75 | (nil? xs "[]" 76 | (+++ (show (car xs)) " : " (show (cdr xs))))) 77 | (= (show (Option String) String) 78 | x 79 | (show (pull x))) 80 | (= (show (Option Number) String) 81 | x 82 | (show (pull x))) 83 | (= (show (Map Number Number) String) 84 | xs 85 | (+++ "[ " (show-map-content xs) "]")) 86 | (= (show (Map Keyword String) String) 87 | xs 88 | (+++ "[ " (show-map-content xs) "]")) 89 | 90 | 91 | (= (show-map-content (Map Number Number) String) 92 | xs 93 | (nil? xs "" 94 | (+++ (+++ "(" (+++ (show (fst (car xs))) " . " (show (snd (car xs)))) ")") 95 | " " 96 | (show-map-content (cdr xs))))) 97 | 98 | (= (show-map-content (Map Keyword String) String) 99 | xs 100 | (nil? xs "" 101 | (+++ (+++ "(" (+++ (show (fst (car xs))) " . " (show (snd (car xs)))) ")") 102 | " " 103 | (show-map-content (cdr xs))))) 104 | 105 | 106 | (= (+++ String String String String) s1 s2 s3 107 | (++ (++ s1 s2) s3)) 108 | 109 | ;;primitive wrapper 110 | (= (=? a a Bool) 111 | x y (** c-equal? x y)) 112 | (= (< Number Number Bool) 113 | x y (** c-< x y)) 114 | (= (> Number Number Bool) 115 | x y (** c-> x y)) 116 | (= (<= Number Number Bool) 117 | x y (** c-<= x y)) 118 | (= (>= Number Number Bool) 119 | x y (** c->= x y)) 120 | (= (+ Number Number Number) 121 | x y (** c-+ x y)) 122 | (= (- Number Number Number) 123 | x y (** c-- x y)) 124 | (= (* Number Number Number) 125 | x y (** c-* x y)) 126 | (= (/ Number Number Number) 127 | x y (** c-/ x y)) 128 | (= (% Number Number Number) 129 | x y (** c-mod x y)) 130 | (= (++ String String String) 131 | x y (** c-string-append x y)) 132 | (= (num->str Number String) 133 | x (** number->string x)) 134 | (= (kw->str Keyword String) 135 | x (** keyword->string x)) 136 | 137 | 138 | ;;; I/O 139 | (synonym Time Number) 140 | 141 | (= (print Time String Time) 142 | time str (** timed-print time str)) 143 | (= (read Time String) t 144 | (** read- t)) 145 | 146 | 147 | ;;help 148 | (= (help String) 149 | " 150 | 151 | | SYNTAX 152 | | ------ 153 | | ;; declare the type as an alias of 154 | | (synonym ) 155 | | 156 | | ;; define a generic function 157 | | (= ( ... ) 158 | | ... 159 | | ) 160 | | 161 | | ;; define a constructor for 162 | | (=u ( ... ) 163 | | ... 164 | | ) 165 | | 166 | | ;; lambda expression 167 | | (^ ... ) 168 | | 169 | | ;; function application 170 | | ( ...) 171 | | 172 | | ;; literals 173 | | \\\"string\\\" 123456 'symbol :keyword 174 | | 175 | | FEATURE 176 | | ------- 177 | | * Purely functional 178 | | * Default lazy evaluation 179 | | * Default currying 180 | | * Static type checking 181 | | * Statically resolved multimethod 182 | | * Timed I/O 183 | | 184 | | REPL 185 | | ---- 186 | | ^C -- Exit 187 | | help -- See this help 188 | | -- See the usage of the function (through its type) 189 | 190 | ") 191 | 192 | (= (language String) 193 | "Carrot") 194 | 195 | (= (version String) 196 | "2.2.0") 197 | 198 | (= (code-name String) 199 | "Netherland Dwarf") 200 | 201 | (= (info (Map Keyword String)) 202 | (cons (pair :language language) 203 | (cons (pair :version version) 204 | (cons (pair :code-name code-name) nil)))) 205 | -------------------------------------------------------------------------------- /examples/primes.nadeko: -------------------------------------------------------------------------------- 1 | (= (inf-int Number (List Number)) 2 | n (cons n (inf-int (+ n 1)))) 3 | 4 | (= (primes (List Number)) 5 | (sieve (inf-int 2))) 6 | 7 | (= (sieve (List Number)) 8 | ps 9 | (cons (car ps) 10 | (-> (cdr ps) 11 | -> (remove (^ x (=? (% x p) 0))) 12 | <- sieve))) 13 | -------------------------------------------------------------------------------- /examples/srfi-1.nadeko: -------------------------------------------------------------------------------- 1 | ;;;; list functions ;;;; 2 | 3 | ;;;; 4 | ;; Certain portions of this document -- the specific, marked segments of text describing the R5RS procedures -- were adapted with permission from the R5RS report. 5 | ;; All other text is copyright (C) Olin Shivers (1998, 1999). All Rights Reserved. 6 | ;; Permission is hereby granted, free of charge, to any? person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 7 | ;; The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 8 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | ;;;; 10 | 11 | ;;; Constructors ;;; 12 | 13 | (= (make-integers-from Number (List Number)) n 14 | (cons n (make-integers-from (+ n 1)))) 15 | (= (integers (List Number)) 16 | (make-integers-from 0)) 17 | 18 | 19 | 20 | 21 | ;;; Selectors ;;; 22 | 23 | (= (list-ref Number (List a) (Option a)) i xs 24 | (nil? xs none 25 | (=? i 0 (some (car xs)) 26 | (list-ref (- i 1) (cdr xs))))) 27 | 28 | 29 | (= (take Number (List a) (List a)) n xs 30 | (nil? xs nil 31 | (=? n 0 nil 32 | (cons (car xs) (take (- n 1) (cdr xs)))))) 33 | 34 | 35 | (= (drop Number (List a) (List a)) i xs 36 | (nil? xs nil 37 | (=? i 0 xs (drop (- i 1) (cdr xs))))) 38 | 39 | 40 | (= (take-right Number (List a) (List a)) i xs 41 | (drop (- (length xs) i) xs)) 42 | 43 | 44 | (= (drop-right Number (List a) (List a)) i xs 45 | (take (- (length xs) i) xs)) 46 | 47 | 48 | (= (split-at Number (List a) (Pair (List a) (List a))) i xs 49 | (pair (take i xs) (drop i xs))) 50 | 51 | 52 | (= (last (List a) a) xs 53 | (nil? (cdr xs) (car xs) (last (cdr xs)))) 54 | 55 | 56 | 57 | 58 | ;;; Miscellaneous ;;; 59 | 60 | (= (length (List a) Number) xs 61 | (nil? xs 0 (+ 1 (length (cdr xs))))) 62 | 63 | 64 | (= (append (List a) (List a) (List a)) xs1 xs2 65 | (nil? xs1 xs2 66 | (cons (car xs1) (append (cdr xs1) xs2)))) 67 | 68 | 69 | (= (reverse (List a) (List a)) xs 70 | (foldl cons nil xs)) 71 | 72 | 73 | (= (zip (List a) (List b) (List (Pair a b))) xs1 xs2 74 | (nil? xs1 nil 75 | (nil? xs2 nil 76 | (cons (pair (car xs1) (car xs2)) 77 | (zip (cdr xs1) (cdr xs2)))))) 78 | 79 | 80 | (= (zipWith (List a) (Fn a b c) (List b) (List c)) xs1 f xs2 81 | (nil? xs1 nil 82 | (nil? xs2 nil 83 | (cons (f (car xs1) (car xs2)) 84 | (zipWith (cdr xs1) f (cdr xs2)))))) 85 | 86 | 87 | ;;(= unzip xs (unzip- nil nil (reverse xs))) 88 | 89 | 90 | #|(= unzip- xs1 xs2 zipped 91 | (nil? zipped 92 | (pair xs1 xs2) 93 | (unzip- 94 | (cons (fst (car zipped)) xs1) 95 | (cons (snd (car zipped)) xs2) 96 | (cdr zipped))))|# 97 | 98 | 99 | (= (count1 (Fn a Bool) (List a) Number) pred xs 100 | (nil? xs 0 101 | (pred (car xs) (+ 1 (count1 pred (cdr xs))) 102 | (count1 pred (cdr xs))))) 103 | 104 | 105 | (= (count2 (Fn a b Bool) (List a) (List b) Number) 106 | pred xs1 xs2 107 | (nil? xs1 0 108 | (nil? xs2 0 109 | (pred (car xs1) (car xs2) (+ 1 (count2 pred (cdr xs1) (cdr xs2))) 110 | (count2 pred (cdr xs1) (cdr xs2)))))) 111 | 112 | 113 | 114 | 115 | ;;; Fold, unfold & map ;;; 116 | 117 | (= (foldl (Fn a b c) b (List a) c) f init xs 118 | (nil? xs init 119 | (foldl f (f (car xs) init) (cdr xs)))) 120 | 121 | 122 | (= (foldr (Fn a b c) b (List a) c) f init xs 123 | (nil? xs init 124 | (f (car xs) (foldr f init (cdr xs))))) 125 | 126 | 127 | #|(= unfold p f g seed 128 | (p seed nil 129 | (cons (f seed) (unfold p f g (g seed)))))|# 130 | 131 | 132 | ;(= unfold-right ) ;pending 133 | 134 | 135 | (= (map (Fn a b) (List a) (List b)) f xs 136 | (nil? xs nil (cons (f (car xs)) (map f (cdr xs))))) 137 | 138 | 139 | 140 | 141 | ;;; Filtering & partitioning ;;; 142 | 143 | (= (filter (Fn a Bool) (List a) (List a)) f xs 144 | (nil? xs nil 145 | (f (car xs) (cons (car xs) (filter f (cdr xs))) (filter f (cdr xs))))) 146 | 147 | 148 | ;;(= partition xs (partition- nil nil (reverse xs))) 149 | 150 | 151 | (= (remove (Fn a Bool) (List a) (List a)) f xs 152 | (nil? xs nil 153 | (f (car xs) (remove f (cdr xs)) (cons (car xs) (remove f (cdr xs)))))) 154 | 155 | 156 | 157 | 158 | ;;; Searching ;;; 159 | 160 | (= (find (Fn a Bool) (List a) (Option a)) pred xs 161 | (nil? xs none 162 | (pred (car xs) (some (car xs)) 163 | (find pred (cdr xs))))) 164 | 165 | 166 | (= (find-tail (Fn a Bool) (List a) (List a)) pred xs 167 | (nil? xs nil 168 | (pred (car xs) xs 169 | (find-tail pred (cdr xs))))) 170 | 171 | 172 | (= (take-while (Fn a Bool) (List a) (List a)) pred xs 173 | (nil? xs nil 174 | (pred (car xs) 175 | (cons (car xs) (take-while pred (cdr xs))) 176 | nil))) 177 | 178 | 179 | (= (drop-while (Fn a Bool) (List a) (List a)) pred xs 180 | (nil? xs nil 181 | (pred (car xs) 182 | (drop-while pred (cdr xs)) 183 | xs))) 184 | 185 | 186 | (= (any? (Fn a Bool) (List a) Bool) pred xs 187 | (nil? xs false 188 | (pred (car xs) true (any? pred (cdr xs))))) 189 | 190 | 191 | (= (every? (Fn a Bool) (List a) Bool) pred xs 192 | (nil? xs true 193 | (pred (car xs) (every? pred (cdr xs)) false))) 194 | 195 | 196 | (= (list-index (Fn a Bool) (List a) (Option Number)) pred xs 197 | (nil? xs none 198 | (pred (car xs) (some 0) 199 | (opt>>= (list-index pred (cdr xs)) 200 | (comp some (+ 1)))))) 201 | 202 | 203 | (= (member a (List a) (List a)) x xs 204 | (nil? xs nil 205 | (=? (car xs) x xs (member x (cdr xs))))) 206 | 207 | 208 | (= (delete a (List a) (List a)) x xs 209 | (nil? xs nil 210 | (=? (car xs) x 211 | (delete x (cdr xs)) 212 | (cons (car xs) (delete x (cdr xs)))))) 213 | 214 | 215 | (= (delete-duplicates (List a) (List a)) xs 216 | (nil? xs nil 217 | (cons (car xs) (delete-duplicates (delete (car xs) xs))))) 218 | 219 | 220 | 221 | 222 | ;;; Association lists ;;; 223 | 224 | (= (assq a (List (Pair a b)) (Option b)) key axs 225 | (nil? axs none 226 | (=? (fst (car axs)) key 227 | (some (snd (car axs))) 228 | (assq key (cdr axs))))) 229 | 230 | 231 | (= (acons a b (List (Pair a b)) (List (Pair a b))) 232 | key datum axs 233 | (cons (pair key datum) axs)) 234 | 235 | 236 | (= (alist-copy (List (Pair a b)) (List (Pair a b))) axs 237 | (nil? axs nil 238 | (cons (pair (fst (car axs)) (snd (car axs))) 239 | (alist-copy (cdr axs))))) 240 | 241 | 242 | (= (alist-delete a (List (Pair a b)) (List (Pair a b))) 243 | key axs 244 | (remove (comp (=? key) fst) axs)) 245 | 246 | ;;; predicate ;;; 247 | 248 | (= (list-eq? (List a) (List a) Bool) xs1 xs2 249 | (nil? xs1 (nil? xs2) 250 | (=? (car xs1) (car xs2) 251 | (list-eq? (cdr xs1) (cdr xs2)) 252 | false))) 253 | -------------------------------------------------------------------------------- /examples/tarai.nadeko: -------------------------------------------------------------------------------- 1 | (= (tarai Number Number Number Number) 2 | x y z 3 | (<= x y y 4 | (tarai (tarai (- x 1) y z) 5 | (tarai (- y 1) z x) 6 | (tarai (- z 1) x y)))) 7 | 8 | ;(tarai 18 9 0) 9 | -------------------------------------------------------------------------------- /examples/test.nadeko: -------------------------------------------------------------------------------- 1 | (=u (cons a (List a) (List a)) 2 | x y f (f x y)) 3 | (=u (nil (List a)) 'nil) 4 | (= (car (List a) a) xs (xs (^ x _ x))) 5 | (= (cdr (List a) (List a)) xs (xs (^ _ xs xs))) 6 | (= (nil? (List a) Bool) xs (=? nil xs)) 7 | 8 | (= (+++ String String String String) s1 s2 s3 9 | (++ (++ s1 s2) s3)) 10 | (= (++ String String String) 11 | x y (** ++ x y)) 12 | (= (=? a a Bool) 13 | x y (** =? x y)) 14 | 15 | (= (show String String) x x) 16 | (= (show Number String) x (** num->str x)) 17 | (= (show Keyword String) x (** kw->str x)) 18 | (= (show Symbol String) x (** symbol->string x)) 19 | (= (show (List a) String) 20 | xs 21 | (nil? xs "[]" 22 | (+++ (show (car xs)) " : " (show (cdr xs))))) 23 | -------------------------------------------------------------------------------- /install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | version="2.2.0" 4 | 5 | echo "Installing Carrot..." 6 | 7 | # cp bin/carrot-repl.scm /usr/local/bin/carrot-repl 8 | cp bin/carrot-read.scm /usr/local/bin/carrot-read 9 | cp bin/carrot-type.scm /usr/local/bin/carrot-type 10 | cp bin/carrot-compile.scm /usr/local/bin/carrot-compile 11 | cp bin/carrot-vm.scm /usr/local/bin/carrot-vm 12 | 13 | chmod u+x /usr/local/bin/carrot-* 14 | 15 | mkdir /usr/local/share/Carrot 16 | mkdir /usr/local/share/Carrot/$version 17 | mkdir /usr/local/share/Carrot/$version/lib 18 | mkdir /usr/local/share/Carrot/$version/compilers 19 | mkdir /usr/local/share/Carrot/$version/examples 20 | 21 | cp lib/* /usr/local/share/Carrot/$version/lib/ 22 | cp compilers/* /usr/local/share/Carrot/$version/compilers/ 23 | cp examples/* /usr/local/share/Carrot/$version/examples/ 24 | 25 | echo "Installation complete." 26 | echo "" 27 | echo "Example Usage:" 28 | #echo "carrot-repl" 29 | echo " cat foo.carrot bar.carrot | carrot-read | carrot-compile to-js > main.js" 30 | echo " cat foo.carrot | carrot-read | carrot-compile to-carrot-vm | carrot-vm" 31 | echo "" 32 | echo "Enjoy!" 33 | echo "" 34 | -------------------------------------------------------------------------------- /lib/CarrotVM.scm: -------------------------------------------------------------------------------- 1 | ;;;; Modified Krivine's Machine in Scheme ;;;; 2 | ;;; 2012 Minori Yamashita ;;add your name here 3 | ;;; 4 | ;;; reference: 5 | ;;; http://pauillac.inria.fr/~xleroy/talks/zam-kazam05.pdf 6 | ;;; http://pop-art.inrialpes.fr/~fradet/PDFs/HOSC07.pdf 7 | ;;; Improving the Lazy Krivine Machine 8 | 9 | ;;; Notes ;;; 10 | ;; CLOSURE creates thunks that packs the continuation and environment together. 11 | ;; To create closures(function objects), CLOSURE the GRAB and expression followed by CONTINUE 12 | 13 | 14 | (define-module CarrotVM 15 | (export CarrotVM) 16 | (use srfi-1) 17 | (use srfi-9) 18 | (use DataTypes) 19 | (use util.match) 20 | (use Util) 21 | 22 | ;;; Helpers ;;; 23 | 24 | (define (lookup-fail? x) 25 | (eq? x 'lookup-fail)) 26 | 27 | 28 | ;;weak head normal form? 29 | (define (clos-is-value? closure) 30 | (let ([inst (clos-expr closure)]) 31 | (or (is-a? inst ) 32 | (is-a? inst )))) 33 | 34 | (define-record-type mark 35 | (marker loc) 36 | marker? 37 | (loc marker-loc)) 38 | 39 | 40 | (define heap-size-default 200) 41 | (define *heap-size-limit* heap-size-default) 42 | 43 | (define *global-env* (make-hash-table 'eq?)) 44 | 45 | (define (CarrotVM exprs-ht main-name) 46 | (let* ([main (hash-table-get exprs-ht main-name #f)]) 47 | (if main 48 | (begin 49 | ;;(print-code "closure: ~S" main) 50 | (set! *global-env* exprs-ht) 51 | (CarrotVM* main '() (make-hash-table 'eq?) '())) 52 | '()))) 53 | 54 | 55 | (define *step* 0) 56 | 57 | ;;; Krivine's Machine ;;; 58 | (define (CarrotVM* closure stack heap nprocs) 59 | 60 | (set! *step* (+ *step* 1)) 61 | 62 | (let* ([inst (clos-expr closure)] 63 | [env (clos-env closure)]) 64 | 65 | ;;(print inst) 66 | ;;(print-code "env : ~S" env) 67 | ;;(print-code "stak: ~S" (map (^m (ref heap (marker-loc m))) stack)) 68 | ;;(print-code "nprc: ~S" nprocs) 69 | ;;(print-code "heap: ~S" (hash-table->alist heap)) 70 | ;;(newline) 71 | ;;(sys-sleep 1) 72 | 73 | (vm-step inst env stack heap nprocs))) 74 | 75 | 76 | (define-method vm-step [(refi ) env stack heap nprocs] 77 | (let* ([mark (assoc-ref env (var refi))] 78 | [clos (ref heap (marker-loc mark))]) 79 | (if (clos-is-value? clos) 80 | ;;VAR2 + UPDATE done at the same time 81 | (begin 82 | (CarrotVM* clos stack (hash-table-put-! heap (marker-loc mark) clos) nprocs)) 83 | ;;VAR1 84 | (CarrotVM* clos stack heap nprocs)))) 85 | 86 | ;; if it were just var2 then (Krivine- clos (cons mark stack)) 87 | 88 | 89 | (define-method vm-step [(refgi ) env stack heap nprocs] 90 | (let1 clos (ref *global-env* (var refgi)) 91 | (CarrotVM* clos stack heap nprocs))) 92 | 93 | 94 | ;;CALL 95 | (define-method vm-step [(lambdai ) env stack heap nprocs] 96 | (if (null? stack) 97 | (CarrotVM* (make 98 | :expr (make :val lambdai) 99 | :env '()) 100 | stack heap nprocs) ;;whnf 101 | (let* ([param (parameter lambdai)] 102 | [body (expression lambdai)] 103 | [mark (car stack)]) 104 | (CarrotVM* (make :expr body :env (acons param mark env)) 105 | (cdr stack) 106 | heap 107 | nprocs)))) 108 | 109 | 110 | (define (make-crt-bool b) 111 | (make 112 | :parameter 'x 113 | :expression (make 114 | :parameter 'y 115 | :expression (make :var (if b 'x 'y))))) 116 | 117 | ;;Weak Head Normal 118 | (define-method vm-step [(atomi ) env stack heap nprocs] 119 | (if (null? nprocs) ;;no pending procedure call 120 | (val atomi) 121 | 122 | ;;TODO: break this down 123 | 124 | ;;native procedure call 125 | (let* ([val (val atomi)] 126 | [v-clos (make 127 | :expr (make :val val) :env '())] 128 | [x (car nprocs)] 129 | [proc (car x)] 130 | [m (cadr x)] 131 | [stk (cddr x)] 132 | [res (proc val)]) 133 | 134 | (if (closure? res) 135 | (CarrotVM* (make 136 | :expr (make :procedure res) :env '()) 137 | (append stk stack) 138 | (hash-table-put-! heap (marker-loc m) v-clos) 139 | (cdr nprocs)) 140 | (let* ([-expr (cond 141 | [(boolean? res) (make-crt-bool res)] 142 | [else (make :val res)])] 143 | [clos (make :expr -expr :env '())]) 144 | (CarrotVM* clos 145 | (append stk stack) 146 | (if (boolean? res) heap 147 | (hash-table-put-! heap (marker-loc m) v-clos)) 148 | (cdr nprocs))))))) 149 | 150 | 151 | ;;(native proc) 152 | ;;evacuate the stack, enter first closure 153 | (define-method vm-step ([nativei ] env stack heap nprocs) 154 | (let* ([m (car stack)] 155 | [proc (eval (procedure nativei) (find-module 'nadeko-sandbox))]) 156 | (CarrotVM* (ref heap (marker-loc m)) 157 | '() 158 | (collect-garbage 159 | heap 160 | (append env (map (^m (cons (gensym "tmp") m)) 161 | (append stack 162 | (apply append (map cdr nprocs)))))) 163 | (cons (cons proc stack) nprocs)))) 164 | 165 | 166 | (define-method vm-step [(appi ) env stack heap nprocs] 167 | (let* ([M (operator appi)] 168 | [N (operand appi)] 169 | [loc (gensym)] 170 | [mark (marker loc)]) 171 | (CarrotVM* (make :expr M :env env) 172 | (cons mark stack) 173 | (hash-table-put-! heap loc (make :expr N :env env)) 174 | nprocs))) 175 | 176 | 177 | ;;(APPVAR M (REF x)) 178 | (define-method vm-step [(appvi ) env stack heap nprocs] 179 | (let* ([M (operator appvi)] 180 | [x (var (operand appvi))] 181 | [mark (assoc-ref env x)]) 182 | (CarrotVM* (make :expr M :env env) 183 | (cons mark stack) heap nprocs))) 184 | 185 | 186 | 187 | ;; Copy GC 188 | ;; heap :: {sym (CLOS expr ((sym . mark)))} 189 | (define (collect-garbage heap env) 190 | ;;(format #t ".") (flush) 191 | (if (> (hash-table-num-entries heap) *heap-size-limit*) 192 | (begin 193 | (hash-table-put! heap 'tmp (make :expr '() :env env)) ;;hack 194 | (let ([h (hash-table-fold 195 | heap 196 | (fn [k clos acc] 197 | (for-each 198 | (fn [x] 199 | (let ([loc (marker-loc (cdr x))]) 200 | (hash-table-put! acc loc (hash-table-get heap loc)))) 201 | (clos-env clos)) 202 | acc) 203 | (make-hash-table 'eq?))]) 204 | (set! *heap-size-limit* (max heap-size-default (+ 50 (hash-table-num-entries h)))) 205 | h)) 206 | heap))) 207 | 208 | 209 | (define-module nadeko-sandbox 210 | (export-all) 211 | (use Util) 212 | 213 | (define (c2 f) 214 | (fn [x] (fn [y] (f x y)))) 215 | 216 | (define c-equal? (c2 equal?)) 217 | (define c-< (c2 <)) 218 | (define c-> (c2 >)) 219 | (define c-<= (c2 <=)) 220 | (define c->= (c2 >=)) 221 | (define c-+ (c2 +)) 222 | (define c-- (c2 -)) 223 | (define c-* (c2 *)) 224 | (define c-/ (c2 /)) 225 | (define c-mod (c2 mod)) 226 | (define c-string-append (c2 string-append)) 227 | (define (read- x) (read)) 228 | 229 | (define (timed-print time) 230 | (fn [x] 231 | (print x) 232 | (+ time 1)))) 233 | -------------------------------------------------------------------------------- /lib/Check.scm: -------------------------------------------------------------------------------- 1 | ;;;; Check.scm 2 | ;;;; 2014 Minori Yamashita 3 | ;;;; Find type errors 4 | 5 | (add-load-path "../lib/" :relative) 6 | 7 | (define-module Check 8 | (export type-check) 9 | (use srfi-1) 10 | (use srfi-9) 11 | (use Util) 12 | (use util.match) 13 | (use DataTypes) 14 | 15 | (define *exprs-ht* (make-hash-table 'eq?)) 16 | (define *types-ht* (make-hash-table 'eq?)) 17 | (define *genmap-ht* (make-hash-table 'eq?)) 18 | (define *checking* (atom '(main))) 19 | 20 | ;; type-check ({exprs} . {types}) -> (U #f) 21 | (define (type-check exprs*types*genmap) 22 | (set! *exprs-ht* (fst exprs*types*genmap)) 23 | (set! *types-ht* (snd exprs*types*genmap)) 24 | (set! *genmap-ht* (thd exprs*types*genmap)) 25 | (reset! *checking* '(main)) 26 | (let* ([main-name (get-main-name (caddr exprs*types*genmap))] 27 | [main-expr (hash-table-get *exprs-ht* main-name #f)]) 28 | (if main-expr 29 | (check-fn main-expr (ref *types-ht* main-name) '()) 30 | (make :type 'Unit)))) 31 | 32 | 33 | (define (print-exc exc) 34 | (format #t "~A: ~A\n" (deref *checking*) (ref exc 'message))) 35 | 36 | ;; (^ prams... expr) * * {types} -> (U #f) 37 | (define-method check-fn ((expr ) (type ) env) 38 | (let* ([params (butlast (cdr expr))] 39 | [expr (last expr)] 40 | [in-ts (butlast (get-type type))] 41 | [out-t (last (get-type type))]) 42 | (if (and (require-check? type) (not (check-prevented? type))) 43 | (begin ;; (exc [else (print-exc exc) #f]) 44 | (set! (check-prevented? type) #t) ;;prevent loop 45 | (let1 expr-t (p (type-of expr (append (zip params in-ts) env))) 46 | (unify out-t expr-t) 47 | (set! (check-prevented? type) #f) 48 | expr-t)) 49 | out-t))) 50 | 51 | ;; expr * * {types} -> (U #f) 52 | (define-method check-fn (expr (type ) env) 53 | (if (and (require-check? type) (not (check-prevented? type))) 54 | (begin ;; (exc [else (print-exc exc) #f]) 55 | (set! (check-prevented? type) #t) ;;prevent loop 56 | (let1 expr-t (type-of expr env) 57 | (unify type expr-t) 58 | (set! (check-prevented? type) #f) 59 | expr-t)) 60 | type)) 61 | 62 | 63 | (define (gen-type-var) 64 | (make :type (gensym "t_var"))) 65 | 66 | ;; expr * {types} -> 67 | (define-method type-of ((_ ) _) (make :type 'String)) 68 | (define-method type-of ((_ ) _) (make :type 'Number)) 69 | (define-method type-of ((_ ) _) (make :type 'Char)) 70 | (define-method type-of ((_ ) _) (make :type 'Keyword)) 71 | (define-method type-of ((s ) env) 72 | (swap! *checking* (cut cons s <>)) 73 | (let1 t (assoc s env) 74 | (if t (cadr t) 75 | (let* ([t (ref *types-ht* s)] 76 | [ex (hash-table-get *exprs-ht* s #f)]) 77 | (when (and ex (not (check-fn ex t env))) 78 | (raise-error/message 79 | (format "Declared return type of `~S` doesn't agree with actual value." s))) 80 | t)))) 81 | (define-method type-of ((xs ) env) 82 | (cond [(quote-expr? xs) (make :type 'Symbol)] 83 | [(lambda-expr? xs) 84 | (type-of-lambda xs env)] ;;stub 85 | [(native-expr? xs) (gen-type-var)] 86 | [else (type-of-app (type-of (car xs) env) 87 | (map (cut type-of <> env) (cdr xs)))])) 88 | 89 | 90 | ;; (^ params... expr) -> 91 | (define (type-of-lambda xs env) 92 | (let* ([paramts (cons (gen-type-var) (map (^x (gen-type-var)) (butlast (cdr xs))))] 93 | [expr-t (check-fn xs 94 | (make :type paramts :checked #t) 95 | env)]) 96 | (unless expr-t (raise-error/message "lambda")) 97 | (make :type (append paramts (list expr-t))))) 98 | 99 | 100 | ;; * [] -> 101 | (define-method type-of-app ((t ) ts) 102 | (raise-error/message (format "Can not apply a ~S to ~S" 103 | (get-type t) (map get-type ts)))) 104 | (define-method type-of-app ((t ) ts) t) 105 | (define-method type-of-app ((t ) ts) t) 106 | (define-method type-of-app ((t ) (_ )) t) 107 | (define-method type-of-app ((t ) ts) 108 | (let* ([ft (get-type t)] 109 | [binding (unify (car ft) (car ts))] 110 | [rest-ft (fold (fn [b ft-] 111 | (replace-type-var ft- (car b) (cdr b))) 112 | (cdr ft) 113 | binding)]) 114 | (cond [(and (= 1 (length rest-ft)) 115 | (is-a? (car rest-ft) )) 116 | (type-of-app (car rest-ft) (cdr ts))] 117 | [(and (= 1 (length rest-ft))) 118 | (car rest-ft)] 119 | [else 120 | (type-of-app (make :type rest-ft) (cdr ts))]))) 121 | 122 | 123 | (define (replace-type-var ft var t) 124 | (if (null? ft) '() 125 | (cons (cond [(equal? (car ft) var) t] 126 | [(is-a? (car ft) ) 127 | (make 128 | :name (type-name (car ft)) 129 | :type (replace-type-var (get-type (car ft)) var t))] 130 | [(is-a? (car ft) ) 131 | (make :type (replace-type-var 132 | (get-type (car ft)) var t))] 133 | [else (car ft)]) 134 | (replace-type-var (cdr ft) var t)))) 135 | 136 | 137 | ;;a Number -> ((a Number)) 138 | (define-method unify ((t1 ) (t2 )) 139 | (if (equal? t1 t2) 140 | (list (cons (gen-type-var) t2)) 141 | (raise-error/message (format "Primitive type contradiction: ~S -><- ~S" t1 t2)))) 142 | 143 | (define-method unify ((t1 ) (t2 )) 144 | (let ([t1- (get-type t1)] 145 | [t2- (get-type t2)]) 146 | (if (eq? (type-name t1) (type-name t2)) 147 | (apply append (map (fn [tx ty] (unify tx ty)) (get-type t1) (get-type t2))) 148 | (raise-error/message 149 | (format "Composite type container contradiction: ~S -><- ~S" 150 | (type-name t1) (type-name t2)))))) 151 | 152 | (define-method unify ((t1 ) (t2 )) 153 | (list (cons t1 t2))) 154 | 155 | (define-method unify ((t1 ) (t2 )) 156 | (list (cons t2 t1))) 157 | 158 | (define-method unify ((t1 ) (t2 )) 159 | (unify (make :name 'Fn :type (get-type t1)) 160 | (make :name 'Fn :type (get-type t2)))) 161 | 162 | (define-method unify ((t1 ) (t2 )) 163 | (raise-error/message (format "Type contradiction: ~S -><- ~S" t1 t2)))) 164 | -------------------------------------------------------------------------------- /lib/DataTypes.scm: -------------------------------------------------------------------------------- 1 | ;;;; datatypes.scm 2 | ;;;; 2014 Minori Yamashita 3 | ;;;; define data structures used throughout the system 4 | 5 | 6 | (define-module DataTypes 7 | (export-all) 8 | (use srfi-9) 9 | (use Util) 10 | 11 | 12 | (define-class () ()) 13 | 14 | (define-method write-object [(x ) out] 15 | (let* ([class (class-of x)] 16 | [serializable-slots (filter (^s (get-keyword :init-keyword (cdr s) #f)) 17 | (class-slots class))] 18 | [slot-names (map car serializable-slots)] 19 | [init-kws (filter-map (^s (get-keyword :init-keyword (cdr s))) 20 | serializable-slots)]) 21 | (apply (pa$ format out (str "#,(crt-serializable ~A " 22 | (apply str (separate " ~A " init-kws)) 23 | " ~A)") 24 | (class-name class)) 25 | (map (compose show (cut slot-ref x <>)) slot-names)))) 26 | 27 | (define-reader-ctor 'crt-serializable 28 | (lambda [class . xs] 29 | (apply (pa$ make (eval class (interaction-environment))) xs))) 30 | 31 | 32 | ;;;; Carrot Types 33 | 34 | (define-class () 35 | ((typ :accessor get-type 36 | :init-keyword :type) 37 | (checked :init-value #f 38 | :accessor require-check? 39 | :init-keyword :checked) 40 | (check-prevented :init-value #f 41 | :accessor check-prevented?))) 42 | 43 | (define-class () ()) 44 | 45 | (define-class () ()) 46 | 47 | (define-class () ()) 48 | 49 | (define-class () 50 | ((name :accessor type-name 51 | :init-keyword :name))) 52 | 53 | (define-method object-equal? ((x ) (y )) 54 | (equal? (get-type x) (get-type y))) 55 | 56 | (define-method object-equal? ((x ) (y )) 57 | (and (equal? (type-name x) (type-name y)) 58 | (equal? (get-type x) (get-type y)))) 59 | 60 | 61 | (define-method type->data ((t )) 62 | (cons 'Fn (map type->data (get-type t)))) 63 | (define-method type->data ((t )) 64 | (let1 s (get-type t) 65 | (if (null? s) 66 | (type-name t) 67 | (cons (type-name t) (map type->data (get-type t)))))) 68 | (define-method type->data ((t )) 69 | (get-type t)) 70 | (define-method type->data (t) t) 71 | 72 | 73 | 74 | ;;;; CarrotVM closure 75 | 76 | (define-class () 77 | ((expr :accessor clos-expr 78 | :init-keyword :expr) 79 | (env :accessor clos-env 80 | :init-keyword :env) 81 | (name :init-value 'anonymous 82 | :accessor name 83 | :init-keyword :name))) 84 | 85 | 86 | ;;;; CarrotVM instructions 87 | (define-class () ()) 88 | 89 | (define-class () 90 | ((var :init-keyword :var 91 | :accessor var))) 92 | 93 | (define-class () ()) 94 | 95 | (define-class () 96 | ((val :init-keyword :val 97 | :accessor val))) 98 | 99 | (define-class () 100 | ((param :init-keyword :parameter 101 | :accessor parameter) 102 | (expr :init-keyword :expression 103 | :accessor expression))) 104 | 105 | (define-class () 106 | ((proc :init-keyword :procedure 107 | :accessor procedure))) 108 | 109 | (define-class () 110 | ((operator :init-keyword :operator 111 | :accessor operator) 112 | (operand :init-keyword :operand 113 | :accessor operand))) 114 | 115 | (define-class () ()) 116 | 117 | 118 | ;;;;Tuples 119 | 120 | (define-class () 121 | ((x :init-keyword :fst :accessor fst) 122 | (y :init-keyword :snd :accessor snd))) 123 | 124 | (define (pair x y) 125 | (make :fst x :snd y)) 126 | 127 | (define-class () 128 | ((x :init-keyword :fst :accessor fst) 129 | (y :init-keyword :snd :accessor snd) 130 | (z :init-keyword :thd :accessor thd))) 131 | 132 | (define (triple x y z) 133 | (make :fst x :snd y :thd z)) 134 | 135 | 136 | 137 | ;;;; Hashtables 138 | 139 | (define (write-hash-table ht) 140 | (format "#,(hash-table ~S)" (hash-table->alist ht))) 141 | 142 | (define-reader-ctor 'hash-table alist->hash-table)) 143 | -------------------------------------------------------------------------------- /lib/Read.scm: -------------------------------------------------------------------------------- 1 | ;;;; read.scm 2 | ;;;; 2014 Minori Yamashita 3 | ;;;; transform a list of s-expressions into a tuple of three hashtables: 4 | ;;;; one mapping unique name to expression, 5 | ;;;; one mapping unique name to type, 6 | ;;;; one mapping generic name to unique names 7 | 8 | (add-load-path "../lib/" :relative) 9 | 10 | (define-module Read 11 | (export read-s-exprs read-s-exprs*) 12 | (use srfi-1) 13 | (use DataTypes) 14 | (use Util) 15 | 16 | 17 | (define *synonyms* (make-hash-table 'eq?)) ;;fmm 18 | 19 | (define (proper-def? def) 20 | (and (pair? def) (case (car def) [(= =u) #t] [else #f]))) 21 | 22 | (define (synonym-definition? x) 23 | (and (pair? x) (eq? (car x) 'synonym))) 24 | 25 | (define (non-definition? x) 26 | (synonym-definition? x)) 27 | 28 | (define (type-var? x) 29 | (char-upper-case? (string-ref (symbol->string x) 0))) 30 | 31 | 32 | ;;;; read-s-exprs :: [S-expr] -> ({uniq-name => expr} 33 | ;;;; {uniq-name => type} 34 | ;;;; {generic-name => [uniqname]}) 35 | (define (read-s-exprs program exprs*types*genmap) 36 | (read-s-exprs* program 37 | (fst exprs*types*genmap) 38 | (snd exprs*types*genmap) 39 | (thd exprs*types*genmap))) 40 | 41 | (define (read-s-exprs* program exprs-ht types-ht genmap-ht) 42 | (cond [(null? program) 43 | (triple exprs-ht types-ht genmap-ht)] 44 | 45 | [(synonym-definition? (car program)) 46 | (register-synonym! (car program) *synonyms*) 47 | (read-s-exprs* (cdr program) exprs-ht types-ht genmap-ht)] 48 | 49 | [else 50 | (let* ([def (car program)] 51 | [def (if (proper-def? def) def `(= (main a) ,def))] 52 | [generic-name (caadr def)] 53 | [uniqn (length (hash-table-get genmap-ht generic-name '()))] 54 | [uniq-name (if (= uniqn 0) ;;use the symbol unchanged 55 | generic-name 56 | (string->symbol 57 | (string-append 58 | (symbol->string generic-name) 59 | (number->string (inc uniqn)))))]) 60 | (read-s-exprs* (cdr program) 61 | (register-function uniq-name def exprs-ht) 62 | (register-type uniq-name def types-ht) 63 | (ht-put-cons genmap-ht generic-name uniq-name)))])) 64 | 65 | 66 | ;; name * def-statement * {exprs} -> {exprs} 67 | (define (register-function uniq-name def exprs-ht) 68 | (let* ([params (butlast (cddr def))] 69 | [body (last def)]) 70 | (if (null? params) 71 | (hash-table-put-! exprs-ht uniq-name body) 72 | (hash-table-put-! exprs-ht uniq-name `(^ ,@params ,body))))) 73 | 74 | ;; name * def-statement * {types} -> {types} 75 | (define (register-type uniq-name def types-ht) 76 | (let ([type (cdadr def)]) 77 | (if (= 1 (length type)) 78 | (hash-table-put-! types-ht uniq-name 79 | (make-unknown-crt-type (car type) 80 | (not (eq? (car def) '=u)))) 81 | (hash-table-put-! types-ht uniq-name 82 | (make 83 | :type (map (cut make-unknown-crt-type <> #f) type) 84 | :checked (not (eq? (car def) '=u))))))) 85 | 86 | ;; synonym-statement * {synonyms} -> () 87 | (define (register-synonym! synonym synonyms-ht) 88 | (let* ([alias (cadr synonym)] 89 | [actual (caddr synonym)] 90 | [unique-actual (car (uniquify-type-var actual '()))]) 91 | (hash-table-put! synonyms-ht alias unique-actual))) 92 | 93 | 94 | ;; (Container a b) -> (Container tvar12 tvar34) 95 | (define (uniquify-type-var t syms) 96 | (cond [(and (pair? t) (eq? 'lambda (car t))) 97 | (cons (eval t (interaction-environment)) syms)] ;;polymorphic synonym 98 | [(pair? t) 99 | (cons (cons (car t) (car (fold (fn [t acc] 100 | (let1 x (uniquify-type-var t (cdr acc)) 101 | (cons (cons (car x) (car acc)) 102 | (cdr x)))) 103 | '(() . ()) 104 | (cdr t)))) 105 | syms)] 106 | [(type-var? t) 107 | (cons t syms)] 108 | [else 109 | (let1 s (assq t syms) 110 | (if s (cons (cdr s) syms) 111 | (let1 s- (gensym "tvar") 112 | (cons s- (acons t s- syms)))))])) 113 | 114 | 115 | ;; expr * boolean -> 116 | (define (make-unknown-crt-type x checked) 117 | (case x 118 | [(String Number Char Keyword Symbol) 119 | (make :type x :checked checked)] 120 | [else (cond [(and (pair? x) (eq? 'Fn (car x))) 121 | (make 122 | :type (map (cut make-unknown-crt-type <> #f) (cdr x)) 123 | :checked checked)] 124 | [(pair? x) 125 | (let1 alias (hash-table-get *synonyms* (car x) #f) 126 | (cond [(and alias (closure? alias)) 127 | (make-unknown-crt-type (p (apply alias (cdr x))) checked)] 128 | [alias (make-unknown-crt-type alias checked)] 129 | [else (make :name (car x) 130 | :type (map (cut make-unknown-crt-type <> #f) (cdr x)) 131 | :checked checked)]))] 132 | [(type-var? x) 133 | (let1 alias (hash-table-get *synonyms* x #f) 134 | (if alias (make-unknown-crt-type alias checked) 135 | (make :name x :type '() :checked checked)))] 136 | [else (make :type x :checked checked)])]))) 137 | -------------------------------------------------------------------------------- /lib/Type.scm: -------------------------------------------------------------------------------- 1 | ;;;; Type.scm 2 | ;;;; 2014 Minori Yamashita 3 | ;;;; Type-check and resolve multimethod call 4 | 5 | (add-load-path "../lib/" :relative) 6 | 7 | (define-module Type 8 | (export acquire-checked-program) 9 | (use srfi-1) 10 | (use srfi-9) 11 | (use Util) 12 | (use util.match) 13 | (use DataTypes) 14 | 15 | (define *exprs-ht* (make-hash-table 'eq?)) 16 | (define *types-ht* (make-hash-table 'eq?)) 17 | (define *genmap-ht* (make-hash-table 'eq?)) 18 | (define *checking* (atom '(main))) 19 | 20 | ;; type-check ({uniq-name => expr} 21 | ;; {uniq-name => types} 22 | ;; {generic-name => [uniq-name]}) -> ({uniq-name => expr} . main-t) 23 | (define (acquire-checked-program exprs*types*genmap) 24 | (set! *exprs-ht* (fst exprs*types*genmap)) 25 | (set! *types-ht* (snd exprs*types*genmap)) 26 | (set! *genmap-ht* (thd exprs*types*genmap)) 27 | (reset! *checking* '(main)) 28 | (let ([checked-exprs (make-hash-table 'eq?)] 29 | [mains (hash-table-get *genmap-ht* 'main #f)]) 30 | (hash-table-for-each 31 | *exprs-ht* 32 | (fn [name expr] ;;(format #t "~A ~A\n" name (ref *types-ht* name)) 33 | (let1 t (ref *types-ht* name) 34 | (if (require-check? t) 35 | (hash-table-put! checked-exprs name 36 | (fst (type-toplevel expr t '()))) 37 | (hash-table-put! checked-exprs name expr))))) 38 | (if mains 39 | (let1 main-t (snd (type-toplevel (ref *exprs-ht* (car mains)) 40 | (ref *types-ht* (car mains)) '())) 41 | (pair checked-exprs main-t)) 42 | (pair checked-exprs 'Unit)))) 43 | 44 | (define (print-exc exc) 45 | (format (standard-error-port) "~A: ~A\n" (deref *checking*) (ref exc 'message))) 46 | 47 | ;; (^ prams... expr) * * {types} -> (U expr #f) 48 | (define-method type-toplevel ((expr ) (t ) env) 49 | (let* ([params (butlast (cdr expr))] 50 | [expr (last expr)] 51 | [in-ts (butlast (get-type t))] 52 | [out-t (last (get-type t))]) 53 | (guard (exc [else (print-exc exc) #f]) 54 | (let1 expr*type (type expr (append (zip params in-ts) env)) 55 | (unify out-t (snd expr*type)) 56 | (pair (append (cons '^ params) (list (fst expr*type))) 57 | (snd expr*type)))))) 58 | 59 | ;; expr * * {types} -> (U #f) 60 | (define-method type-toplevel (expr (t ) env) 61 | (guard (exc [else (print-exc exc) #f]) 62 | (let1 expr*type (type expr env) 63 | (unify t (snd expr*type)) 64 | expr*type))) 65 | 66 | 67 | (define (gen-type-var) 68 | (make :type (gensym "t_var"))) 69 | 70 | (define (prim-type x) 71 | (make :type x)) 72 | 73 | ;; expr * {types} -> (expr * ) 74 | (define-method type ((x ) _) (pair x (prim-type 'String))) 75 | (define-method type ((x ) _) (pair x (prim-type 'Number))) 76 | (define-method type ((x ) _) (pair x (prim-type 'Char))) 77 | (define-method type ((x ) _) (pair x (prim-type 'Keyword))) 78 | (define-method type ((s ) env) 79 | (swap! *checking* (cut cons s <>)) 80 | (let1 t (assoc s env) 81 | (if t 82 | (pair s (cadr t)) 83 | (let* ([names (ref *genmap-ht* s)]) 84 | (if (= (length names) 1) 85 | (pair (ref *exprs-ht* (car names)) 86 | (ref *types-ht* (car names))) 87 | (raise-error/message "Can't select method")))))) 88 | (define-method type ((xs ) env) 89 | (cond [(quote-expr? xs) (pair xs (prim-type 'Symbol))] 90 | [(lambda-expr? xs) (type-lambda xs env)] ;;stub 91 | [(native-expr? xs) (pair xs (gen-type-var))] 92 | [else 93 | (type-app (car xs) (cdr xs) env)])) 94 | 95 | 96 | ;; (^ params... expr) -> (expr * ) 97 | (define (type-lambda xs env) 98 | (let* ([paramts (cons (gen-type-var) 99 | (map (^x (gen-type-var)) (butlast (cdr xs))))] 100 | [checked 101 | (type-toplevel xs 102 | (make :type paramts :checked #t) 103 | env)]) 104 | (unless checked (raise-error/message "Type error inside of a lambda")) 105 | (pair xs (make :type (append paramts (list (snd checked))))))) 106 | 107 | 108 | ;; expr * [expr] * [] -> (expr * ) 109 | (define-method type-app [(generic-name ) (argxs ) env] 110 | (if (guard (_ [else #f]) (type generic-name env)) ;;local fn call or non-gen? 111 | (pair (cons generic-name (map (compose fst (cut type <> env)) argxs)) 112 | (type-of-app (snd (type generic-name env)) 113 | (map (compose snd (cut type <> env)) argxs))) 114 | 115 | (let* ([arg-expr*type (map (cut type <> env) argxs)] 116 | [arg-ts (map snd arg-expr*type)] 117 | [arg-xs (map fst arg-expr*type)] 118 | [selected-uniq-name*type 119 | (sort 120 | (filter-map (fn [uniq-name] 121 | (let1 t (guarded-type-of-app 122 | (ref *types-ht* uniq-name) 123 | arg-ts) 124 | (and t (pair uniq-name t)))) 125 | (ref *genmap-ht* generic-name)) 126 | specificity-sorter)]) 127 | 128 | (when (null? selected-uniq-name*type) 129 | (raise-error/message 130 | (format "No applicable method ~A for ~S" generic-name argxs))) 131 | (when (> (length selected-uniq-name*type) 1) 132 | (format (standard-error-port) 133 | "WARNING: ~A is ambiguous for ~S \n" generic-name argxs)) 134 | 135 | (pair (cons (fst (car selected-uniq-name*type)) arg-xs) 136 | (snd (car selected-uniq-name*type)))))) 137 | (define-method type-app [fx argxs env] 138 | (pair (cons fx argxs) 139 | (type-of-app (snd (type fx env)) ;;type of fn 140 | (map (compose snd (cut type <> env)) argxs)))) ;;types of args 141 | 142 | 143 | (define (replace-type-vars binding remaining-types) 144 | (fold (fn [b ft-] 145 | (replace-type-var ft- (fst b) (snd b))) 146 | remaining-types 147 | binding)) 148 | 149 | 150 | (define-method type-of-app [(t ) ts] 151 | (raise-error/message (format "Can not apply a ~S to ~S" 152 | (get-type t) (map get-type ts)))) 153 | (define-method type-of-app [(t ) ts] t) 154 | (define-method type-of-app [(t ) ts] t) 155 | (define-method type-of-app [(t ) (_ )] t) 156 | (define-method type-of-app [(ft ) argts] 157 | (let* ([raw-ft (get-type ft)] 158 | [binding (unify (car raw-ft) (car argts))] 159 | [rest-ft (replace-type-vars binding (cdr raw-ft))]) 160 | (cond [(and (= 1 (length rest-ft)) 161 | (is-a? (car rest-ft) )) 162 | (type-of-app (car rest-ft) (cdr argts))] 163 | [(and (= 1 (length rest-ft))) 164 | (car rest-ft)] 165 | [else 166 | (type-of-app (make :type rest-ft) 167 | (cdr argts))]))) 168 | 169 | 170 | (define (replace-type-var ft var t) 171 | (if (null? ft) '() 172 | (cons (cond [(equal? (car ft) var) t] 173 | [(is-a? (car ft) ) 174 | (make 175 | :name (type-name (car ft)) 176 | :type (replace-type-var (get-type (car ft)) var t))] 177 | [(is-a? (car ft) ) 178 | (make :type (replace-type-var 179 | (get-type (car ft)) var t))] 180 | [else (car ft)]) 181 | (replace-type-var (cdr ft) var t)))) 182 | 183 | 184 | (define (guarded-unify t1 t2) 185 | (guard (exc [else #f]) 186 | (unify t1 t2))) 187 | 188 | (define (guarded-type-of-app t ts) 189 | (guard (exc [else #f]) 190 | (type-of-app t ts))) 191 | 192 | ;;a Number -> ((a Number)) 193 | (define-method unify ((t1 ) (t2 )) 194 | (if (equal? t1 t2) 195 | (list (pair (gen-type-var) t2)) 196 | (raise-error/message (format "Primitive type contradiction: ~S -><- ~S" t1 t2)))) 197 | 198 | (define-method unify ((t1 ) (t2 )) 199 | (let ([t1- (get-type t1)] 200 | [t2- (get-type t2)]) 201 | (if (eq? (type-name t1) (type-name t2)) 202 | (apply append (map (fn [tx ty] (unify tx ty)) (get-type t1) (get-type t2))) 203 | (raise-error/message 204 | (format "Composite type container contradiction: ~S -><- ~S" 205 | (type-name t1) (type-name t2)))))) 206 | 207 | (define-method unify ((t1 ) (t2 )) 208 | (list (pair t1 t2))) 209 | 210 | (define-method unify ((t1 ) (t2 )) 211 | (list (pair t2 t1))) 212 | 213 | (define-method unify ((t1 ) (t2 )) 214 | (unify (make :name 'Fn :type (get-type t1)) 215 | (make :name 'Fn :type (get-type t2)))) 216 | 217 | (define-method unify ((t1 ) (t2 )) 218 | (raise-error/message (format "Type contradiction: ~S -><- ~S" 219 | (type->data t1) 220 | (type->data t2)))) 221 | 222 | 223 | 224 | (define (specificity-sorter x y) 225 | ;(print x) 226 | ;(print y) 227 | (specific (snd x) (snd y))) 228 | 229 | (define-method specific ((t1 ) (t2 )) 230 | 0) 231 | (define-method specific ((t1 ) (t2 )) 232 | (specific (get-type t1) (get-type t2))) 233 | (define-method specific ((t1 ) (t2 )) 234 | 1) 235 | (define-method specific ((t1 ) (t2 )) 236 | -1) 237 | (define-method specific ((t1 ) (t2 )) 238 | 0)) 239 | -------------------------------------------------------------------------------- /lib/util.scm: -------------------------------------------------------------------------------- 1 | (define-module Util 2 | (export-all) 3 | (use srfi-1) 4 | (use srfi-9) 5 | 6 | (define (butlast xs) (drop-right xs 1)) 7 | 8 | (define (str . xs) 9 | (apply string-append (map show xs))) 10 | 11 | (define-method show [(x )] x) 12 | (define-method show [(x )] (string-append ":" (keyword->string x))) 13 | (define-method show [x] (format "~S" x)) 14 | 15 | (define (separate x xs) 16 | (if (null? xs) 17 | '() 18 | (let1 tail (separate x (cdr xs)) 19 | (cons (car xs) 20 | (if (null? tail) tail (cons x tail)))))) 21 | 22 | ;;h1 > h2 23 | (define (hash-table-union! h1 h2) 24 | (hash-table-for-each h2 (lambda [k v] 25 | (hash-table-put! h1 k v))) 26 | h1) 27 | 28 | ;;get the value associated with the key symbol 29 | (define (assoc-ref env key) 30 | (let ((binding (assq key env))) 31 | (if binding (cdr binding) 'lookup-fail))) 32 | 33 | 34 | (define (find-map f xs) 35 | (cond [(null? xs) #f] 36 | [(f (car xs)) => identity] 37 | [else (find-map f (cdr xs))])) 38 | 39 | (define (find*map f xs) 40 | (cond [(null? xs) #f] 41 | [(f (car xs)) => (cut cons (car xs) <>)] 42 | [else (find*map f (cdr xs))])) 43 | 44 | (define (atom? x) 45 | (or (string? x) 46 | (number? x) 47 | (char? x) 48 | (keyword? x))) 49 | 50 | 51 | (define-syntax fn 52 | (syntax-rules () 53 | ((_ (arg ...) exp ...) 54 | (lambda (arg ...) exp ...)) 55 | ((_ arg exp ...) 56 | (lambda arg exp ...)))) 57 | 58 | (define (p x) ;(print x) 59 | x) 60 | 61 | 62 | (define (lambda-expr? exp) 63 | (and (pair? exp) (eq? (car exp) '^))) 64 | 65 | (define (quote-expr? x) 66 | (and (pair? x) (eq? (car x) 'quote))) 67 | 68 | (define (native-expr? exp) 69 | (and (pair? exp) (eq? (car exp) '**))) 70 | 71 | 72 | (define (flatmap f x) 73 | (apply append (map f x))) 74 | 75 | (define (raise-error/message x) 76 | (raise (condition ( (message x))))) 77 | 78 | 79 | (define (print-code fmt code) 80 | (print 81 | (regexp-replace-all #/#/ (format fmt code) "\\1"))) 82 | 83 | 84 | 85 | (define (hash-table-put-! ht k v) 86 | (hash-table-put! ht k v) 87 | ht) 88 | 89 | 90 | (define (ht-put-cons ht key val) 91 | (let1 xs (hash-table-get ht key #f) 92 | (if xs 93 | (hash-table-put-! ht key (cons val xs)) 94 | (hash-table-put-! ht key (list val))))) 95 | 96 | (define (genmap-merge! ht1 ht2) 97 | (hash-table-for-each 98 | ht2 99 | (lambda [k ys] 100 | (let* ([xs (hash-table-get ht1 k #f)] 101 | [xs (if xs xs '())]) 102 | (hash-table-put! ht1 k (append ys xs))))) 103 | ht1) 104 | 105 | (define (inc x) 106 | (+ x 1)) 107 | 108 | (define-record-type 109 | (atom val) 110 | atom*? 111 | (val deref reset!)) 112 | 113 | (define (swap! atom f) 114 | (reset! atom (f (deref atom)))) 115 | 116 | 117 | (define (get-main-name genmap) 118 | (let1 x (hash-table-get genmap 'main #f) 119 | (if x (car x) #f)))) 120 | -------------------------------------------------------------------------------- /old/Compiler.scm: -------------------------------------------------------------------------------- 1 | ;;;; S-expression to SECD instruction Compiler ;;;; 2 | ;;; 2012 Minori Yamashita ;;add your name here 3 | ;;; 4 | ;;; reference: 5 | ;;; http://www.geocities.jp/m_hiroi/func/abcscm33.html 6 | ;;; 7 | 8 | (load "./SECD.scm") 9 | 10 | ;;; Helpers ;;; 11 | (define (atom? x) 12 | (cond 13 | [(string? x) #t] 14 | [(number? x) #t] 15 | [(boolean? x) #t] 16 | [(char? x) #t] 17 | [else #f])) 18 | 19 | ;;uncurry function applications 20 | (define (complis exp code) 21 | (if (null? exp) 22 | code 23 | (compile- `(delay ,(car exp)) (complis (cdr exp) code)))) 24 | 25 | ;;stack all the arguments to the primitive procedure 26 | ;;and apply the procedure 27 | (define (primitive-compile args prim) 28 | (if (null? args) 29 | prim 30 | (compile- (car args) (primitive-compile (cdr args) prim)))) 31 | 32 | ;;compile :: Lisp -> SECD 33 | (define (compile program) 34 | (fold-right compile- `((,stop)) program)) 35 | 36 | ;;compile- :: Lisp -> code -> code 37 | (define (compile- exp code) 38 | ;(print (format "exp : ~S" exp)) 39 | ;(print (format "code: ~S" code)) 40 | ;(newline) 41 | (cond 42 | [(atom? exp) 43 | ;;(stack-constant const) 44 | (cons `(,stack-constant ,exp) code)] 45 | 46 | [(symbol? exp) 47 | ;;(ref-arg symbol) (thaw) 48 | (cons `(,ref-arg ,exp) (cons `(,thaw) code))] 49 | 50 | [(eq? (car exp) 'quote) 51 | ;;(stack-constant symbol) 52 | (cons `(,stack-constant ,(cadr exp)) code)] 53 | 54 | [(eq? (car exp) '**) 55 | ;; call primitive procedures 56 | (append (primitive-compile (cddr exp) `((,primitive ,(cadr exp)))) code)] 57 | 58 | 59 | [(eq? (car exp) ':=) 60 | ;;(:= (foo bar baz) (bar baz)) 61 | ;;bound (def symbol) 62 | (if (< (length (cadr exp)) 2) 63 | (compile- `(delay ,(caddr exp)) (cons `(,def ,(caadr exp)) code)) ;no param 64 | (compile- `(delay (-> ,(cdadr exp) ,(caddr exp))) (cons `(,def ,(caadr exp)) code)))] 65 | 66 | [(eq? (car exp) '->) 67 | ;;(-> (x y z) (x y z)) = (-> (x) (-> (y) (-> (z) (x y z)))) ;auto-currying 68 | ;;(stack-closure symbol ((code) (restore))) 69 | (let ((params (cadr exp)) 70 | (body (caddr exp))) 71 | (if (null? (cdr params)) 72 | (cons `(,stack-closure ,(car params) ,(compile- body `((,restore)))) code) 73 | (cons `(,stack-closure ,(car params) ,(compile- `(-> ,(cdr params) ,body) `((,restore)))) code)))] 74 | 75 | [(eq? (car exp) 'delay) 76 | ;;(freeze ((code) (restore))) 77 | (cons `(,freeze ,(compile- (cadr exp) `((,restore)))) code)] 78 | 79 | [else 80 | ;;(foo 1 2 3) = (((foo 1) 2) 3) 81 | ;;arg arg ... closure (app) (app) ... 82 | (complis (reverse (cdr exp)) 83 | (compile- 84 | (car exp) 85 | (append (map (lambda (arg) `(,app)) (cdr exp)) code))) 86 | ])) 87 | 88 | -------------------------------------------------------------------------------- /old/K-Compiler.scm: -------------------------------------------------------------------------------- 1 | ;;;; Nadeko -> Krivine's Machine instruction ;;;; 2 | ;;; 2012 Minori Yamashita ;;add your name here 3 | ;;; 4 | 5 | (define-module Compiler 6 | (extend Krivine) 7 | (export compile) 8 | 9 | ;;Helper 10 | (define (atom? x) 11 | (cond 12 | [(string? x) #t] 13 | [(number? x) #t] 14 | [(boolean? x) #t] 15 | [(char? x) #t] 16 | [else #f])) 17 | 18 | ;;curry 19 | (define (curry-grabs params) 20 | (map (lambda (p) `(,GRAB ,p)) params)) 21 | 22 | ;;partial-application 23 | (define (partial-arg args continuation) 24 | (map (lambda (arg) 25 | `(,CLOSURE ,(compile- arg continuation))) (reverse args))) 26 | 27 | ;;; Compiler ;;; 28 | 29 | ;;compile :: Nadeko -> Krivine 30 | (define (compile program) 31 | (fold-right compile- `((,STOP)) program)) 32 | 33 | ;;compile- :: Nadeko -> code -> code 34 | (define (compile- exp code) 35 | ;(print (format "exp : ~S" exp)) 36 | ;(print (format "code: ~S" code)) 37 | ;(newline) 38 | (cond 39 | [(atom? exp) 40 | (cons `(,CONSTANT ,exp) code)] 41 | 42 | [(symbol? exp) 43 | `((,ACCESS ,exp) (,CONTINUE))] ;;CONTINUE dumps the remaining code 44 | 45 | [(eq? (car exp) 'quote) 46 | (cons `(,CONSTANT ,(cadr exp)) code)] 47 | 48 | [(eq? (car exp) '**) 49 | ; (** / 3 2) 50 | (cons 51 | (append `(,PRIMITIVE ,(cadr exp)) (map (lambda (x) (compile- x `((,STOP)))) (cddr exp))) 52 | code)] 53 | 54 | [(eq? (car exp) ':=) 55 | (let ([body (compile- (caddr exp) `((,STOP)))]) ;;if no CONTINUE it must be STOP 56 | (cons 57 | `(,CLOSURE ,(append (curry-grabs (cdadr exp)) body)) 58 | (cons `(,DEFINE ,(caadr exp)) code)))] 59 | 60 | [(eq? (car exp) '->) 61 | (append (curry-grabs (cadr exp)) (compile- (caddr exp) code))] 62 | 63 | [else 64 | (append (partial-arg (cdr exp) code) 65 | (compile- (car exp) code))]))) -------------------------------------------------------------------------------- /old/Krivine.scm: -------------------------------------------------------------------------------- 1 | ;;;; Krivine's Machine in Scheme ;;;; 2 | ;;; 2012 Minori Yamashita ;;add your name here 3 | ;;; 4 | ;;; reference: 5 | ;;; http://pauillac.inria.fr/~xleroy/talks/zam-kazam05.pdf 6 | ;;; http://pop-art.inrialpes.fr/~fradet/PDFs/HOSC07.pdf 7 | 8 | ;;; Notes ;;; 9 | ;; CLOSURE creates thunks that packs the continuation and environment together. 10 | ;; To create closures(function objects), CLOSURE the GRAB and expression followed by CONTINUE. 11 | ;; 12 | 13 | (use srfi-1) 14 | 15 | (define-module Krivine 16 | (export-all) 17 | 18 | ;;; global environment ;;; 19 | (define *global-env* 20 | (make-hash-table)) 21 | 22 | ;;; Helpers ;;; 23 | 24 | ;;get the value associated with the key symbol 25 | (define (assoc-ref env key) 26 | (let ((binding (assq key env))) 27 | (if binding (cdr binding) 'lookup-fail))) 28 | 29 | (define (Krivine code env stack g-env) 30 | (if (hash-table? g-env) (set! *global-env* g-env)) ;side effect 31 | (Krivine- code env stack)) 32 | 33 | ;;; Krivine's Machine ;;; 34 | (define (Krivine- code env stack) 35 | ;(print (format "code : ~S" code)) 36 | ;(print (format "env : ~S" env)) 37 | ;(print (format "stack: ~S" stack)) 38 | ;(print (format "g-env: ~S")) 39 | ;(newline) 40 | 41 | ;inst inst-arg code-rest env stack global 42 | ((caar code) (cdar code) (cdr code) env stack)) 43 | 44 | ;; refer a value associated with the character from either local-env or global-env 45 | (define (ACCESS args code env stack) 46 | (let ([val (assoc-ref env (car args))]) 47 | (Krivine- 48 | code 49 | env 50 | (if (eq? val 'lookup-fail) 51 | (cons (hash-table-get *global-env* (car args) 'lookup-fail) stack) 52 | (cons val stack))))) 53 | 54 | ;; retrieves a thunk from the stack and replace the state with its. 55 | ;; thunks carry all the continuation therefore no need to worry about the "frame" or "return" 56 | (define (CONTINUE args code env stack) 57 | (let* ([closure (car stack)] 58 | [c-code (assoc-ref closure 'code)] 59 | [c-env (assoc-ref closure 'env)]) 60 | (Krivine- 61 | c-code 62 | c-env 63 | (cdr stack)))) 64 | 65 | ;; associate a stack-top value with the character and cons the pair onto the local-env 66 | (define (GRAB args code env stack) 67 | (Krivine- 68 | code 69 | (cons `(,(car args) . ,(car stack)) env) 70 | (cdr stack))) 71 | 72 | ;; creates a thunk that is a data carrying continuation + environment 73 | (define (CLOSURE args code env stack) 74 | (Krivine- 75 | code 76 | env 77 | (cons `((code . ,(car args)) (env . ,env)) stack))) 78 | 79 | 80 | ;;;; Extension for nadeko ;;;; 81 | 82 | ;; returns what's on the top of the stack 83 | (define (STOP args code env stack) 84 | (values (if (null? stack) '() (car stack)) *global-env*)) 85 | 86 | ;; cons a self-evaluating value on to the stack 87 | (define (CONSTANT args code env stack) 88 | (Krivine- 89 | code 90 | env 91 | (cons (car args) stack))) 92 | 93 | ;; creates a global binding 94 | (define (DEFINE args code env stack) 95 | (hash-table-put! *global-env* (car args) (car stack)) ;side effect 96 | (Krivine- 97 | code 98 | env 99 | (cdr stack))) 100 | 101 | (define (PRIMITIVE args code env stack) 102 | (define (get-constant code) ;dirty part 103 | (receive (result _) 104 | (guard (exc 105 | (else (values 'closure '()))) 106 | (Krivine- code env '())) result)) 107 | (let ([subr (car args)] 108 | [p-args (cdr args)] 109 | [true `((,ACCESS true) (,CONTINUE))] 110 | [false `((,ACCESS false) (,CONTINUE))]) 111 | (cond 112 | [(eq? subr 'equal) 113 | (Krivine- 114 | (append (if (equal? (get-constant (car p-args)) (get-constant (cadr p-args))) true false) code) 115 | env stack)] 116 | [(eq? subr '<) 117 | (Krivine- 118 | (append (if (< (get-constant (car p-args)) (get-constant (cadr p-args))) true false) code) 119 | env stack)] 120 | [(eq? subr '<=) 121 | (Krivine- 122 | (append (if (<= (get-constant (car p-args)) (get-constant (cadr p-args))) true false) code) 123 | env stack)] 124 | [(eq? subr '+) 125 | (Krivine- 126 | code env 127 | (cons (+ (get-constant (car p-args)) (get-constant (cadr p-args))) stack))] 128 | [(eq? subr '-) 129 | (Krivine- 130 | code env 131 | (cons (- (get-constant (car p-args)) (get-constant (cadr p-args))) stack))] 132 | [(eq? subr '*) 133 | (Krivine- 134 | code env 135 | (cons (* (get-constant (car p-args)) (get-constant (cadr p-args))) stack))] 136 | [(eq? subr '/) 137 | (Krivine- 138 | code env 139 | (cons (/ (get-constant (car p-args)) (get-constant (cadr p-args))) stack))] 140 | [(eq? subr '%) 141 | (Krivine- 142 | code env 143 | (cons (mod (get-constant (car p-args)) (get-constant (cadr p-args))) stack))] 144 | [(eq? subr '++) 145 | (Krivine- 146 | code env 147 | (cons (string-append (get-constant (car p-args)) (get-constant (cadr p-args))) stack))] 148 | [(eq? subr 'num->str) 149 | (Krivine- 150 | code env 151 | (cons (number->string (get-constant (car p-args))) stack))] 152 | [(eq? subr 'string?) 153 | (Krivine- 154 | (append (if (string? (get-constant (car p-args))) true false) code) env stack)] 155 | [(eq? subr 'number?) 156 | (Krivine- 157 | (append (if (number? (get-constant (car p-args))) true false) code) 158 | env stack)] 159 | [(eq? subr 'print) 160 | (print (get-constant (car p-args))) 161 | (Krivine- 162 | code env stack)] 163 | [(eq? subr 'time) 164 | (time (get-constant (car p-args))) 165 | (Krivine- 166 | code env stack)])))) -------------------------------------------------------------------------------- /old/SECD.scm: -------------------------------------------------------------------------------- 1 | ;;;; SECD Machine in Scheme ;;;; 2 | ;;; 2012 Minori Yamashita ;;add your name here 3 | ;;; 4 | ;;; reference: 5 | ;;; http://www.geocities.jp/m_hiroi/func/abcscm33.html 6 | ;;; http://en.wikipedia.org/wiki/SECD_machine 7 | ;;; 8 | ;;; The description of each instruction is copied from wikipedia.org on 22 Nov 2012 9 | 10 | ;;; Spec to note ;;; 11 | ;; every function take exactly one argument. 12 | ;; curry your function manually if you want more than one argument. 13 | ;; 14 | ;; VM is responsible of looking up the environment unlike the original SECD 15 | ;; 16 | ;; VM is capable of handling `freeze` and `thaw` instruction which can be used to simulate lazy evaluation 17 | 18 | (use srfi-1) 19 | 20 | ;;; Helpers ;;; 21 | 22 | ;;data structure for closure 23 | (define (data-closure param code env) 24 | (lambda (f) 25 | (f param code env))) 26 | (define (cls-param p c e) p) 27 | (define (cls-code p c e) c) 28 | (define (cls-env p c e) e) 29 | 30 | ;;data structure for thunk 31 | (define (data-thunk code env) 32 | (lambda (f) (f code env))) 33 | (define (thk-code c e) c) 34 | (define (thk-env c e) e) 35 | 36 | ;;get the value associated with the key symbol 37 | (define (env-ref env key) 38 | (let ((binding (assq key env))) 39 | (if binding (cdr binding) 'lookup-fail))) 40 | 41 | ;;; SECD Machine ;;; 42 | (define (SECD stack env code dump g-env) 43 | ;(print (format "stack: ~S" stack)) 44 | ;(print (format "env : ~S" env)) 45 | ;(print (format "code : ~S" code)) 46 | ;(print (format "dump : ~S" dump)) 47 | ;(print (format "g-env: ~S" g-env)) 48 | ;(newline) 49 | 50 | ;inst args stack env code dump global-env 51 | ((caar code) (cdar code) stack env (cdr code) dump g-env)) 52 | 53 | 54 | ;;; Instructions ;;; 55 | 56 | ;;ldc 57 | ;; pushes a constant argument onto the stack 58 | (define (stack-constant args stack env code dump g-env) 59 | (SECD 60 | ; constant 61 | (cons (car args) stack) ;S 62 | env ;E 63 | code ;C 64 | dump ;D 65 | g-env)) 66 | 67 | ;;ld 68 | ;; pushes the value of a variable onto the stack. 69 | ;; The variable is indicated by the argument, a symbol. 70 | ;; Try the local env first then g-env if failed 71 | (define (ref-arg args stack env code dump g-env) 72 | (let ((val (env-ref env (car args)))) 73 | (SECD 74 | (cons (if (eq? val 'lookup-fail) 75 | (env-ref g-env (car args)) 76 | val) stack) ;S 77 | env ;E 78 | code ;C 79 | dump ;D 80 | g-env))) 81 | 82 | ;;ldf 83 | ;; takes one list argument representing a function. 84 | ;; It constructs a closure (a pair containing the function and the current environment) 85 | ;; and pushes that onto the stack. 86 | (define (stack-closure args stack env code dump g-env) 87 | (SECD 88 | ; param code 89 | (cons (data-closure (car args) (cadr args) env) stack) ;S 90 | env ;E 91 | code ;C 92 | dump ;D 93 | g-env)) 94 | 95 | ;;ap 96 | ;; pops a closure and a list of parameter values from the stack. 97 | ;; The closure is applied to the parameters by installing its environment as the current one, 98 | ;; pushing the parameter list in front of that, clearing the stack, and setting C to the closure's function pointer. 99 | ;; The previous values of S, E, and the next value of C are saved on the dump. 100 | (define (app args stack env code dump g-env) 101 | (let* ( 102 | (closure (car stack)) 103 | (clos-prm (closure cls-param)) 104 | (clos-code (closure cls-code)) ;code enclosed in the closure 105 | (clos-env (closure cls-env))) ;enclosed environment 106 | (SECD 107 | '() ;S 108 | ; symbol argument 109 | (cons `(,clos-prm . ,(cadr stack)) clos-env) ;E 110 | clos-code ;C 111 | ; stack-(closure+arg) 112 | (cons (list (cddr stack) env code) dump) ;D 113 | g-env))) 114 | 115 | ;;ret 116 | ;; pops one return value from the stack, 117 | ;; restores S, E, and C from the dump, and pushes the return value onto the now-current stack. 118 | (define (restore args stack env code dump g-env) 119 | (let* ( 120 | (frame (car dump)) 121 | (restoring-stack (car frame)) 122 | (restoring-env (cadr frame)) 123 | (restoring-code (caddr frame))) 124 | (SECD 125 | ; value returned 126 | (cons (car stack) restoring-stack) ;S 127 | restoring-env ;E 128 | restoring-code ;C 129 | (cdr dump) ;D 130 | g-env))) 131 | 132 | ;;def 133 | ;; push stack top to g-env 134 | (define (def args stack env code dump g-env) 135 | (SECD 136 | (cdr stack) ;S 137 | env ;E 138 | code ;C 139 | dump ;D 140 | (cons `(,(car args) . ,(car stack)) g-env))) 141 | 142 | ;;freeze 143 | ;; delays the evaluation of the code until thawing 144 | ;; creates a thunk (or promice) and stack it 145 | (define (freeze args stack env code dump g-env) 146 | (SECD 147 | (cons (data-thunk (car args) env) stack) ;S 148 | env ;E 149 | code ;C 150 | dump ;D 151 | g-env)) 152 | 153 | ;;thaw 154 | ;; evaluates the code inside the thunk in its environment. 155 | ;; creates a call frame like app 156 | (define (thaw args stack env code dump g-env) 157 | (let* ( 158 | (thunk (car stack)) 159 | (thunk-code (thunk thk-code)) 160 | (thunk-env (thunk thk-env))) 161 | (SECD 162 | '() ;S 163 | thunk-env ;E 164 | thunk-code ;C 165 | (cons (list (cdr stack) env code) dump) ;D 166 | g-env))) 167 | 168 | ;;stop 169 | ;; stops the Machine and return the value at the top of the stack 170 | (define (stop args stack env code dump g-env) 171 | (values (if (null? stack) stack (car stack)) g-env)) ;;return `values`. useful for REPL 172 | 173 | 174 | 175 | ;;; primitives ;;; 176 | (define (primitive args stack env code dump g-env) 177 | (let ([subr (car args)] 178 | [true `((,ref-arg true) (,thaw))] 179 | [false `((,ref-arg false) (,thaw))]) 180 | (cond 181 | [(eq? subr 'equal) 182 | (let ([bool (if (equal? (cadr stack) (car stack)) true false)]) 183 | (SECD 184 | (cddr stack) 185 | env 186 | (append bool code) 187 | dump g-env))] 188 | [(eq? subr '+) 189 | (SECD 190 | (cons (+ (cadr stack) (car stack)) (cddr stack)) 191 | env code dump g-env)] 192 | [(eq? subr '-) 193 | (SECD 194 | (cons (- (cadr stack) (car stack)) (cddr stack)) 195 | env code dump g-env)] 196 | [(eq? subr '*) 197 | (SECD 198 | (cons (* (cadr stack) (car stack)) (cddr stack)) 199 | env code dump g-env)] 200 | [(eq? subr '/) 201 | (SECD 202 | (cons (/ (cadr stack) (car stack)) (cddr stack)) 203 | env code dump g-env)] 204 | [(eq? subr '%) 205 | (SECD 206 | (cons (mod (cadr stack) (car stack)) (cddr stack)) 207 | env code dump g-env)] 208 | [(eq? subr '++) 209 | (SECD 210 | (cons (string-append (cadr stack) (car stack)) (cddr stack)) 211 | env code dump g-env)] 212 | [(eq? subr 'num->str) 213 | (SECD 214 | (cons (number->string (car stack)) (cdr stack)) 215 | env code dump g-env)] 216 | [(eq? subr 'number?) 217 | (SECD 218 | (cdr stack) 219 | env 220 | (append (if (number? (car stack)) true false) code) 221 | dump g-env)] 222 | [(eq? subr 'string?) 223 | (SECD 224 | (cdr stack) 225 | env 226 | (append (if (string? (car stack)) true false) code) 227 | dump g-env)]))) 228 | -------------------------------------------------------------------------------- /tests/srfi-1.scm: -------------------------------------------------------------------------------- 1 | (add-load-path "../lib/" :relative) 2 | (add-load-path "../compilers/" :relative) 3 | 4 | (use gauche.test) 5 | (use to-carrot-vm) 6 | (use CarrotVM) 7 | (use Util) 8 | (use DataTypes) 9 | (use Read) 10 | (use Type) 11 | 12 | (define (load-file fname exprs*types*genmap) 13 | (call-with-input-file fname 14 | (fn [file-port] 15 | (read-s-exprs (read-list file-port) exprs*types*genmap)))) 16 | 17 | 18 | 19 | (define (read-list port) 20 | (let ((exp (read port))) 21 | (if (eof-object? exp) '() 22 | (cons exp (read-list port))))) 23 | 24 | (define *exprs*types*genmap 25 | (fold (fn [fname exprs*types*genmap] 26 | (load-file fname exprs*types*genmap)) 27 | (triple (make-hash-table 'eq?) (make-hash-table 'eq?) (make-hash-table 'eq?)) 28 | '("examples/prelude.nadeko" "examples/srfi-1.nadeko"))) 29 | 30 | (define (run* code) 31 | (let* ([res (read-s-exprs code *exprs*types*genmap)] 32 | [exprs*t (acquire-checked-program res)]) 33 | (set! *exprs*types*genmap res) 34 | (pair (CarrotVM (compile (fst exprs*t)) (get-main-name (thd res))) (snd exprs*t)))) 35 | 36 | (define (run code) 37 | (let* ([res1 (run* `((show ,code)))] 38 | [res2 (run* `(,code))]) 39 | (list (fst res1) (type->data (snd res2))))) 40 | 41 | (test-start "srfi-1-acceptance-test") 42 | 43 | (test-section "constructors") 44 | (test* "cons" 45 | '("1 : 2 : 3 : []" (List Number)) 46 | (run `(cons 1 (cons 2 (cons 3 nil))))) 47 | (test* "make-integers-from" 48 | '("2 : 3 : 4 : []" (List Number)) 49 | (run `(take 3 (make-integers-from 2)))) 50 | (test* "integers" 51 | '("0 : 1 : 2 : 3 : []" (List Number)) 52 | (run `(take 4 integers))) 53 | 54 | (test-section "selectors") 55 | (test* "car" 56 | '("0" Number) 57 | (run `(car integers))) 58 | (test* "cdr" 59 | '("1 : 2 : 3 : []" (List Number)) 60 | (run `(cdr (take 4 integers)))) 61 | (test* "list-ref" 62 | '("2" (Option Number)) 63 | (run `(list-ref 2 integers))) 64 | (test* "list-ref nil" 65 | '("t" String) 66 | (run `(none? (list-ref 8 (cons 1 nil)) "t" "f"))) 67 | (test* "take" 68 | '("0 : 1 : 2 : 3 : []" (List Number)) 69 | (run `(take 4 integers))) 70 | (test* "drop" 71 | '("2 : 3 : []" (List Number)) 72 | (run `(take 2 (drop 2 integers)))) 73 | (test* "take-right" 74 | '("2 : 3 : 4 : []" (List Number)) 75 | (run `(take-right 3 (take 5 integers)))) 76 | (test* "drop-right" 77 | '("0 : 1 : []" (List Number)) 78 | (run `(drop-right 3 (take 5 integers)))) 79 | (test* "split-at" 80 | '("0 : 1 : 2 : 3 : 4 : []" (List Number)) 81 | (run `(fst (split-at 5 (take 10 integers))))) 82 | (test* "split-at" 83 | '("5 : 6 : 7 : 8 : 9 : []" (List Number)) 84 | (run `(snd (split-at 5 (take 10 integers))))) 85 | (test* "last" 86 | '("5" Number) 87 | (run `(last (take 6 integers)))) 88 | 89 | (test-section "miscellaneous") 90 | (test* "length" 91 | '("0" Number) 92 | (run `(length nil))) 93 | (test* "length" 94 | '("10" Number) 95 | (run `(length (take 10 integers)))) 96 | (test* "append" 97 | '("0 : 1 : 2 : 0 : 1 : 2 : 3 : []" (List Number)) 98 | (run `(append (take 3 integers) (take 4 integers)))) 99 | #;(test* "concatenate" "0 : 1 : 2 : 0 : 1 : 2 : 3 : []" 100 | (run `(concatenate (cons (take integers 3) (cons (take integers 4) nil))))) 101 | (test* "reverse" 102 | '("5 : 4 : 3 : 2 : 1 : 0 : []" (List Number)) 103 | (run `(reverse (take 6 integers)))) 104 | (test* "zip" 105 | '("[ (0 . 2) (1 . 1) (2 . 0) ]" (List (Pair Number Number))) 106 | (run `(zip (take 3 integers) (reverse (take 3 integers))))) 107 | ;;(test* "unzip" "0 : 1 : 2 : []" (run `(fst (unzip (zip (take integers 3) (reverse (take integers 3))))))) 108 | ;;(test* "unzip" "2 : 1 : 0 : []" (run `(snd (unzip (zip (take integers 3) (reverse (take integers 3))))))) 109 | (test* "count1" 110 | '("3" Number) 111 | (run `(count1 (=? 1) (cons 1 (cons 2 (cons 1 (cons 3 (cons 1 nil)))))))) 112 | (test* "count2" 113 | '("3" Number) 114 | (run `(count2 (^ x y (=? 2 (+ x y))) 115 | (cons 1 (cons 2 (cons 1 (cons 3 (cons 1 nil))))) 116 | (cons 1 (cons 2 (cons 1 (cons 3 (cons 1 nil)))))))) 117 | 118 | (test-section "fold : map") 119 | (test* "fold" 120 | '("55" Number) 121 | (run `(foldl + 0 (take 11 integers)))) 122 | (test* "foldl" 123 | '("2 : 1 : 0 : []" (List Number)) 124 | (run `(foldl cons nil (take 3 integers)))) 125 | (test* "foldr" 126 | '("55" Number) 127 | (run `(foldr + 0 (take 11 integers)))) 128 | (test* "foldr" 129 | '("0 : 1 : 2 : []" (List Number)) 130 | (run `(foldr cons nil (take 3 integers)))) 131 | #;(test* "unfold" "1 : 4 : 9 : 16 : 25 : 36 : 49 : 64 : 81 : 100 : []" 132 | (run `(unfold (< 10) (^ x (* x x)) (+ 1) 1))) 133 | (test* "map" 134 | '("0 : 2 : 4 : 6 : 8 : []" (List Number)) 135 | (run `(take 5 (map (* 2) integers)))) 136 | 137 | (test-section "filtering : partitioning") 138 | (test* "filter" 139 | '("1 : 3 : 2 : []" (List Number)) 140 | (run `(filter (> 5) (cons 1 (cons 9 (cons 3 (cons 12 (cons 2 nil)))))))) 141 | ;;(test* "partition" "1 : 3 : []" 142 | ;; (run `(fst (partition (cons 1 (cons "2" (cons 3 (cons "4" nil)))) number?)))) 143 | ;;(test* "partition" "2 : 4 : []" 144 | ;; (run `(snd (partition (cons 1 (cons "2" (cons 3 (cons "4" nil)))) number?)))) 145 | (test* "remove" 146 | '("5 : 6 : 7 : []" (List Number)) 147 | (run `(remove (> 5) (take 8 integers)))) 148 | 149 | (test-section "searching") 150 | (test* "find" 151 | '("6" (Option Number)) 152 | (run `(find (< 5) (take 10 integers)))) 153 | (test* "find" 154 | '("none" String) 155 | (run `(none? (find (< 5) (cons 3 nil)) "none" "some"))) 156 | (test* "find-tail" 157 | '("6 : 7 : 8 : 9 : []" (List Number)) 158 | (run `(find-tail (< 5) (take 10 integers)))) 159 | (test* "take-while" 160 | '("0 : 1 : 2 : 3 : []" (List Number)) 161 | (run `(take-while (> 4) (take 8 integers)))) 162 | (test* "drop-while" 163 | '("4 : 5 : 6 : 7 : []" (List Number)) 164 | (run `(drop-while (> 4) (take 8 integers)))) 165 | (test* "any?" 166 | '("true" String) 167 | (run `(any? (=? 3) (take 5 integers) "true" "false"))) 168 | (test* "any?" 169 | '("false" String) 170 | (run `(any? (=? 100) (take 5 integers) "true" "false"))) 171 | (test* "every?" 172 | '("true" String) 173 | (run `(every? (> 8) (take 5 integers) "true" "false"))) 174 | (test* "every?" 175 | '("false" String) 176 | (run `(every? (> 3) (take 5 integers) "true" "false"))) 177 | (test* "list-index" 178 | '("7" (Option Number)) 179 | (run `(list-index (< 6) (take 10 integers)))) 180 | (test* "list-index" 181 | '("none" String) 182 | (run `(none? (list-index (< 20) (take 10 integers)) "none" "some"))) 183 | (test* "member" 184 | '("3 : 4 : 5 : []" (List Number)) 185 | (run `(member 3 (take 6 integers)))) 186 | (test* "delete" 187 | '("2 : 3 : []" (List Number)) 188 | (run `(delete 1 (cons 1 (cons 2 (cons 1 (cons 3 nil))))))) 189 | (test* "delete-duplicates" 190 | '("1 : 2 : 3 : []" (List Number)) 191 | (run `(delete-duplicates (cons 1 (cons 2 (cons 1 (cons 3 (cons 2 nil)))))))) 192 | 193 | (test-section "association list") 194 | (test* "assq" 195 | '("nori" (Option String)) 196 | (run `(assq :nazuna (acons :yuno "miyako" (acons :nazuna "nori" nil))))) 197 | (test* "assq" 198 | '("none" String) 199 | (run `(none? (assq :hiro (cons (pair :yuno "miyako") (cons (pair :nazuna "nori") nil))) "none" "some"))) 200 | (test* "acons" 201 | '("[ (:yunocchi . miyako) (:yuno . miyako) (:nazuna . nori) ]" 202 | (List (Pair Keyword String))) 203 | (run `(acons :yunocchi "miyako" (acons :yuno "miyako" (acons :nazuna "nori" nil))))) 204 | (test* "alist-copy" 205 | '("[ (:a . yuno) (:b . miyako) ]" (List (Pair Keyword String))) 206 | (run `(alist-copy (acons :a "yuno" (acons :b "miyako" nil))))) 207 | (test* "alist-delete" 208 | '("[ (:b . miyako) ]" (List (Pair Keyword String))) 209 | (run `(alist-delete :a (cons (pair :a "yuno") (cons (pair :b "miyako") nil))))) 210 | 211 | 212 | (test-end :exit-on-failure #t) 213 | --------------------------------------------------------------------------------