├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── README.md ├── examples ├── arithmetic.rkt ├── define.rkt ├── exit.rkt └── two-and-two-make-four.rkt ├── info.rkt ├── lang └── reader.rkt ├── main.rkt ├── private ├── README.md ├── command.rkt └── stack.rkt └── scribblings ├── Makefile ├── README.md └── forth.scrbl /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \.\#* 3 | \#* 4 | *\.swo 5 | *\.swp 6 | compiled/ 7 | 8 | *\.js 9 | *\.css 10 | *\.html 11 | 12 | coverage/ 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | langauge: c 2 | sudo: false 3 | env: 4 | global: 5 | - RACKET_DIR=~/racket 6 | matrix: 7 | - RACKET_VERSION=HEAD 8 | 9 | before_install: 10 | - git clone https://github.com/greghendershott/travis-racket.git ../travis-racket 11 | - cat ../travis-racket/install-racket.sh | bash 12 | - export PATH="${RACKET_DIR}/bin:${PATH}" 13 | 14 | install: raco pkg install --deps search-auto $TRAVIS_BUILD_DIR 15 | 16 | script: 17 | - raco test $TRAVIS_BUILD_DIR 18 | - raco setup --check-pkg-deps forth 19 | 20 | after_success: 21 | - raco pkg install --deps search-auto cover 22 | - raco pkg install --deps search-auto cover-coveralls 23 | - raco cover -f coveralls -d $TRAVIS_BUILD_DIR/coverage -b . 24 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | forth 2 | Copyright (c) 2015-2023 Ben Greenman 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link this package into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Forth 2 | ===== 3 | [![Build Status](https://travis-ci.org/bennn/forth.svg)](https://travis-ci.org/bennn/forth) 4 | [![Scribble](https://img.shields.io/badge/Docs-Scribble-blue.svg)](http://docs.racket-lang.org/forth/index.html) 5 | 6 | Forth language! Implemented as a Racket `#lang`. 7 | 8 | 9 | Install 10 | --- 11 | 12 | From the package server: 13 | ``` 14 | > raco pkg install forth 15 | ``` 16 | 17 | From source: 18 | ``` 19 | > git clone https://github.com/bennn/forth 20 | > raco pkg install ./forth 21 | ``` 22 | 23 | 24 | Usage 25 | --- 26 | 27 | All files starting with `#lang forth` are interpreted as a sequence of Forth commands. 28 | 29 | ``` 30 | #lang forth 31 | 32 | push 2 ;; add `2` to the stack 33 | push 2 34 | + ;; add the top two numbers on the stack 35 | dup ;; duplicate head of stack 36 | 2 ;; short for `push 2` 37 | swap ;; swap order of top 2 stack arguments 38 | - 39 | 40 | : incr 1 + ;; define a new command `incr` 41 | incr 42 | incr 43 | + 44 | ``` 45 | 46 | To open an interactive session, run `raco forth`. 47 | 48 | 49 | `#lang` Details 50 | --- 51 | 52 | Running `raco pkg install forth` installs `forth` as a Racket package. 53 | Since the package contains a directory named `lang/` that contains a file `reader.rkt`, the new package can be used as a `#lang`. 54 | Racket uses to reader defined in `reader.rkt` to process programs that begin with `#lang forth`. 55 | (Official docs [here](http://docs.racket-lang.org/guide/language-collection.html)) 56 | 57 | All `reader.rkt` modules need to provide the functions `read` and `read-syntax`. 58 | These functions must produce a Racket module (docs [here](http://docs.racket-lang.org/guide/hash-lang_reader.html)). 59 | 60 | In this project, `read` just calls `read-syntax`, which reads all lines from the file and interprets them as forth commands. 61 | The interpreting happens during compilation and produces a stack. 62 | After evaluating all commands in the module, our `read-syntax` function returns a module; inside the module, we save the stack to a variable. 63 | Doing so makes the stack available inside the Dr. Racket interactions panel. 64 | 65 | One more thing: this package's `info.rkt` file defines the `raco forth` command. 66 | Docs [here](http://docs.racket-lang.org/raco/command.html).) 67 | -------------------------------------------------------------------------------- /examples/arithmetic.rkt: -------------------------------------------------------------------------------- 1 | #lang forth 2 | 3 | 21 4 | 21 5 | + 6 | 7 | 1 8 | 43 9 | - 10 | 11 | 6 12 | 7 13 | * 14 | 15 | 2 16 | 84 17 | / 18 | -------------------------------------------------------------------------------- /examples/define.rkt: -------------------------------------------------------------------------------- 1 | #lang forth 2 | 3 | : DOUBLE 2 * ; 4 | 5 | 10 6 | DOUBLE 7 | DOUBLE 8 | -------------------------------------------------------------------------------- /examples/exit.rkt: -------------------------------------------------------------------------------- 1 | #lang forth 2 | 3 | 2 4 | 2 5 | 2 6 | + 7 | 2 8 | EXIT 9 | + 10 | + 11 | -------------------------------------------------------------------------------- /examples/two-and-two-make-four.rkt: -------------------------------------------------------------------------------- 1 | #lang forth 2 | 3 | push 2 4 | push 2 5 | + 6 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "forth") 4 | (define deps '("base")) 5 | (define build-deps '( 6 | "scribble-lib" 7 | "racket-doc" 8 | "rackunit-lib" 9 | "rackunit-abbrevs")) 10 | (define pkg-desc "Forth emulator") 11 | (define version "0.1") 12 | (define pkg-authors '(ben)) 13 | (define scribblings '(("scribblings/forth.scrbl" () (omit-start)))) 14 | (define raco-commands '(("forth" (submod forth main) "Open a Forth REPL session" #f))) 15 | -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (rename-out 4 | [forth-read read] 5 | [forth-read-syntax read-syntax])) 6 | 7 | (require 8 | forth/private/command 9 | (only-in syntax/strip-context strip-context)) 10 | 11 | ;; ============================================================================= 12 | 13 | (define (forth-read in) 14 | (syntax->datum (forth-read-syntax #f in))) 15 | 16 | (define (forth-read-syntax src-path in) 17 | ;; Beware, environment would be 3D syntax 18 | (let-values ([(E S) (forth-eval* in)]) 19 | (strip-context 20 | #`(module forth-program racket/base 21 | (require forth/private/stack forth/private/command) 22 | (define stack '#,S) 23 | stack)))) 24 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Running this file with: 4 | ;; `racket main.rkt` 5 | ;; opens a forth repl session. 6 | 7 | (module+ main 8 | (require forth/private/stack forth/private/command) 9 | (forth-repl)) 10 | -------------------------------------------------------------------------------- /private/README.md: -------------------------------------------------------------------------------- 1 | private 2 | === 3 | 4 | Implementation of the Forth emulator. 5 | 6 | The folder name `private` is a Racket convention. 7 | It's a hint to not require the modules here, though there's nothing to stop any module from doing: 8 | 9 | ``` 10 | (require forth/private/stack) 11 | ``` 12 | 13 | and using the undocumented API. 14 | 15 | 16 | Module Summary 17 | --- 18 | - `command.rkt` Implements Forth command parsing & execution 19 | - `stack.rkt` Implements a stack data structure 20 | -------------------------------------------------------------------------------- /private/command.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Forth commands, parsing and executing. 4 | 5 | ;; The evaluator keeps two pieces of state: 6 | ;; - E : an environment of commands 7 | ;; - S : a stack of numbers 8 | 9 | (provide 10 | forth-eval* 11 | ;; (-> Input-Port Stack) 12 | ;; Reads lines from the input port until exhausted. 13 | ;; Each line is interpreted as a Forth command and evaluated with 14 | ;; the current stack & environment. 15 | 16 | forth-repl 17 | ;; (-> Void) 18 | ;; Prompts the user for input, 19 | ;; evaluates the input Forth expression, 20 | ;; updates the current stack and environment, 21 | ;; repeats. 22 | 23 | ;; --- 24 | 25 | ;; type Env = Listof Command 26 | ) 27 | 28 | ;; ----------------------------------------------------------------------------- 29 | 30 | (require 31 | racket/match 32 | forth/private/stack 33 | (only-in racket/list drop-right last) 34 | (only-in racket/string string-join string-split) 35 | (only-in racket/port with-input-from-string) 36 | (for-syntax racket/base racket/syntax syntax/parse) 37 | ) 38 | 39 | ;; ============================================================================= 40 | ;; -- Commands 41 | 42 | ;; A Forth command is implemented as a callable struct. 43 | ;; For example: 44 | ;; (define f (lambda arg* ...)) 45 | ;; (define c (command 'hello f "A simple command")) 46 | ;; (c 4) 47 | ;; Calls the command struct `c` with the argument 4. 48 | ;; Normally calling a struct is an error, but since we declared `command` 49 | ;; with the property `prop:procedure`, the call gets redirected to the struct 50 | ;; field `exec`. i.e. `(c 4)` is the same as `(f 4)`. 51 | 52 | (struct command ( 53 | id ;; : Symbol 54 | exec ;; : (-> Env State Any (U 'EXIT #f (Pairof Env State))) 55 | descr ;; : String 56 | ) #:transparent 57 | #:property prop:procedure 58 | (struct-field-index exec)) 59 | ;; (define-type Command command) 60 | 61 | ;; True if the argument is a list with one element 62 | (define (singleton-list? v) 63 | (and (list? v) 64 | (not (null? v)) 65 | (null? (cdr v)))) 66 | 67 | ;; Create a binary operation command. 68 | ;; Command is recognized by its identifier, 69 | ;; the identifier is then applied to the top 2 numbers on the stack. 70 | (define-syntax binop-command 71 | (syntax-parser 72 | [(_ name:id doc:str) 73 | #:with name-sym (syntax->datum #'name) 74 | #'(command 'name-sym 75 | (lambda (E S v) 76 | (and (singleton-list? v) 77 | (eq? 'name-sym (car v)) 78 | (let*-values ([(v1 S1) (stack-pop S)] 79 | [(v2 S2) (stack-pop S1)]) 80 | (cons E (stack-push S2 (name v2 v1)))))) 81 | doc)])) 82 | 83 | ;; Turns a symbol into a stack command parser 84 | (define-syntax stack-command 85 | (syntax-parser #:literals (quote) 86 | [(_ (quote cmd:id) doc:str) 87 | #:with stack-cmd (format-id #'cmd "stack-~a" (syntax->datum #'cmd)) 88 | #'(command 'cmd 89 | (lambda (E S v) 90 | (and (singleton-list? v) 91 | (eq? 'cmd (car v)) 92 | (cons E (stack-cmd S)))) 93 | doc)])) 94 | 95 | ;; Default environment of commands 96 | (define CMD* (list 97 | (command 98 | 'exit 99 | (lambda (E S v) 100 | (if (or (eof-object? v) 101 | (and (symbol? v) 102 | (exit? v)) 103 | (and (list? v) 104 | (not (null? v)) 105 | (exit? (car v)))) 106 | 'EXIT 107 | #f)) 108 | "End the REPL session") 109 | (command 110 | 'help 111 | (lambda (E S v) 112 | (cond 113 | [(and (symbol? v) (help? v)) 114 | (displayln (show-help E)) 115 | (cons E S)] 116 | [(and (list? v) (not (null? v)) (help? (car v))) 117 | (displayln (show-help E (and (not (null? (cdr v))) (cdr v)))) 118 | (cons E S)] 119 | [else 120 | #f])) 121 | "Print help information") 122 | (binop-command + "Add the top two numbers on the stack") 123 | (binop-command - "Subtract the top item of the stack from the second item.") 124 | (binop-command * "Multiply the top two item on the stack.") 125 | (binop-command / "Divide the top item of the stack by the second item.") 126 | (stack-command 'drop "Drop the top item from the stack") 127 | (stack-command 'dup "Duplicate the top item of the stack") 128 | (stack-command 'over "Duplicate the top item of the stack, but place the duplicate in the third position of the stack.") 129 | (stack-command 'swap "Swap the first two numbers on the stack") 130 | (command 131 | 'push 132 | (lambda (E S v) 133 | (match v 134 | [`(push ,(? number? n)) 135 | (cons E (stack-push S n))] 136 | [`(,(? number? n)) 137 | (cons E (stack-push S n))] 138 | [_ #f])) 139 | "Push a number onto the stack") 140 | (command 141 | 'show 142 | (lambda (E S v) 143 | (match v 144 | [`(,(? show?)) 145 | (displayln S) 146 | (cons E S)] 147 | [_ #f])) 148 | "Print the current stack") 149 | (command 150 | 'define 151 | (lambda (E S v) 152 | (match v 153 | [(cons (or ': 'define) (cons w pre-defn*)) 154 | (define defn* 155 | (if (eq? '|;| (last pre-defn*)) 156 | (drop-right pre-defn* 1) 157 | pre-defn*)) 158 | (define cmd 159 | (command w 160 | (lambda (E S v) 161 | (if (equal? v (list w)) 162 | (let-values ([(e+ s+) 163 | (for/fold ([e E] [s S]) 164 | ([d (in-list defn*)]) 165 | (forth-eval e s (list d)))]) 166 | (cons e+ s+)) 167 | #f)) 168 | (format "~a" defn*))) 169 | (cons (cons cmd E) S)] 170 | [_ #f])) 171 | "Define a new command as a sequence of existing commands") 172 | )) 173 | 174 | ;; (: exit? (-> Any Boolean)) 175 | (define (exit? sym) 176 | (memq sym '(exit quit q leave bye))) 177 | 178 | ;; Search the environment for a command with `id` equal to `sym` 179 | (define (find-command E sym) 180 | (for/first ([c (in-list E)] 181 | #:when (eq? sym (command-id c))) 182 | c)) 183 | 184 | ;; (: help? (-> Any Boolean)) 185 | (define (help? sym) 186 | (memq sym '(help ? ??? -help --help h))) 187 | 188 | ;; (: show? (-> Any Boolean)) 189 | (define (show? sym) 190 | (memq sym '(show print pp ls stack))) 191 | 192 | ;; Print a help message. 193 | ;; If the optional argument is given, try to print information about it. 194 | (define (show-help E [v #f]) 195 | (match v 196 | [#f 197 | (string-join 198 | (for/list ([c (in-list E)]) 199 | (format " ~a : ~a" (command-id c) (command-descr c))) 200 | "\n" 201 | #:before-first "Available commands:\n")] 202 | [(or (list (? symbol? s)) 203 | (? symbol? s)) 204 | (define c (find-command E s)) 205 | (if c 206 | (command-descr c) 207 | (format "Unknown command '~a'" s))] 208 | [x 209 | (format "Cannot help with '~a'" x)])) 210 | 211 | ;; ----------------------------------------------------------------------------- 212 | 213 | ;; The machinery for running commands. 214 | ;; Parses strings & ports to S-expressions, 215 | ;; and feeds those expressions to the structs in the command environment. 216 | 217 | ;; (: forth-eval* (-> Input-Port Stack)) 218 | (define (forth-eval* in) 219 | (for/fold ([e CMD*] 220 | [s (stack-init)]) 221 | ([ln (in-lines in)]) 222 | (define token* (forth-tokenize ln)) 223 | (cond 224 | [(or (null? token*) 225 | (not (list? e))) ;; Cheap way to detect EXIT 226 | (values e s)] 227 | [else 228 | (forth-eval e s token*)]))) 229 | 230 | ;; (: forth-repl (->* [] [Env Stack] Void)) 231 | (define (forth-repl [E CMD*] [S (stack-init)]) 232 | (display "forth> ") 233 | (define token* (forth-tokenize (read-line))) 234 | (if (null? token*) 235 | (displayln S) 236 | (let-values ([(E+ S+) (forth-eval E S token*)]) 237 | (if (not (list? E+)) 238 | (displayln S+) 239 | (forth-repl E+ S+))))) 240 | 241 | ;; (: forth-eval (-> Env Stack (Listof Any) (Values (U Env #f) Stack))) 242 | (define (forth-eval E S token*) 243 | (match (for/or ([c (in-list E)]) (c E S token*)) 244 | ['EXIT 245 | (values #f S)] 246 | [#f 247 | ;; TODO suggest command 248 | (printf "Unrecognized command '~a'.\n" token*) 249 | (values E S)] 250 | [E+S 251 | (values (car E+S) (cdr E+S))])) 252 | 253 | ;; (: forth-tokenize (-> String (Listof Any))) 254 | (define (forth-tokenize str) 255 | (for/list ([word (in-list (string-split str))]) 256 | (define n (string->number word)) 257 | (or n (string->symbol (string-downcase word))))) 258 | 259 | ;; ============================================================================= 260 | 261 | ;; Unit tests. Run these with: 262 | ;; raco test command.rkt 263 | 264 | (module+ test 265 | (require 266 | rackunit 267 | rackunit-abbrevs 268 | (only-in racket/format ~a)) 269 | 270 | ;; -- exit? 271 | (check-true* (lambda (x) (if (exit? x) #t #f)) 272 | ['exit] 273 | ['quit] 274 | ['q]) 275 | 276 | (check-false* exit? 277 | ['()] 278 | [#f] 279 | [53] 280 | ['hello]) 281 | 282 | ;; -- find-command 283 | (check-true* (lambda (sym) (eq? sym (command-id (find-command CMD* sym)))) 284 | ['exit] 285 | ['dup] 286 | ['+]) 287 | 288 | (check-false* (lambda (sym) (if (find-command CMD* sym) #t #f)) 289 | ['hi] 290 | ['hi] 291 | ["yes"] 292 | [00]) 293 | 294 | ;; -- help? 295 | (check-true* (lambda (v) (if (help? v) #t #f)) 296 | ['help] 297 | ['?] 298 | ['--help]) 299 | 300 | (check-false* help? 301 | ['exit] 302 | [#f] 303 | ['q] 304 | [21]) 305 | 306 | ;; -- show? 307 | (check-true* (lambda (v) (if (show? v) #t #f)) 308 | ['show] 309 | ['ls] 310 | ['print]) 311 | 312 | (check-false* help? 313 | ['exit] 314 | [#f] 315 | ['q] 316 | [12]) 317 | 318 | ;; -- show-help 319 | (check-equal? (length (string-split (show-help CMD*) "\n")) (+ 1 (length CMD*))) 320 | (check-equal? (length (string-split (show-help CMD* #f) "\n")) (+ 1 (length CMD*))) 321 | (check-regexp-match #rx"^Cannot help" (show-help CMD* "booo")) 322 | (check-regexp-match #rx"^Unknown command" (show-help CMD* 'booo)) 323 | (check-regexp-match #rx"^Print help" (show-help CMD* 'help)) 324 | 325 | ;; -- forth-eval* 326 | (let* ([eval* (lambda (v*) 327 | (with-input-from-string (string-join (map ~a v*) "\n") 328 | (lambda () (forth-eval* (current-input-port)))))] 329 | [eval/stack (lambda (v*) (let-values ([(e s) (eval* v*)]) s))]) 330 | (check-apply* eval/stack 331 | ['(1 2 3) 332 | == '(3 2 1)] 333 | ['(1 1 +) 334 | == '(2)] 335 | ['(2 1 -) 336 | == '(1)] 337 | ['(8 8 8 * *) 338 | == '(512)] 339 | ['(2 1 3 /) 340 | == '(1/3 2)] 341 | ['(1 0 EXIT /) 342 | == '(0 1)] 343 | ['(": dup3 dup dup dup" 1 2 dup3) 344 | == '(2 2 2 2 1)] 345 | ['(1 2 drop) 346 | == '(1)] 347 | ['(1 2 3 over) 348 | == '(3 2 3 1)] 349 | ['(1 0 swap) 350 | == '(1 0)] 351 | ['(": switcheroo swap swap" 5 6 switcheroo switcheroo) 352 | == '(6 5)] 353 | ['("push 1" "push 2" +) 354 | == '(3)])) 355 | 356 | ;; -- forth-eval 357 | (let* ([S '(2 4 8)] 358 | [E CMD*] 359 | [eval/stack (lambda (token*) 360 | (let-values ([(e s) (forth-eval E S token*)]) s))]) 361 | (check-apply* eval/stack 362 | [#f 363 | == S] 364 | ['nada 365 | == S] 366 | ['(exit) 367 | == S] 368 | ['(help) 369 | == S] 370 | ['(: hi 3 2 1) 371 | == S] 372 | ['(+) 373 | == '(6 8)] 374 | ['(-) 375 | == '(2 8)] 376 | ['(*) 377 | == '(8 8)] 378 | ['(/) 379 | == '(2 8)] 380 | ['(drop) 381 | == (stack-drop S)] 382 | ['(dup) 383 | == (stack-dup S)] 384 | ['(over) 385 | == (stack-over S)] 386 | ['(swap) 387 | == (stack-swap S)] 388 | ['(1) 389 | == (stack-push S 1)] 390 | ['(push 8) 391 | == (stack-push S 8)] 392 | ['(show) 393 | == S])) 394 | 395 | (let* ([S '(6 6 6)] 396 | [E CMD*] 397 | [L (length E)] 398 | [eval/env-length (lambda (token*) 399 | (let-values ([(e s) (forth-eval E S token*)]) (length e)))]) 400 | (check-apply* eval/env-length 401 | ['(2) 402 | == L] 403 | ['(: new dup drop swap) 404 | == (+ 1 L)] 405 | ['(swap) 406 | == L])) 407 | 408 | ;; -- forth-tokenize 409 | (check-apply* forth-tokenize 410 | ["hello world" == '(hello world)] 411 | ["Hello WORLD" == '(hello world)] 412 | [": key val val val;" == '(: key val val |val;|)] 413 | [": key val val val ;" == '(: key val val val |;|)] 414 | [": DOUBLE 2 *;" == '(: double 2 |*;|)] 415 | ["1 2 3" == '(1 2 3)]) 416 | 417 | ) 418 | -------------------------------------------------------------------------------- /private/stack.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Forth stacks, 4 | ;; data definition & operations 5 | 6 | (provide 7 | ;; type Stack = List 8 | ;; 9 | ;; Notation: 10 | ;; [] = empty stack 11 | ;; x::xs = item 'x' on top of the stack 'xs' 12 | ;; 13 | ;; Operations will raise an exception with message "empty stack" 14 | ;; if called on a stack with too few elements. 15 | 16 | stack-drop 17 | ;; (-> x::xs xs) 18 | ;; Drop the item on top of the stack 19 | 20 | stack-dup 21 | ;; (-> x::xs x::x::xs) 22 | ;; Duplicate the item on top of the stack 23 | 24 | stack-init 25 | ;; (-> Stack) 26 | ;; Initialize an empty stack 27 | 28 | stack-over 29 | ;; (-> x::y::xs x::y::x::xs) 30 | ;; Duplicate the item on top of the stack, but place the duplicate 31 | ;; after the 2nd item on the stack. 32 | 33 | stack-pop 34 | ;; (-> x::xs (Values x xs)) 35 | ;; Pop the top item from the stack, return both the item and the new stack. 36 | 37 | stack-push 38 | ;; (-> xs x x::xs) 39 | ;; Push an item on to the stack 40 | 41 | stack-swap 42 | ;; (-> x::y::xs y::x::xs) 43 | ;; Swap the positions of the first 2 items on the stack. 44 | ) 45 | 46 | ;; ============================================================================= 47 | 48 | (define (list->stack xs) 49 | (for/fold ([S (stack-init)]) 50 | ([x (in-list (reverse xs))]) 51 | (stack-push S x))) 52 | 53 | (define (stack-drop S) 54 | (let-values ([(_v S+) (stack-pop S)]) 55 | S+)) 56 | 57 | (define (stack-dup S) 58 | (let-values ([(v S+) (stack-pop S)]) 59 | (stack-push (stack-push S+ v) v))) 60 | 61 | (define (stack-init) 62 | '()) 63 | 64 | (define (stack-over S) 65 | (let*-values ([(v1 S1) (stack-pop S)] 66 | [(v2 S2) (stack-pop S1)]) 67 | (stack-push (stack-push (stack-push S2 v1) v2) v1))) 68 | 69 | (define (stack-pop S) 70 | (if (null? S) 71 | (raise-user-error "empty stack") 72 | (values (car S) (cdr S)))) 73 | 74 | (define (stack-push S v) 75 | (cons v S)) 76 | 77 | (define (stack-swap S) 78 | (let*-values ([(v1 S1) (stack-pop S)] 79 | [(v2 S2) (stack-pop S1)]) 80 | (stack-push (stack-push S2 v1) v2))) 81 | 82 | ;; ============================================================================= 83 | 84 | (module+ test 85 | 86 | (require rackunit) 87 | 88 | (define exn-rx #rx"empty stack") 89 | 90 | (define-syntax-rule (check-stack-exn e) 91 | (check-exn exn-rx (lambda () e))) 92 | 93 | (let ([S (list->stack '(1 2))]) 94 | ;; -- drop 95 | (check-equal? (stack-drop S) (list->stack '(2))) 96 | (check-equal? (stack-drop (stack-drop S)) (list->stack '())) 97 | (check-stack-exn (stack-drop (stack-drop (stack-drop S)))) 98 | ;; -- dup 99 | (check-equal? (stack-dup S) (list->stack '(1 1 2))) 100 | (check-equal? (stack-dup (stack-drop S)) (list->stack '(2 2))) 101 | (check-stack-exn (stack-dup (stack-init))) 102 | ;; -- init 103 | (check-equal? (stack-init) (list->stack '())) 104 | ;; -- over 105 | (check-equal? (stack-over S) (list->stack '(1 2 1))) 106 | (check-stack-exn (stack-over (stack-drop S))) 107 | (check-stack-exn (stack-over (stack-init))) 108 | ;; -- pop 109 | (let-values ([(v S2) (stack-pop S)]) 110 | (check-equal? v 1) 111 | (check-equal? S2 (list->stack '(2)))) 112 | (check-stack-exn (stack-pop (stack-drop (stack-drop S)))) 113 | (check-stack-exn (stack-pop (stack-init))) 114 | ;; -- push 115 | (check-equal? (stack-push S 4) (list->stack '(4 1 2))) 116 | (check-equal? (stack-push (stack-init) 6) (list->stack '(6))) 117 | ;; -- swap 118 | (check-equal? (stack-swap S) (list->stack '(2 1))) 119 | (check-equal? (stack-swap (stack-swap S)) S) 120 | (check-stack-exn (stack-swap (stack-drop S))) 121 | (check-stack-exn (stack-swap (stack-init)))) 122 | 123 | ) 124 | -------------------------------------------------------------------------------- /scribblings/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | raco scribble \ 3 | --html \ 4 | ++main-xref-in \ 5 | --redirect-main http://docs.racket-lang.org/ \ 6 | forth.scrbl 7 | 8 | clean: 9 | rm -rf compiled 10 | rm *.css 11 | rm *.js 12 | rm *.html 13 | -------------------------------------------------------------------------------- /scribblings/README.md: -------------------------------------------------------------------------------- 1 | scribblings 2 | === 3 | 4 | Documentation for the Forth package. 5 | Run `make` to build the document `forth.html`. 6 | -------------------------------------------------------------------------------- /scribblings/forth.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[racket/include] 3 | @require[scribble/eval] 4 | 5 | @; TODO can we use the REPL in examples? 6 | @(define forth-eval (make-base-eval '(require forth/private/command))) 7 | 8 | @title[#:tag "top"]{Forth} 9 | @author[@hyperlink["https://github.com/bennn"]{Ben Greenman}] 10 | 11 | @defmodule[forth] 12 | 13 | @hyperlink["https://en.wikipedia.org/wiki/Forth_(programming_language)"]{Forth} is a stack-based calculator language. 14 | This package implements a subset of Forth as a Racket @tt{#lang}. 15 | 16 | @section{Install} 17 | 18 | To install from the package server, run: 19 | @racketblock[ 20 | raco pkg install forth 21 | ] 22 | 23 | To install from source, run: 24 | @racketblock[ 25 | git clone https://github.com/bennn/forth 26 | raco pkg install ./forth 27 | ] 28 | 29 | 30 | @section{Usage} 31 | 32 | Files starting with @tt{#lang forth} are interpreted as a newline-separated sequence of commands. 33 | Alternatively, run @tt{raco forth} to start an interactive session. 34 | 35 | 36 | @section{Commands} 37 | 38 | These commands are the base environment, but the list of commands can grow as a program runs. 39 | Type @tt{help} at any time to see the currently available commands. 40 | 41 | @defform[(exit)]{ 42 | End the program or REPL session immediately. 43 | } 44 | 45 | @defform[(help maybe-cmd)]{ 46 | If no arguments is given, print the current list of commands. 47 | Otherwise, print known information about the symbol @racket[maybe-cmd]. 48 | } 49 | 50 | @defform[(+ - * /)]{ 51 | Pop the top two values from the stack, perform an arithmetic operation, push the result back on the stack. 52 | } 53 | 54 | @defform[(drop)]{ 55 | Delete the top item from the stack. 56 | } 57 | 58 | @defform[(dup)]{ 59 | Duplicate the top item of the stack. 60 | } 61 | 62 | @defform[(over)]{ 63 | Duplicate the top item of the stack, but save the result as the 3rd item on the stack. 64 | } 65 | 66 | @defform[(swap)]{ 67 | Switch the positions of the top two items on the stack. 68 | } 69 | 70 | @defform*[((push N) N)]{ 71 | Put the number @racket[N] on the stack. 72 | } 73 | 74 | @defform[(show)]{ 75 | Print the current stack. 76 | } 77 | 78 | @defform[(: id cmd* ...)]{ 79 | Define a new command with name @racket[id] as the composition of existing commands @racket[cmd* ...]. 80 | Later calls to @racket[id] will execute the commands @racket[cmd* ...] in sequence, and later calls to @racket[help] will display information about @racket[id]. 81 | } 82 | 83 | @section{Example} 84 | 85 | Running this program should produce the list @racket[(4 2)]. 86 | Forth programs always return their final stack. 87 | Note that @racket["push 2"] and @racket["2"] have the same effect. 88 | 89 | @(racketmod forth 90 | 91 | push 2 92 | push 2 93 | + 94 | dup 95 | 2 96 | swap 97 | - 98 | swap 99 | 100 | : incr 1 + 101 | incr 102 | incr 103 | + 104 | ) 105 | --------------------------------------------------------------------------------