Commits

Rohin Shah  committed c34ed9c

More refactoring, removed a bunch of dead code

  • Participants
  • Parent commits b9b5180

Comments (0)

Files changed (7)

File ArrayForth/arrayforth.rkt

 
 (provide compile compile-and-run compile-to-vector compile-to-string)
 
-(add-compiler-directives!)
+(add-directives!)
 (add-bit-words!)
 (add-control-words!)
 (add-io-words!)

File ArrayForth/classes.rkt

 	   (set 'pc (* 4 addr))
 	   (set 'next-word (add1 addr)))
 
-	 (define/public (execute-code addr)
-	   ; pc will be the address of the next instruction to execute
-	   (push-int! (get 'rstack) (inexact->exact (ceiling (/ (get 'pc) 4))))
-	   (set-pc! addr))
-
-	 (define/public (execute entry)
-	   (execute-code (entry-code entry)))
-
 	 (define/public (single-step core)
 	   (set 'state-index core)
 	   (let [(memory (get 'memory))
 		 (pc (get 'pc))]
 	     (if (or (< pc 0) (>= pc (rvector-length memory)))
 		 (set 'used-cores (remove core (get 'used-cores)))
-		 (let [(code (read-and-increment-pc!))]
-		   (unless (string? code)
+		 (let [(name (read-and-increment-pc!))]
+		   (unless (string? name)
 			   (raise "Not a string -- single-step"))
-		   (let [(proc (rvector-ref codespace (entry-code (find-entry dict code))))]
-		     (if (member code address-required)
+		   (let [(proc (get-instruction-proc name))]
+		     (if (member name address-required)
 			 (proc this (read-and-increment-pc!))
 			 (proc this)))))))
 
 	   (unless (null? (get 'used-cores))
 		   (interpret)))))
 
-(define codespace (make-rvector 100 -1))
-(define dict (make-rvector 500 -1))
-(define compiler-directives (make-rvector 100 -1))
-
-(define (add-entry! prim name code)
-  (let [(new (entry prim name code))]
-    (add-element! dict new)
-    new))
-
-(define (add-primitive-code! elmt)
-  (add-element! codespace elmt))
-
-(define (add-word! prim name)
-  (add-entry! prim name (rvector-length codespace)))
-
-(define (add-primitive-word! name code)
-  (add-word! #t name)
-  (add-primitive-code! code))
-
-; Adds a new compiler directive - something that is executed
-(define (add-compiler-directive! name code)
-  (add-element! compiler-directives
-		(entry #t name (rvector-length codespace)))
-  (add-primitive-code! code))
-
-(define (make-synonym a b)
-  (let [(a-dir (find-entry dict a))
-	(b-dir (find-entry dict b))]
+(define instructions (make-hash))
+(define (is-instruction? name)
+  (hash-has-key? instructions name))
+(define (add-instruction! name code)
+  (hash-set! instructions name code))
+(define (get-instruction-proc name)
+  (and (is-instruction? name)
+       (hash-ref instructions name)))
+
+; Compiler directive - something that is executed at compile time
+(define directives (make-hash))
+(define (is-directive? name)
+  (hash-has-key? directives name))
+(define (add-directive! name code)
+  (hash-set! directives name code))
+(define (get-directive-proc name)
+  (and (is-directive? name)
+       (hash-ref directives name)))
+
+(define (make-instruction-synonym a b)
+  (let [(a-present (is-instruction? a))
+	(b-present (is-instruction? b))]
     ; If both are defined, or neither is defined, error.
-    (cond [(or (and a-dir b-dir) (not (or a-dir b-dir)))
+    (cond [(or (and a-present b-present) (not (or a-present b-present)))
 	   (raise "Cannot make synonym")]
-	  [a-dir (add-entry! (entry-primitive a-dir) b (entry-code a-dir))]
-	  [else (add-entry! (entry-primitive b-dir) a (entry-code b-dir))])))
-
-; Entry for the dictionary.
-; Code must be mutable to allow procs which refer to the entry itself.
-(struct entry (primitive name code))
+	  [a-present
+	   (add-instruction! b (hash-ref instructions a))]
+	  [else
+	   (add-instruction! a (hash-ref instructions b))])))
 
 (define compiler%
   (class object%
 
 	 (field (location-counter 1)
 		(i-register 0)
+		(dict (make-hash))
 		(execute? #f)
 		(dstack (make-infinite-stack))
-		(lit-entry 0)
 		(interpreter (new interpreter%)))
 
 	 ; Note: It is important that we look in this object before the
 	 (define/public (increment-pc!)
 	   (send interpreter increment-pc!))
 
+	 (define/public (add-word! name code)
+	   (hash-set! dict name code))
+
+	 (define/public (get-word-address name)
+	   (and (hash-has-key? dict name)
+		(hash-ref dict name)))
+
 	 (define/public (add-compiled-data! data)
 	   (let [(memory (get 'memory))
 		 (i-register (get 'i-register))]
 	    [else #f]))
 
 	 (define/public (compile-loop)
-	   (let [(to-compile (forth_read))]
-	     (unless (eof-object? to-compile)
-		     (unless (eq? to-compile #\newline)
-			     (let [(directive (find-entry compiler-directives to-compile))]
-			       (if directive
-				   ((rvector-ref codespace (entry-code directive)) this)
-				   (let [(entry (find-entry dict to-compile))]
-				     (cond [(not entry)
-					    (let [(num (or (port->number to-compile) 
-							   (string->bytes to-compile)))]
-					      (if num
-						  (if execute?
-						      (push-cells! (get 'dstack) num)
-						      (compile-constant! num))
-						  (raise (string-append to-compile " ?"))))]
-					   [execute?
+	   (let [(token (forth_read))]
+	     (unless (eof-object? token)
+		     (unless (eq? token #\newline)
+			     (compile-token token))
+		     (compile-loop))))
+
+	 (define/public (compile-token token)
+	   (let [(directive (get-directive-proc token))
+		 (instruction (get-instruction-proc token))
+		 (address (get-word-address token))]
+	     (cond [directive
+		    (directive this)]
+		   [(and instruction execute?)
 ; Assume that it is not an instruction that requires an address as an argument
-					    ((rvector-ref codespace (entry-code entry)) (get 'interpreter))]
-					   [(member to-compile address-required-on-dstack)
-					    (when (= (remainder i-register 4) 3)
-						  (fill-rest-with-nops))
-					    (add-compiled-code! to-compile)
-					    (compile-address! (pop-int! dstack #f))
-					    (fill-rest-with-nops)]
-					   [(entry-primitive entry)
-					    (add-compiled-code! to-compile)
-					    (when (member to-compile instructions-using-entire-word)
-						  (fill-rest-with-nops))]
-					   [else
-					    (let [(nxt (forth_read))]
+		    (instruction (get 'interpreter))]
+		   [instruction
+		    (add-compiled-code! token)
+		    (when (member token instructions-using-entire-word)
+			  (fill-rest-with-nops))]
+		   [address
+		    (let [(nxt (forth_read))]
 ; TODO: Check if address can fit.  For now, don't put jump/call in last slot.
 ; This is already taken care of by add-compiled-code!
-					      (if (equal? nxt ";")
-						  (add-compiled-code! "jump")
-						  (begin (forth_read 'put-back nxt)
-							 (add-compiled-code! "call")))
+		      (if (equal? nxt ";")
+			  (add-compiled-code! "jump")
+			  (begin (forth_read 'put-back nxt)
+				 (add-compiled-code! "call")))
 ; Compile the address.  Automatically compiles #f into the rest of the word.
-					      (compile-address! (entry-code entry)))])))))
-	      (compile-loop))))))
-
+		      (compile-address! address))]
+		   [else
+		    (let [(num (or (port->number token) 
+				   (string->bytes token)))]
+		      (if num
+			  (if execute?
+			      (push-cells! (get 'dstack) num)
+			      (compile-constant! num))
+			  (raise (string-append token " ?"))))])))))
 
 ; Stacks
 (define push-cells! push!)
 (define (get-int stack signed? [pos 0])
   (integer-bytes->integer (get-cells stack pos) signed? #t))
 
-; Debugging
-
 (define (print-stack stack)
   (define (loop pos)
     (print (get-int stack #t pos))
   (display "| ")
   (loop (sub1 (stack-length stack)))
   (display ">"))
-
-(define (find-address d name)
-  (define (loop address)
-    (let [(word (rvector-ref d address))]
-      (cond [(equal? name (entry-name word)) address]
-            [(= address 0) #f]
-            [else (loop (sub1 address))])))
-  (let ((len (rvector-length d)))
-    (if (= len 0)
-	#f
-	(loop (sub1 len)))))
-
-(define (find-entry d name)
-  (let [(address (find-address d name))]
-    (if address
-        (rvector-ref d address)
-        #f)))
-
-(define (lookup key records)
-  (cond ((null? records) #f)
-	((equal? key (caar records)) (cdar records))
-	(else (lookup key (cdr records)))))

File ArrayForth/compiler_directives.rkt

 
 (require "classes.rkt" "forth_read.rkt" "rvector.rkt")
 
-(provide add-compiler-directives!)
+(provide add-directives!)
 
 ; Compiler directives
 
-(define (add-compiler-directives!)
-  (add-compiler-directive!
+(define (add-directives!)
+  (add-directive!
    "node"
    (lambda (compiler)
      (send compiler set 'state-index
      (send compiler set 'location-counter 1)
      (send compiler set 'i-register 0)))
 
-  (add-compiler-directive!
+  (add-directive!
    "org"
    (lambda (compiler)
      (send compiler set 'location-counter
      (send compiler set 'i-register
 	   (* 4 (sub1 (send compiler get 'location-counter))))))
 
-  (add-compiler-directive!
+  (add-directive!
    "yellow"
    (lambda (compiler) (send compiler set 'execute? #t)))
 
-  (add-compiler-directive!
+  (add-directive!
    "green"
    (lambda (compiler) (send compiler set 'execute? #f)))
 
-  (add-compiler-directive!
+  (add-directive!
    ":"
    (lambda (compiler)
      (send compiler fill-rest-with-nops)
-     (add-entry! #f (forth_read_no_eof)
-		 (quotient (send compiler get 'i-register) 4))))
+     (send compiler add-word!
+	   (forth_read_no_eof)
+	   (quotient (send compiler get 'i-register) 4))))
 
-  (add-compiler-directive!
+  (add-directive!
    ".."
    (lambda (compiler) (send compiler fill-rest-with-nops)))
 
   ; Custom addition to make it easy to specify where to start programs.
-  (add-compiler-directive!
+  (add-directive!
    "start"
    (lambda (compiler)
      (send compiler set-pc! (sub1 (send compiler get 'location-counter)))
   (define (comment compiler)
     (unless (equal? (read-char) #\))
 	    (comment compiler)))
-  (add-compiler-directive! "(" comment)
+  (add-directive! "(" comment)
 
   ; ,
-  (add-compiler-directive!
+  (add-directive!
    ","
    (lambda (compiler)
      (let [(data (pop-cells! (send compiler get 'dstack)))]
     (send compiler fill-rest-with-nops)
     (push-int! (send compiler get 'dstack)
 	       (quotient (send compiler get 'i-register) 4)))
-  (add-compiler-directive! "begin" begin-proc)
+  (add-directive! "begin" begin-proc)
   
-  (add-compiler-directive!
+  (add-directive!
    "for"
    (lambda (compiler)
      (send compiler add-compiled-code! "push")
      (begin-proc compiler)))
 
   ; next, when seen in the compiler
-  (add-compiler-directive!
+  (add-directive!
    "next"
    (lambda (compiler)
      (let [(addr (pop-int! (send compiler get 'dstack) #f))]

File ArrayForth/forth_bit_words.rkt

 (define false 0)
 
 (define (add-bit-words!)
-  (add-primitive-word!
+  (add-instruction!
    "and" ; bitwise and
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
 	    (arg2 (pop-int! dstack #t))]
        (push-int! dstack (bitwise-and arg1 arg2)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "or" ; bitwise exclusive or
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
 	    (arg2 (pop-int! dstack #t))]
        (push-int! dstack (bitwise-xor arg1 arg2)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "-" ; invert (bitwise negation)
    (lambda (i)
      (let [(dstack (send i get 'dstack))]
 ; Math
 
 ; Addition - adds 2 ints, pushes it back onto the stack.  Treated as signed, but works for unsigned as well.
-  (add-primitive-word!
+  (add-instruction!
    "+"
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
 	(push-int! dstack (+ (bitwise-and t 131072)
 			     (quotient (bitwise-and t 262143) 2))))))
 
-  (add-primitive-word! "+*" multiply-step-proc)
+  (add-instruction! "+*" multiply-step-proc)
 
-  (add-primitive-word!
+  (add-instruction!
    "2*"
    (lambda (i)
      (let [(dstack (send i get 'dstack))]
        (push-int! dstack (* (pop-int! dstack #t) 2)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "2/"
    (lambda (i)
      (let [(dstack (send i get 'dstack))]
        (push-int! dstack (/ (pop-int! dstack #t) 2)))))
 
-  (add-primitive-word! "." (lambda (i) (void)))
-  (make-synonym "." "nop"))
+  (add-instruction! "." (lambda (i) (void)))
+  (make-instruction-synonym "." "nop"))

File ArrayForth/forth_control_words.rkt

 ; Return
 ; Moves R into P, popping the return stack.
 ; As a result, it skips any remaining slots and fetches next instruction word.
-  (add-primitive-word!
+  (add-instruction!
    ";" 
    (lambda (i)
      (send i set-pc! (pop-int! (send i get 'rstack) #f))))
-  (make-synonym ";" "ret")
+  (make-instruction-synonym ";" "ret")
 
 ; Execute
 ; Exchanges R and P.
 ; As a result, it skips any remaining slots and fetches next instruction word.
-  (add-primitive-word!
+  (add-instruction!
    "ex"
    (lambda (i)
      (let [(temp (send i get 'pc))
 ; Jump
 ; Sets P to destination address
 ; As a result, it fetches next instruction word.
-  (add-primitive-word!
+  (add-instruction!
    "jump"
    (lambda (i addr) (send i set-pc! addr)))
 
 ; Moves P into R, pushing an item onto the return stack,
 ; Sets P to destination address 
 ; As a result, it fetches next instruction word.
-  (add-primitive-word!
+  (add-instruction!
    "call"
    (lambda (i addr)
      (let [(pc (send i get 'pc))
 ; If R is zero, pops the return stack and continues with the next opcode.
 ; If R is nonzero, decrements R by 1 and causes execution to continue with slot 0 of the current instruction word
 ; This is done without re-fetching the word (irrelevant here).
-  (add-primitive-word!
+  (add-instruction!
    "unext"
    (lambda (i)
      (let* [(rstack (send i get 'rstack))
 ; next
 ; If R is zero, pops the return stack and continues with the next instruction word addressed by P.
 ; If R is nonzero, decrements R by 1 and jumps to the given address.
-  (add-primitive-word!
+  (add-instruction!
    "next"
    (lambda (i addr)
      (let* [(rstack (send i get 'rstack))
 		    (set! pc (add1 pc)))))
     (push-int! dstack location-counter)
     (add-primitive-code! dummy-proc))
-  (add-primitive-word! #t "if" if-proc)
+  (add-instruction! #t "if" if-proc)
 
 ; -IF
 ; 1. Puts a procedure which jumps over one slot if the top of stack is negative.
                   (set! pc (add1 pc)))))
   (push-int! dstack location-counter)
   (add-primitive-code! dummy-proc))
-(add-primitive-word! #t "-if" nif-proc)
+(add-instruction! #t "-if" nif-proc)
 
 ; THEN
 ; Put an unconditional branch to HERE.
 (define (then-proc)
   (let [(here-addr location-counter)]
     (rvector-set! codespace (pop-int! dstack #f) (lambda () (set! pc here-addr)))))
-(add-primitive-word! #t "then" then-proc)
+(add-instruction! #t "then" then-proc)
 
 
 ; Loops
 		  (pop-int! rstack #t))
            (begin (push-int! rstack (add1 (pop-int! rstack #t)))
                   (set! pc addr)))))))
-(add-primitive-word! #t "loop" loop-proc)
+(add-instruction! #t "loop" loop-proc)
 
 ; BEGIN
 ; Put HERE on the stack, to be used by UNTIL or REPEAT.
 (define (for-proc)
   (add-primitive-code!(push-proc))
   (push-int! dstack location-counter))
-(add-primitive-word! #t "for" for-proc)
+(add-instruction! #t "for" for-proc)
 
 
 (add-compiler-directive! "for"
                           (if (= (pop-int! dstack #t) 0)
                               (set! pc addr)
                               (void))))))
-(add-primitive-word! #t "until" until-proc)
+(add-instruction! #t "until" until-proc)
 
 ; WHILE
 ; Does the same thing as IF.
 ; BEGIN - WHILE - REPEAT is like BEGIN - IF - LOOP THEN
-(add-primitive-word! #t "while" if-proc)
+(add-instruction! #t "while" if-proc)
 
-(add-primitive-word! #f "?dup" (lambda () (if (= 0 (get-int dstack #f))
+(add-instruction! #f "?dup" (lambda () (if (= 0 (get-int dstack #f))
                                               (void)
                                               (push-cells! (get-cells dstack)))))
 
-(add-primitive-word! #t "abort\""
+(add-instruction! #t "abort\""
                      (lambda () (let [(str (read-string))]
                                   (add-primitive-code!
                                    (lambda () (if (= (pop-int! dstack #t) false)

File ArrayForth/forth_io_words.rkt

 
 (define (add-io-words!)
 
-  (add-primitive-word!
+  (add-instruction!
    "send"
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
 	   (send i set 'pc (sub1 pc))
 	   (rvector-set! table arg1 arg2)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "recv"
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
 		  (send i set 'pc (sub1 pc)))))))
 
   ; Debugging
-  (add-primitive-word!
+  (add-instruction!
    ".s"
    (lambda (i)
      (print-stack (send i get 'dstack))))
 
-  (add-primitive-word!
+  (add-instruction!
    ".ns"
    (lambda (i)
      (print (send i get 'state-index))
      (print-stack (send i get 'dstack))
      (newline)))
 
-  (add-primitive-word!
+  (add-instruction!
    ".r"
    (lambda (i)
      (print-stack (send i get 'rstack))))
 
-  (add-primitive-word!
+  (add-instruction!
    ".nr"
    (lambda (i)
      (print (send i get 'state-index))
 			     (display elmt)])))
 	       (print-memory memory (+ 4 start) end))))
 
-  (add-primitive-word!
+  (add-instruction!
    ".mem"
    (lambda (i)
      (let* [(dstack (send i get 'dstack))

File ArrayForth/forth_state_words.rkt

   ; Stack manipulation words
 
   ; Get the first cell and push it back on
-  (add-primitive-word!
+  (add-instruction!
    "dup"
    (lambda (i)
      (let [(dstack (send i get 'dstack))]
        (push-cells! dstack (get-cells dstack)))))
 
   ; Get the second cell and push it back on
-  (add-primitive-word!
+  (add-instruction!
    "over"
    (lambda (i)
      (let [(dstack (send i get 'dstack))]
        (push-cells! dstack (get-cells dstack 1)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "drop"
    (lambda (i)
      (pop-cells! (send i get 'dstack))))
 
 #|
-  (add-primitive-word!
+  (add-instruction!
    "swap"
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
        (push-cells! dstack arg1)
        (push-cells! dstack arg2))))
 
-  (add-primitive-word!
+  (add-instruction!
    "rot"
    (lambda (i)
      (let* [(dstack (send i get 'dstack))
 
   ; rstack manipulation words
 
-  (add-primitive-word!
+  (add-instruction!
    "push"
    (lambda (i)
      (push-cells! (send i get 'rstack)
 		  (pop-cells! (send i get 'dstack)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "pop"
    (lambda (i)
      (push-cells! (send i get 'dstack)
 
   ; fetch via register
 
-  (add-primitive-word!
+  (add-instruction!
    "@+"
    (lambda (i)
      (let [(dstack (send i get 'dstack))
        (push-int! dstack (rvector-ref memory rega))
        (send i set 'rega (add1 rega)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "@"
    (lambda (i)
      (let [(dstack (send i get 'dstack))
 	   (rega (send i get 'rega))]
        (push-int! dstack (rvector-ref memory rega)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "@b"
    (lambda (i)
      (let [(dstack (send i get 'dstack))
 
   ; @p only works when it is immediately followed by { .. }
   ; Annoyingly, needs to take into account the pc increment done by interpret.
-  (add-primitive-word!
+  (add-instruction!
    "@p" 
    (lambda (i)
      (let [(dstack (send i get 'dstack))
   ; store via register
 
   ; TODO: !p doesn't work if write to memory
-  (add-primitive-word!
+  (add-instruction!
    "!p" 
    (lambda (i)
      (let [(dstack (send i get 'dstack))
        (rvector-set! memory pc (pop-cells! dstack))
        (send i increment-pc!))))
 
-  (add-primitive-word!
+  (add-instruction!
    "!+" 
    (lambda (i)
      (let [(dstack (send i get 'dstack))
        (rvector-set! memory rega (pop-int! dstack #t))
        (send i set 'rega (add1 rega)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "!"
    (lambda (i)
      (let [(dstack (send i get 'dstack))
 	   (rega (send i get 'rega))]
        (rvector-set! memory rega (pop-int! dstack #t)))))
 
-  (add-primitive-word!
+  (add-instruction!
    "!b"
    (lambda (i)
      (let [(dstack (send i get 'dstack))
      (rvector-set! memory regb (pop-int! dstack #t)))))
 
   ; fetch from register
-  (add-primitive-word!
+  (add-instruction!
    "a"
    (lambda (i)
      (push-int! (send i get 'dstack) (send i get 'rega))))
 
   ; store to register
-  (add-primitive-word!
+  (add-instruction!
    "a!"
    (lambda (i)
      (send i set 'rega (pop-int! (send i get 'dstack) #f))))
 
-  (add-primitive-word!
+  (add-instruction!
    "b!"
    (lambda (i)
      (send i set 'regb (pop-int! (send i get 'dstack) #f))))
 
   ;;;;;;;;;;;;;;;;;;;; (testing only) : store to pc ;;;;;;;;;;;;;;;;;;;
-  (add-primitive-word!
+  (add-instruction!
    "p!"
    (lambda (i)
      (send i set 'pc (pop-int! (send i get 'dstack) #f)))))