From: Frank Buss
Subject: a Forth CPU assembler
Date: Tue, 05 Sep 2006 02:22:32 +0000
Message-ID: <11qbapefo688e$.oruwjxxwm818$.dlg@40tude.net>

I'm designing a CPU with an instruction set like Forth:

http://www.frank-buss.de/vhdl/forth-cpu.html

The goal is to synthesize it for a FPGA. To test it, I've written an
assembler for it, see below. There is some redundant code, but it should
work.

Maybe someone wants to write the "execute" function to simulate the CPU?
After executing the test program, the bytes from 0 to 5 should be swapped
with the bytes from 6 to 11.


(defconstant +max-memory+ 1024)

(defconstant +commands+
  '((push . (parse-push #b00000000))
    (pushr . (parse-push #b00001000))
    (pop . (parse-pop #b00000010))
    (popr . (parse-pop #b01000010))
    (loada . (parse-load #b00100010))
    (loadpc . (parse-load #b00101010))
    (loads . (parse-load #b00110010))
    (jump . (parse-jump-call #b00001010))
    (call . (parse-jump-call #b00111010))
    (bcc . (parse-branch #b00000001))
    (bcs . (parse-branch #b01000001))
    (beq . (parse-branch #b10000001))
    (bne . (parse-branch #b11000001))
    (@a . (······@!a #b00000011))
    (!a . (······@!a #b00100011))
    (dup . (parse-no-argument #b01000011))
    (swap . (parse-no-argument #b01001011))
    (drop . (parse-no-argument #b01010011))
    (rot . (parse-no-argument #b01011011))
    (over . (parse-no-argument #b01100011))
    (reserved . (parse-no-argument #b01101011))
    (add . (parse-no-argument #b01110011))
    (sub . (parse-no-argument #b01111011))
    (inc . (parse-no-argument #b10000011))
    (dec . (parse-no-argument #b10001011))
    (mul . (parse-no-argument #b10010011))
    (xor . (parse-no-argument #b10011011))
    (and . (parse-no-argument #b10100011))
    (or . (parse-no-argument #b10101011))
    (not . (parse-no-argument #b10110011))
    (reserved . (parse-no-argument #b10111011))
    (lsl . (parse-no-argument #b11000011))
    (lsr . (parse-no-argument #b11001011))
    (rol . (parse-no-argument #b11010011))
    (ror . (parse-no-argument #b11011011))
    (cmp . (parse-no-argument #b11100011))
    (reserved . (parse-no-argument #b11101011))
    (stop . (parse-no-argument #b11110011))
    (nop . (parse-no-argument #b11111011))
    (.org . (parse-.org))
    (.db . (parse-.db))
    (.dw . (parse-.dw))))
         
(defparameter *pc* 0)
(defparameter *memory* nil)
(defparameter *labels* nil)
(defparameter *first-pass* nil)

(defun add-byte (byte)
  (setf (aref *memory* *pc*) byte)
  (incf *pc*))

(defun parse-byte-or-word (token)
  (cond
   ((keywordp token)
    (let ((label-value (gethash token *labels*)))
      (unless label-value
        (unless *first-pass* (error "undefined label ~a" token))
        (setf label-value 0))
      label-value))
   ((numberp token) token)
   (t (error "value expected"))))

(defun parse-push (tokens byte)
  (let ((source (pop tokens)))
    (cond
     ((eql source 'a)
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte))
     ((eql source 'pc)
      (setf byte (logior byte #b00010000))
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte))
     ((eql source 's)
      (setf byte (logior byte #b00100000))
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte))
     ((eql source '\#)
      (setf byte (logior byte #b00110000))
      (let ((imm-value (pop tokens)))
        (cond
         ((eql imm-value 0))
         ((eql imm-value 1)
          (setf byte (logior byte #b01000000)))
         (t (error "0 or 1 expected"))))
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte))
     ((eql source 'byte)
      (let ((address (parse-byte-or-word (pop tokens))))
        (when (eql (pop tokens) '+pc)
          (setf address (- *pc* address))
          (when (> address #x7f) (error "address out of range"))
          (when (< address #x-80) (error "address out of range"))
          (setf byte (logior byte #b00000100)))
        (add-byte (logior byte #b10110000))
        (add-byte address)))
     ((eql source 'word)
      (let ((address (parse-byte-or-word (pop tokens))))
        (when (eql (pop tokens) '+pc)
          (setf address (- *pc* address))
          (when (> address #x7fff) (error "address out of range"))
          (when (< address #x-8000) (error "address out of range"))
          (setf byte (logior byte #b00000100)))
        (add-byte (logior byte #b11110000))
        (add-byte address)))
     (t (error "A, PC, S, #, byte or word source expected")))))

(defun parse-pop (tokens byte)
  (let ((destination (pop tokens)))
    (cond
     ((eql destination 'a))
     ((eql destination 'pc)
      (setf byte (logior byte #b00001000)))
     ((eql destination 's)
      (setf byte (logior byte #b00010000)))
     (t (error "A, PC or S destination expected"))))
  (when (eql (pop tokens) '+pc)
    (setf byte (logior byte #b00000100)))
  (add-byte byte))

(defun parse-load (tokens byte)
  (let ((type (pop tokens)))
    (cond
     ((eql type '\#)
      (setf byte (logior byte #b00110000))
      (let ((imm-value (pop tokens)))
        (cond
         ((eql imm-value 0))
         ((eql imm-value 1)
          (setf byte (logior byte #b01000000)))
         (t (error "0 or 1 expected"))))
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte))
     ((eql type 'byte)
      (let ((address (parse-byte-or-word (pop tokens))))
        (when (eql (pop tokens) '+pc)
          (setf address (- *pc* address))
          (when (> address #x7f) (error "address out of range"))
          (when (< address #x-80) (error "address out of range"))
          (setf byte (logior byte #b00000100)))
        (add-byte (logior byte #b10110000))
        (add-byte address)))
     ((eql type 'word)
      (let ((address (parse-byte-or-word (pop tokens))))
        (when (eql (pop tokens) '+pc)
          (setf address (- *pc* address))
          (when (> address #x7fff) (error "address out of range"))
          (when (< address #x-8000) (error "address out of range"))
          (setf byte (logior byte #b00000100)))
        (add-byte (logior byte #b11110000))
        (add-byte address)))
     (t (error "#, byte or word expected")))))

(defun parse-branch (tokens byte)
  (let ((token (pop tokens)))
    (when (eql token 'port)
      (setf byte (logior byte #b00010000)))
    (cond
     ((eql token 'a)
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte))
     ((eql token 'r)
      (when (eql (pop tokens) '+pc)
        (setf byte (logior byte #b00000100)))
      (add-byte byte)
      (add-byte (logior byte #b00010000)))
     ((eql token 'byte)
      (let ((address (parse-byte-or-word (pop tokens))))
        (when (eql (pop tokens) '+pc)
          (setf address (- *pc* address))
          (when (> address #x7f) (error "address out of range"))
          (when (< address #x-80) (error "address out of range"))
          (setf byte (logior byte #b00000100)))
        (add-byte (logior byte #b00011000))
        (add-byte address)))
     ((eql token 'word)
      (let ((address (parse-byte-or-word (pop tokens))))
        (when (eql (pop tokens) '+pc)
          (setf address (- *pc* address))
          (when (> address #x7fff) (error "address out of range"))
          (when (< address #x-8000) (error "address out of range"))
          (setf byte (logior byte #b00000100)))
        (add-byte (logior byte #b00111000))
        (add-byte (ash address -8))
        (add-byte (logand address #xff))))
     (t (error "byte or word transfer width expected")))))

(defun ······@!a (tokens byte)
  (let ((token (pop tokens)))
    (when (eql token 'port)
      (setf byte (logior byte #b00010000)
            token (pop tokens)))
    (cond
     ((eql token 'byte))
     ((eql token 'word) (setf byte (logior byte #b00001000)))
     (t (error "byte or word transfer width expected")))
    (add-byte byte)))

(defun parse-no-argument (tokens byte)
  (let ((token (pop tokens)))
    (when token
      (if (eql token 'popa)
          (setf byte (logior byte #b00000100))
        (error "popa or no argument expected")))
    (add-byte byte)))

(defun parse-.org (tokens byte)
  (declare (ignore byte))
  (setf *pc* (parse-byte-or-word (pop tokens))))
  
(defun parse-.db (tokens byte)
  (declare (ignore byte))
  (loop for token in tokens do
        (add-byte (parse-byte-or-word token))))

(defun parse-.dw (tokens byte)
  (declare (ignore byte))
  (loop for token in tokens do
        (let ((word (parse-byte-or-word token)))
          (add-byte (ash word -8))
          (add-byte (logand word #xff)))))

(defun parse-command (tokens command-symbol)
  (let ((command (assoc command-symbol +commands+)))
    (unless command (error "unknown command ~a" command-symbol))
    (let ((command-info (cdr command)))
      (let ((command-function (first command-info))
            (command-byte (second command-info)))
        (funcall (symbol-function command-function) tokens
command-byte)))))

(defun parse-line (tokens)
  (when tokens
    (let ((token (pop tokens)))
      (cond
       ((keywordp token) (setf (gethash token *labels*) *pc*))
       (t (parse-command tokens token))))))

(defun assemble-pass (program)
  (setf *pc* 0
        *memory* (make-array +max-memory+
                             :element-type '(unsigned-byte 8) 
                             :initial-element 0))
  (with-input-from-string (lines program)
    (loop for line = (read-line lines nil) while line do
          (with-input-from-string (tokens line)
            (parse-line
             (loop for token = (read tokens nil) while token collect
token))))))

(defun assemble (program)
  ;; first pass for setting label addresses for labels which are defined
later than used
  (setf *labels* (make-hash-table)
        *first-pass* t)
  (assemble-pass program)

  ;; second pass with all labels defined
  (setf *first-pass* nil)
  (assemble-pass program))

(defun execute (address)
  ;; todo
)

(defun test ()
  (assemble 
   "
	.org 0
	.db 1 2 3 4 5
	.db 100 101 102 103 104 105

	.org #x100
	push byte 5 ; i=5
:loop	dup popa	; i
	@A byte	; (i) i
	over	; i (i) i
	push byte 6	; 6 i (i) i
	add popa	; (i) i
	@A byte	; (6+i) (i) i
	over	; (i) (6+i) i
	!A byte	; (6+i) i
	over popa	; (6+i) i
	!A byte	; i
	dec	; i-1
	bcc byte :loop +PC
	drop	; empty stack
	stop
")
  (execute #x100))

-- 
Frank Buss, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de

• Re: a Forth CPU assembler Pascal Bourguignon
• Re: a Forth CPU assembler Pascal Bourguignon
  • Re: a Forth CPU assembler Frank Buss
• Re: a Forth CPU assembler Frank Buss
  • Re: a Forth CPU assembler Ari Johnson
  • Re: a Forth CPU assembler Michael Parker
  • Re: a Forth CPU assembler Joe Knapka

From: Pascal Bourguignon
Subject: Re: a Forth CPU assembler
Date: Tue, 05 Sep 2006 03:25:18 +0000
Message-ID: <873bb79eqp.fsf@thalassa.informatimago.com>

Frank Buss <··@frank-buss.de> writes:

> I'm designing a CPU with an instruction set like Forth:
> [...]
> (defun test ()
>   (assemble 
>    "
> 	.org 0
> 	.db 1 2 3 4 5
> 	.db 100 101 102 103 104 105
>
> 	.org #x100
> 	push byte 5 ; i=5
> :loop	dup popa	; i
> 	@A byte	; (i) i
> 	over	; i (i) i
> 	push byte 6	; 6 i (i) i
> 	add popa	; (i) i
> 	@A byte	; (6+i) (i) i
> 	over	; (i) (6+i) i
> 	!A byte	; (6+i) i
> 	over popa	; (6+i) i
> 	!A byte	; i
> 	dec	; i-1
> 	bcc byte :loop +PC
> 	drop	; empty stack
> 	stop
> ")
>   (execute #x100))

BAD! BAD! BAD!

If you  do it  like this, we  cannot use  lisp macros to  generate the
assembler code!

(defmacro while (condition &body body)
  (let ((cond-label (gensym))
        (end-label (gensym)))
  `(forth-asm
      ,cond-label
      (forth-asm ,condition)
      
      
-- 
__Pascal Bourguignon__                     http://www.informatimago.com/

In a World without Walls and Fences, 
who needs Windows and Gates?

From: Pascal Bourguignon
Subject: Re: a Forth CPU assembler
Date: Tue, 05 Sep 2006 03:33:22 +0000
Message-ID: <87wt8j7zst.fsf@thalassa.informatimago.com>

Frank Buss <··@frank-buss.de> writes:

> I'm designing a CPU with an instruction set like Forth:
> [...]
> (defun test ()
>   (assemble 
>    "
> 	.org 0
> 	.db 1 2 3 4 5
> 	.db 100 101 102 103 104 105
>
> 	.org #x100
> 	push byte 5 ; i=5
> :loop	dup popa	; i
> 	@A byte	; (i) i
> 	over	; i (i) i
> 	push byte 6	; 6 i (i) i
> 	add popa	; (i) i
> 	@A byte	; (6+i) (i) i
> 	over	; (i) (6+i) i
> 	!A byte	; (6+i) i
> 	over popa	; (6+i) i
> 	!A byte	; i
> 	dec	; i-1
> 	bcc byte :loop +PC
> 	drop	; empty stack
> 	stop
> ")
>   (execute #x100))

BAD! BAD! BAD!

If you  do it  like this, we  cannot use  lisp macros to  generate the
assembler code!


;; just an example, I've not learned the opcodes to generate correct code.

(defmacro while (condition &body body)
  (let ((cond-label (gensym))
        (end-label (gensym)))
   `(forth-asm
       ,cond-label
        ,@condition
        (bne byte ,end-label +pc)
        ,@body
        (bt ,cond-label)
        ,end-label)))

(macroexpand-1 '(while ((dup popa) (push byte 0) (cmp byte))
                   (push byte -1)

--> (FORTH-ASM #1=#:G6869 (DUP POPA) (PUSH BYTE 0) (CMP BYTE)
               (BNE BYTE #2=#:G6870 +PC) (PUSH BYTE -1) (ADD POPA) (BT #1#) #2#)

Moreover, if you take sexps instead of strings, you don't have to
parse anything, and you can use full lisp as a preprocessor to the
assembler:

    (forth-asm
        (push #.(+ some-label +cdr-offset+))
        ...)


-- 
__Pascal Bourguignon__                     http://www.informatimago.com/

In a World without Walls and Fences, 
who needs Windows and Gates?

From: Frank Buss
Subject: Re: a Forth CPU assembler
Date: Tue, 05 Sep 2006 06:48:59 +0000
Message-ID: <mvsir023vkk.7chon6t31egu$.dlg@40tude.net>

Pascal Bourguignon wrote:

> (macroexpand-1 '(while ((dup popa) (push byte 0) (cmp byte))
>                    (push byte -1)
> 
> --> (FORTH-ASM #1=#:G6869 (DUP POPA) (PUSH BYTE 0) (CMP BYTE)
>                (BNE BYTE #2=#:G6870 +PC) (PUSH BYTE -1) (ADD POPA) (BT #1#) #2#)

Thanks, this is better, I'll rewrite it. With some more macros, I could
implement Lisp for it :-)

-- 
Frank Buss, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de

From: Frank Buss
Subject: Re: a Forth CPU assembler
Date: Wed, 06 Sep 2006 22:56:41 +0000
Message-ID: <9bgbqfkleak6.1t4y9a2ay815j.dlg@40tude.net>

Frank Buss wrote:

> Maybe someone wants to write the "execute" function to simulate the CPU?
> After executing the test program, the bytes from 0 to 5 should be swapped
> with the bytes from 6 to 11.

I've changed it to s-expressions and implemented a first version of the
execute function. There was a minor bug in the Forth test program. I wonder
how a Forth programmer writes programs, without confusing which and how
many values are on stack.

http://www.frank-buss.de/tmp/forth-cpu.lisp.txt

-- 
Frank Buss, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de

From: Ari Johnson
Subject: Re: a Forth CPU assembler
Date: Wed, 06 Sep 2006 23:30:22 +0000
Message-ID: <m23bb4po8h.fsf@hermes.theari.com>

Frank Buss <··@frank-buss.de> writes:

> Frank Buss wrote:
>
>> Maybe someone wants to write the "execute" function to simulate the CPU?
>> After executing the test program, the bytes from 0 to 5 should be swapped
>> with the bytes from 6 to 11.
>
> I've changed it to s-expressions and implemented a first version of the
> execute function. There was a minor bug in the Forth test program. I wonder
> how a Forth programmer writes programs, without confusing which and how
> many values are on stack.

I suspect that they keep whiteboards near their workstations.

From: Michael Parker
Subject: Re: a Forth CPU assembler
Date: Wed, 06 Sep 2006 23:50:41 +0000
Message-ID: <060920061912065972%michaelparker@earthlink.net>

In article <······························@40tude.net>, Frank Buss
<··@frank-buss.de> wrote:

> ... I wonder
> how a Forth programmer writes programs, without confusing which and how
> many values are on stack.

With a text editor, of course.  Writing small functions helps.  Back in
the day the old 16x64 (most forths) or 24x40 (apple II forths) screen
editors enforced this the hard way; this was relaxed considerably in
more modern forths with filesystem support.  After awhile your brain
just handles it all without effort.

I still think forth style took an irreparable hit in the move from
screen editors to file editors, but then I think it's been all downhill
since FIG-forth.

From: Joe Knapka
Subject: Re: a Forth CPU assembler
Date: Thu, 07 Sep 2006 04:30:01 +0000
Message-ID: <dfNLg.13426$dl.951@tornado.texas.rr.com>

Frank Buss wrote:

> Frank Buss wrote:
> 
> 
>>Maybe someone wants to write the "execute" function to simulate the CPU?
>>After executing the test program, the bytes from 0 to 5 should be swapped
>>with the bytes from 6 to 11.
> 
> 
> I've changed it to s-expressions and implemented a first version of the
> execute function. There was a minor bug in the Forth test program. I wonder
> how a Forth programmer writes programs, without confusing which and how
> many values are on stack.
> 
> http://www.frank-buss.de/tmp/forth-cpu.lisp.txt

If you'd crossposted this to c.l.forth, you'd have way more
answers to that than you ever wanted.  The most popular
one would be the Method Advocated by Primal Authority: Chuck
Moore says that in his code, the stack rarely gets deeper
than seven items. Obviously, if you can't keep track of
that much data in your head, you're not a Real Programmer.

(Now, what the heck was I doing before I got distracted by
this thread....?)

-- JK