Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial commit, v1.0

  • Loading branch information...
commit 7a75df00d9e83ed684f4b03cf2f0f04342734a86 1 parent 37f16ff
@dsmvwld authored
View
100 README.md
@@ -1,4 +1,98 @@
-CamelForth-16
-=============
+CamelForth for the DCPU-16
+==========================
-CamelForth port for the DCPU-16
+This is CamelForth-16, an implementation of the Forth programming language
+for the fictional Mojang 16-bit DCPU. It is a fully-featured, standard, ANS-compatible
+16-bit implementation of the language, including a glimpse of required 16/32-bit
+mixed arithmetic.
+
+It is a port of the popular CamelForth direct-threaded code (DTC) model,
+derived directly from the existing Z-80 CP/M code by Brad Rodriguez.
+Like CamelForth in general, it is licensed under the GPL.
+
+For details on DCPU-16, see <http://0x10c.com/doc/dcpu-16.txt>,
+but also see the yet-unpublished, semi-official changes at
+<http://pastebin.com/raw.php?i=Q4JvQvnM>. CamelForth-16 is
+written to the latter spec (v1.7),
+and thus requires a recent, up-to-date simulator.
+It was developed using an unofficial, patched version of the "highnerd rc1" simulator,
+but can be run in any recent simulator that supports the required
+devices (generic keyboard and LEM-1802 display), for example, hellige's simulator
+from <https://github.com/hellige/dcpu> with the -g switch (SDL required).
+
+For background on the Mojang DCPU and the 0x10c game,
+check out <http://0x10c.com>.
+
+For details on CamelForth, see <http://www.camelforth.com>.
+For help and tutorials on Forth itself, see <http://www.forth.org>,
+<http://www.forth.com> and <http://en.wikipedia.org/wiki/Forth_(programming_language)>.
+
+
+Quick Start
+-----------
+
+The CamelForth-16 image is supplied as a big-endian image in the file camel16.o.
+The choice for big-endian stems from it being the native format of Notch's simulator
+it was developed in, and it being supported by popular up-to-date simulators such
+as hellige's. Other formats such as little-endian or DAT source will be supplied shortly.
+
+The CamelForth image, camel16.o, can be run from a SDL-enabled hellige
+DCPU simulator directory as follows:
+
+ ./dcpu -g ../path/to/camel16.o
+
+Notice the need to include the -g option, and thus the SDL requirement.
+CamelForth does not yet run in hellige's pure ncurses console environment.
+
+In a setting with an extra SDL window open, remember to keep the input focus
+on the simulator window to get keyboard input to register.
+Also, CamelForth is case-sensitive, but does not fold case on input. Standard
+Forth words have thus to be entered in uppercase.
+
+Try
+ 3 4 + .
+to check out basic arithmetic, or
+ 355 10000 113 */ .
+to try some mixed 16/32-bit arithmetic, delivering an amusing result.
+
+Try
+ WORDS
+to get a listing of the Forth words supported by CamelForth-16.
+Remember to enter it in upper case.
+The WORDS listing can be interrupted by pressing a key anytime.
+
+Check out the commented source listing (camel16.lst) for details.
+
+
+The Assembler
+-------------
+
+CamelForth-16 comes with its own custom DCPU-16 assembler, which is currently
+required to build a CamelForth-16 executable. The assembler is written in Ruby,
+and implements the macros needed to define Forth headers and keep track of link
+fields. It is not a full macro assembler however.
+
+To recompile CamelForth-16 from its three source files, issue
+
+ ./asm camel16.dasm
+
+This will also produce an updated listing in camel16.lst.
+
+
+Thanks
+------
+
+Thanks go out to Brad Rodriguez for a simple yet comprehensive model
+implementation. Check out <http://www.camelforth.com> for other
+implementations on common, real microprocessors. As the saying goes,
+"If you've seen one Forth, you've -- well, seen one Forth," but
+porting CamelForth was exceptionally easy.
+
+Thanks to Markus Persson (@notch) for 0x10c as such, for providing an interesting
+challenge and a moving target that kept things lively this April (2012).
+Check out <http://0x10c.com> for the upcoming game.
+
+Last but not least, thanks to Charles Moore for Forth in general.
+I hadn't touched Forth in many years now, and it all felt familiar (and "just right")
+again. An amazing language and mindset.
+Check out his site <http://www.colorforth.com/index.html>.
View
276 asm
@@ -0,0 +1,276 @@
+#!/usr/bin/env ruby
+# asm.rb -- assembler for Mojang's fictional 1985 DCPU-16
+# hh 04apr12 started
+# hh 06apr12 generate listing and object file, added DAT
+# hh 28apr12 adapted to DCPU 1.5, added INCLUDE, macros
+# hh 03may12 fix INCLUDE listing darkness
+# hh 06may12 fix handling of negative literals
+
+# TODO:
+# do not list INCLUDEs as line 0 of included file
+# do not list data if ORG bumps $pc forward
+
+WORD = 0xffff
+BASIC_OPCODES = %w(- SET ADD SUB MUL MLI DIV DVI MOD MDI AND BOR XOR SHR ASR SHL IFB IFC IFE IFN IFG IFA IFL IFU - - ADX SBX - - STI STD)
+SPECIAL_OPCODES = %w(- JSR - - - - - HCF INT IAG IAS IAP IAQ - - - HWN HWQ HWI)
+REGS = %w(A B C X Y Z I J)
+EXTRAS = %w(- PEEK - SP PC EX)
+
+REG = /[ABCXYZIJ]/
+LABEL = /[A-Za-z$_][A-Za-z0-9$_]*/
+LITERAL = /-?\d{1,5}|0[xX][0-9a-fA-F]{1,4}/
+
+$mem = Array.new(0x1_0000, 0)
+$labels = Hash.new
+$errors = 0
+$link = 0 # macro variable for CamelForth headers
+
+def err(msg)
+ $stderr.puts "#{File.basename($f.last.path)}:#{$f.last.lineno} #{msg}"
+ $errors += 1
+end
+
+# deposit a word in memory, advancing PC
+def comma(w)
+ $mem[$pc & WORD] = (w & WORD)
+ $pc += 1
+end
+
+SOME_VALUE = 040 # not a compact literal
+
+def lookup(label)
+ if $pass == 1
+ $labels.fetch(label, SOME_VALUE)
+ else
+ $labels.fetch(label) {|k| err("undefined label: #{label}"); SOME_VALUE }
+ end
+end
+
+def word(s)
+ s.to_i(0) & WORD # accept 0x
+end
+
+def asm_operand(op)
+ case op
+ when /^#{REG}$/
+ REGS.index(op)
+ when /^\[(#{REG})\]$/
+ 010+REGS.index($1)
+ when /^\[(#{LITERAL})\+(#{REG})\]$/
+ comma(word($1))
+ 020+REGS.index($2)
+ when /^\[(#{LABEL})\+(#{REG})\]$/
+ comma(lookup($1))
+ 020+REGS.index($2)
+ when /^(PUSH|POP)$/
+ 030 # TODO error checking a/b
+ when /^(PEEK|SP|PC|EX)$/
+ 030+EXTRAS.index(op)
+ when /^\[SP\+(#{LITERAL})\]$/ # TODO allow LABEL
+ comma($1)
+ 032
+ when /^\[(#{LITERAL})\]$/
+ comma(word($1))
+ 036
+ when /^\[(#{LABEL})\]$/
+ comma(lookup($1))
+ 036
+ when /^(#{LITERAL})$/
+ lit = word($1)
+ if lit == 0xffff
+ 040
+ elsif (0..30) === lit
+ 040+(lit+1)
+ else
+ comma(lit)
+ 037
+ end
+ when /^(#{LABEL})$/
+ comma(lookup($1)) # TODO use short form if backref
+ 037
+ else
+ raise "bad operand: #{op}"
+ end
+end
+
+def resolve(opd)
+ return case opd
+ when /^#{LITERAL}$/
+ word(opd)
+ when /^#{LABEL}$/
+ lookup(opd.upcase)
+ else
+ err("bad expression: #{opd}") if $pass == 1
+ 0
+ end
+end
+
+def data(opd)
+ case opd
+ when /^"(.*)"$/, /^'(.*)'$/
+ $1.codepoints.each {|u| comma(u) }
+ else
+ comma(resolve(opd))
+ end
+end
+
+def asm_opcode(opc, opds)
+ case opc
+ when 'DAT', 'DW'
+ opds.each {|opd| data(opd) }
+ when 'INCLUDE'
+ $f << File.open(opds.shift+".dasm", "r")
+ when 'HEAD', 'IMMED'
+ label, name, action = opds
+ comma($link)
+ comma(opc == 'IMMED' ? 1 : 0)
+ $labels['$LINK'] = $link = $pc
+ comma(name.length()-2) # sans quotes
+ data(name)
+ deflab(label.upcase, $pc)
+ unless action.upcase == "DOCODE"
+ comma(0x7c20) # JSR addr
+ comma(lookup(action.upcase))
+ end
+ when 'NEXT'
+ comma(0x3401)
+ comma(0x88a2)
+ comma(0x0381)
+ when 'ORG'
+ $list_pc = $pc = resolve(opds.shift)
+ else
+ a = b = 0
+ pc = $pc
+ comma(0) # allocate instruction early on
+ o = if b = SPECIAL_OPCODES.index(opc)
+ a = asm_operand(opds.shift.upcase)
+ 0
+ elsif o = BASIC_OPCODES.index(opc)
+ # processor handles a first, then b
+ bop = opds.shift.upcase
+ a = asm_operand(opds.shift.upcase)
+ b = asm_operand(bop) & 037 # TODO error checking
+ raise "too many operands" unless opds.empty?
+ o
+ else
+ err "bad opcode #{opc}" if $pass == 1
+ return
+ 0
+ end
+ $mem[pc] = (a << 10) | (b << 5) | o
+ end
+end
+
+def tokenize(line)
+ tokens = line.scan(/:[\w$]+|;.*|,|"[^"]*"|'[^']*'|[-\w$\[\]\+]+/)
+ tokens.delete(',')
+ comment = tokens.find_index {|t| t =~ /^;/ }
+ tokens = tokens[0, comment] unless comment.nil?
+ tokens
+end
+
+def deflab(label, value)
+ if $labels.include?(label) && $labels[label] != value
+ err "duplicate definition of #{label}" if $pass == 1
+ else
+ $labels[label] = value
+ end
+end
+
+def asm_line(line)
+ tokens = tokenize(line)
+ return if tokens.empty?
+ while tokens.first.start_with?(':')
+ label = tokens.shift.sub(/^:/, '')
+ if $pass == 1
+ deflab(label.upcase, $pc)
+ else
+ err "phase error" if $pc != $labels[label.upcase]
+ end
+ return if tokens.empty? # allow labels-only lines
+ end
+ opcode = tokens.shift.upcase
+ asm_opcode(opcode, tokens)
+end
+
+def word_if(addr, used)
+ used ? "%04x" % $mem[addr] : ''
+end
+
+def list_line(line, pc)
+ len = $pc - pc
+ $listing.printf("%04x %-4s %-4s %-4s\t%4d %s\n",
+ pc, word_if(pc, len >= 1), word_if(pc+1, len >= 2), word_if(pc+2, len >= 3),
+ $f.last.lineno, line
+ )
+ if len > 3
+ len -= 3
+ while len > 0
+ pc += 3
+ $listing.printf("%04x %-4s %-4s %-4s\t%4d\n",
+ pc, word_if(pc, len >= 1), word_if(pc+1, len >= 2), word_if(pc+2, len >= 3),
+ $f.last.lineno
+ )
+ len -= 3
+ end
+ end
+end
+
+def asm_file(f) # f rewindable
+ $f = Array.new
+ $f << f
+ while !$f.empty?
+ line = $f.last.gets
+ if line
+ line.chomp!
+ $list_pc = $pc
+ asm_line(line)
+ list_line(line, $list_pc) if $pass == 2
+ else
+ $f.pop
+ end
+ end
+end
+
+def dump_syms(f)
+ f.puts "\nSYMBOL TABLE\n\n"
+ $labels.sort.each {|k,v| f.printf("%-10s %04x\n", k, v) }
+end
+
+def save_obj(fn)
+ File.open(fn, "wb") {|f|
+ f.write $mem[0, $pc].pack("n*")
+ }
+end
+
+def asm_fn(ifn, ofn)
+ File.open(ifn, "r") {|f|
+ $pass = 1
+ $pc = $link = 0
+ asm_file(f)
+ f.rewind
+ $pass = 2
+ $pc = $link = 0
+ $listing = File.open(File.basename(ifn, ".dasm") + ".lst", "w")
+ asm_file(f)
+ #dump_syms($listing)
+ $listing.close
+ save_obj(ofn)
+ }
+end
+
+if $0 == __FILE__
+ unless ARGV.length == 1 || ARGV.length == 3
+ $stderr.puts "usage: #{File.basename($0, '.rb')} [-o output.o] input.dasm"
+ exit(1)
+ end
+ ofn = nil
+ if ARGV.first == '-o'
+ ofn = ARGV.shift(2).last
+ end
+ ifn = ARGV.shift
+ ofn = File.basename(ifn, '.dasm') + '.o' if ofn.nil?
+ asm_fn(ifn, ofn)
+ puts "#{$errors} errors" if $errors > 0
+ exit($errors == 0 ? 0 : 1)
+end
View
842 camel16.dasm
@@ -0,0 +1,842 @@
+; Listing 2.
+; ===============================================
+; CamelForth for the Mojang DCPU-16 (http://0x10c.com)
+; Copyright (c) 2012 Helge Horch
+; CamelForth for the Zilog Z80
+; Copyright (c) 1994,1995 Bradford J. Rodriguez
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 3 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+; Commercial inquiries should be directed to the author at
+; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+; or via email to bj@camelforth.com
+;
+; ===============================================
+; CAMEL16.S: Code Primitives
+; Source code is for the ASM assembler.
+; Forth words are documented as follows:
+;x NAME stack -- stack description
+; where x=C for ANS Forth Core words, X for ANS
+; Extensions, Z for internal or private words.
+;
+; Direct-Threaded Forth model for DCPU-16
+; 16 bit cell, 16 bit char, 16 bit (word) adrs unit
+; DCPU-16 B = Forth TOS (top Param Stack item)
+; C = W working register
+; Z = IP Interpreter Pointer
+; SP = PSP Param Stack Pointer
+; X = RSP Return Stack Pointer
+; Y = UP User area Pointer
+; A, I, J = temporaries
+;
+; Revision history:
+; 07 Apr 12 v0.1 cloned from Z80 CamelForth
+; ===============================================
+; Macros to define Forth headers
+; HEAD label,name,action
+; IMMED label,name,action
+; label = assembler name for this word
+; (special characters not allowed)
+; name = Forth's name for this word
+; action = code routine for this word, e.g.
+; DOCOLON, or DOCODE for code words
+; IMMED defines a header for an IMMEDIATE word.
+;
+;head MACRO #label,#name,#action
+; DAT link
+; DAT 0
+;link DEFL $
+; DAT #length(#name),#name
+;#label:
+; IF .NOT.(#action=DOCODE)
+; jsr #action
+; ENDIF
+; ENDM
+;
+;immed MACRO #label,#name,#action
+; DAT link
+; DAT 1
+;link DEFL $
+; DB #length(#name),#name
+;#label:
+; IF .NOT.(#action=DOCODE)
+; jsr #action
+; ENDIF
+; ENDM
+;
+; The NEXT macro (3 words) assembles the 'next'
+; code in-line in every Z80 CamelForth CODE word.
+;next MACRO
+; set a,[z] ;
+; add z,1 ;
+; set pc,a ;
+; ENDM
+;
+; ENTRY POINT ===================================
+; all registers zeroed, 64K words available
+:reset ias 0 ; interrupts off
+ jsr hwdetect ; detect screen and keyboard
+ jsr hwinit
+ set y,0xfc00 ; UP
+ set x,0xff00 ; RP
+ set pc,cold ; enter top-level Forth word
+ set sp,0
+ set b,0
+ set pc,reset ; loop if COLD returns
+
+; Memory map:
+; 0x0000.. Forth kernel and user dictionary
+; 0xfc00..0xfc7f User area, 128 words
+; 0xfc80..0xfcff Terminal Input Buffer, 128 words
+; 0xfd00..0xfdff HOLD area, PAD buffer, L stack, 256 words (40+88+128)
+; 0xfe00..0xfeff Return stack, 256 words
+; 0xff00..0xffff Parameter stack, 256 words
+;
+; See also the definitions of U0, S0, and R0
+; in the "system variables & constants" area.
+; A task (user area) requires 0x400 words.
+
+; INTERPRETER LOGIC =============================
+; See also "defining words" at end of this file
+
+;C EXIT -- exit a colon definition
+ head EXIT,"EXIT",docode
+ set z,[x] ; pop old IP from ret stk
+ add x,1
+:anext next
+
+;Z lit -- x fetch inline literal to stack
+; This is the primitive compiled by LITERAL.
+ head lit,"lit",docode
+ set push,b ; push old TOS
+ set b,[z] ; fetch cell at IP to TOS,
+ add z,1 ; advancing IP
+ next
+
+;C EXECUTE i*x xt -- j*x execute Forth word
+;C at 'xt'
+ head EXECUTE,"EXECUTE",docode
+ set a,b ; address of word
+ set b,pop ; get new TOS
+ set pc,a ; go do Forth word
+
+; DEFINING WORDS ================================
+
+; ENTER, a.k.a. DOCOLON, entered by CALL ENTER
+; to enter a new high-level thread (colon def'n.)
+; (internal code fragment, not a Forth word)
+; N.B.: DOCOLON must be defined before any
+; appearance of 'docolon' in a 'word' macro!
+:docolon ; (alternate name)
+:enter sub x,1 ; push old IP on ret stack
+ set [x],z
+ set z,pop ; param field adrs -> IP
+ next
+
+;C VARIABLE -- define a Forth variable
+; CREATE 1 CELLS ALLOT ;
+; Action of RAM variable is identical to CREATE,
+; so we don't need a DOES> clause to change it.
+ head VARIABLE,"VARIABLE",docolon
+ DW CREATE,LIT,1,CELLS,ALLOT,EXIT
+; DOVAR, code action of VARIABLE, entered by CALL
+; DOCREATE, code action of newly created words
+:docreate
+:dovar ; -- a-addr
+ set a,pop ; parameter field address
+ set push,b ; push old TOS
+ set b,a ; pfa = variable's adrs -> TOS
+ next
+
+;C CONSTANT n -- define a Forth constant
+; CREATE , DOES> (machine code fragment)
+ head CONSTANT,"CONSTANT",docolon
+ DW CREATE,COMMA,XDOES
+; DOCON, code action of CONSTANT,
+; entered by CALL DOCON
+:docon ; -- x
+ set a,pop ; parameter field address
+ set push,b ; push old TOS
+ set b,[a] ; fetch contents of parameter field -> TOS
+ next
+
+;Z USER n -- define user variable 'n'
+; CREATE , DOES> (machine code fragment)
+ head USER,"USER",docolon
+ DW CREATE,COMMA,XDOES
+; DOUSER, code action of USER,
+; entered by CALL DOUSER
+:douser ; -- a-addr
+ set a,pop ; parameter field address
+ set push,b ; push old TOS
+ set b,[a] ; fetch contents of parameter field (the offset)
+ add b,y ; add user base address
+ next
+
+; DODOES, code action of DOES> clause
+; entered by CALL fragment
+; parameter field
+; ...
+; fragment: CALL DODOES
+; high-level thread
+; Enters high-level thread with address of
+; parameter field on top of stack.
+; (internal code fragment, not a Forth word)
+:dodoes ; -- a-addr
+ sub x,1 ; push old IP on ret stk
+ set [x],z
+ set z,pop ; adrs of new thread -> IP
+ set a,pop ; adrs of parameter field
+ set push,b ; push old TOS onto stack
+ set b,a ; pfa -> new TOS
+ next
+
+; TERMINAL I/O =============================
+
+:hwmon dat 0 ; monitor device number
+:hwkbd dat 0 ; keyboard device number
+
+:hwdetect
+ hwn j ; query #devices
+ set i,0
+:hwloop ife i,j ; so scan 0..n-1
+ set pc,pop ; return if done
+ hwq i
+ ife b,0x7349 ; LEM1802?
+ set [hwmon],i
+ ife b,0x30cf ; keyboard?
+ set [hwkbd],i
+ add i,1
+ set pc,hwloop
+
+:hwinit set b,[vrama]
+ set a,0 ; MEM_MAP_SCREEN
+ hwi [hwmon]
+ ; set b,0
+ ; set a,1 ; MEM_MAP_FONT: built-in
+ ; hwi [hwmon]
+ ; set a,2 ; MEM_MAP_PALETTE: built-in
+ ; hwi [hwmon]
+ set a,3 ; SET_BORDER_COLOR
+ set b,[colora]
+ shr b,8
+ hwi [hwmon]
+ set b,0 ; turn off kbd interrupts
+ set a,3
+ hwi [hwkbd]
+ set a,0 ; clear keyboard buffer
+ hwi [hwkbd]
+ set pc,pop
+
+;Z VRAM -- addr video RAM start
+ head vram,"VRAM",docon
+:vrama DW 0x8000
+
+;Z VLEN -- u video RAM extent (words)
+ head vlen,"VLEN",docon
+:vlena DW 384
+
+;Z VCOLS -- u video line length
+ head vcols,"VCOLS",docon
+ DW 32
+
+;Z CURSOR -- addr cursor offset on screen (next char)
+ head cursor,"CURSOR",dovar
+:cursora DW 0
+
+;Z COLOR -- addr color mask applied to chars
+ head color,"COLOR",dovar
+:colora DW 0xa200 ; green on green
+
+;Z UNBLINK -- u store non-blinking blank at cursor
+ head UNBLINK,"UNBLINK",docolon
+ DW cursor, fetch, vram, over, plus ; ( ofs a)
+ DW color, fetch, bl, plus, swop, store ; ( ofs)
+ DW exit
+
+;C EMIT c -- output character to console
+ head EMIT,"EMIT",docolon
+ DW lit, 8, over, equal, qbranch, notbs
+ DW drop, unblink, oneminus
+ DW lit, 0, max, cursor, store
+ DW branch, blink
+:notbs DW color, fetch, plus ; ( c)
+ DW cursor, fetch, vram, plus, store ; ( )
+ DW cursor, fetch, dup, vlen, oneminus, uless ; ( ofs f)
+ DW qbranch, cr1
+ DW oneplus, cursor, store ; ( )
+:blink DW color, fetch, lit, 0x9f, plus
+ DW cursor, fetch, vram, plus, store, exit
+
+;C CR -- output newline
+ head CR,"CR",docolon
+ DW unblink ; ( ofs)
+:cr1 DW vcols, oneminus, invert, and ; CR
+ DW dup, cursor, store ; ( ofs)
+ DW vlen, vcols, minus, equal ; on last line?
+ DW qbranch, noscroll
+ DW vram, vcols, over, plus, swop ; ( a a2)
+ DW vlen, vcols, minus, cmove ; scroll
+ DW vram, vlen, plus, vcols, minus ; ( a3)
+ DW vcols, branch, cls1 ; clear last line
+:noscroll DW vcols, cursor, plusstore
+ DW branch, blink
+
+;Z CLS -- clear screen
+ head CLS,"CLS",docolon
+ DW lit, 0, cursor, store
+ DW vram, vlen ; ( a u)
+:cls1 DW color, fetch, bl, plus, fill
+ DW branch, blink
+
+;Z SAVEKEY -- addr temporary storage for KEY?
+ head savekey,"SAVEKEY",dovar
+:savekeya DW 0
+
+;X KEY? -- f return true if char waiting
+ head querykey,"KEY?",docode
+ set a,1
+ hwi [hwkbd] ; sets c register
+ ife c,0x11 ; Return key?
+ set c,0x0d
+ ife c,0x10 ; Backspace key?
+ set c,0x08
+ set [savekeya],c
+ set push,b
+ set b,c
+ next
+
+;C KEY -- c get character from keyboard
+; BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT
+; SAVEKEY C@ 0 SAVEKEY C! ;
+ head KEY,"KEY",docolon
+:KEY1 DW SAVEKEY,CFETCH,ZEROEQUAL,qbranch,KEY2
+ DW QUERYKEY,DROP,branch,KEY1
+:KEY2 DW SAVEKEY,CFETCH,LIT,0,SAVEKEY,CSTORE
+ DW EXIT
+
+
+;X BYE i*x -- return to CP/M
+ head bye,"bye",docode
+:halt set pc,halt
+
+; STACK OPERATIONS ==============================
+
+;C DUP x -- x x duplicate top of stack
+ head DUP,"DUP",docode
+:pushtos set push,b
+ next
+
+;C ?DUP x -- 0 | x x DUP if nonzero
+ head QDUP,"?DUP",docode
+ ifn b,0
+ set push,b
+ next
+
+;C DROP x -- drop top of stack
+ head DROP,"DROP",docode
+:poptos set b,pop
+ next
+
+;C SWAP x1 x2 -- x2 x1 swap top two items
+ head SWOP,"SWAP",docode
+ set a,b
+ set b,peek
+ set peek,a
+ next
+
+;C OVER x1 x2 -- x1 x2 x1 per stack diagram
+ head OVER,"OVER",docode
+ set a,peek
+ set push,b
+ set b,a
+ next
+
+;C ROT x1 x2 x3 -- x2 x3 x1 per stack diagram
+ head ROT,"ROT",docode
+ ; x3 is in TOS
+ set a,pop ; x2
+ set c,pop ; x1
+ set push,a
+ set push,b
+ set b,c
+ next
+
+;X NIP x1 x2 -- x2 per stack diagram
+ head NIP,"NIP",docode
+ set a,pop
+ next
+
+;X TUCK x1 x2 -- x2 x1 x2 per stack diagram
+ head TUCK,"TUCK",docode
+ set a,pop
+ set push,b
+ set push,a
+ next
+
+;C >R x -- R: -- x push to return stack
+ head TOR,">R",docode
+ sub x,1
+ set [x],b ; push TOS onto rtn stk
+ set b,pop ; pop new TOS
+ next
+
+;C R> -- x R: x -- pop from return stack
+ head RFROM,"R>",docode
+ set push,b ; push old TOS
+ set b,[x] ; pop top rtn stk item
+ add x,1 ; to TOS
+ next
+
+;C R@ -- x R: x -- x fetch from rtn stk
+ head RFETCH,"R@",docode
+ set push,b ; push old TOS
+ set b,[x] ; fetch top rtn stk item
+ next
+
+;Z SP@ -- a-addr get data stack pointer
+ head SPFETCH,"SP@",docode
+ set push,b
+ set b,sp
+ next
+
+;Z SP! a-addr -- set data stack pointer
+ head SPSTORE,"SP!",docode
+ set sp,b
+ set b,pop ; get new TOS
+ next
+
+;Z RP@ -- a-addr get return stack pointer
+ head RPFETCH,"RP@",docode
+ set push,b
+ set b,x
+ next
+
+;Z RP! a-addr -- set return stack pointer
+ head RPSTORE,"RP!",docode
+ set x,b
+ set b,pop
+ next
+
+; MEMORY AND I/O OPERATIONS =====================
+
+;C ! x a-addr -- store cell in memory
+ head STORE,"!",docode
+ set a,pop ; data
+ set [b],a
+ set b,pop ; pop new TOS
+ next
+
+;C C! char c-addr -- store char in memory
+ head CSTORE,"C!",docode
+ set a,pop ; data
+ set [b],a
+ set b,pop ; pop new TOS
+ next
+
+;C @ a-addr -- x fetch cell from memory
+ head FETCH,"@",docode
+ set b,[b]
+ next
+
+;C C@ c-addr -- char fetch char from memory
+ head CFETCH,"C@",docode
+ set b,[b]
+ next
+
+;Z PC! char c-addr -- output char to port
+; head PCSTORE,"PC!",docode
+; pop hl ; char in L
+; out (c),l ; to port (BC)
+; pop bc ; pop new TOS
+; next
+;
+;Z PC@ c-addr -- char input char from port
+; head PCFETCH,"PC@",docode
+; in c,(c) ; read port (BC) to C
+; ld b,0
+; next
+;
+; ARITHMETIC AND LOGICAL OPERATIONS =============
+
+;C + n1/u1 n2/u2 -- n3/u3 add n1+n2
+ head PLUS,"+",docode
+ add b,pop
+ next
+
+;X M+ d n -- d add single to double
+ head MPLUS,"M+",docode
+ set c,pop ; hi cell
+ add peek,b ; lo cell remains on stack
+ add c,ex
+ set b,c
+ next
+
+;C - n1/u1 n2/u2 -- n3/u3 subtract n1-n2
+ head MINUS,"-",docode
+ set a,b
+ set b,pop
+ sub b,a
+ next
+
+;C AND x1 x2 -- x3 logical AND
+ head AND,"AND",docode
+ and b,pop
+ next
+
+;C OR x1 x2 -- x3 logical OR
+ head OR,"OR",docode
+ bor b,pop
+ next
+
+;C XOR x1 x2 -- x3 logical XOR
+ head XOR,"XOR",docode
+ xor b,pop
+ next
+
+;C INVERT x1 -- x2 bitwise inversion
+ head INVERT,"INVERT",docode
+ xor b,-1
+ next
+
+;C NEGATE x1 -- x2 two's complement
+ head NEGATE,"NEGATE",docode
+ xor b,-1
+ add b,1
+ next
+
+;C 1+ n1/u1 -- n2/u2 add 1 to TOS
+ head ONEPLUS,"1+",docode
+ add b,1
+ next
+
+;C 1- n1/u1 -- n2/u2 subtract 1 from TOS
+ head ONEMINUS,"1-",docode
+ sub b,1
+ next
+
+;Z >< x1 -- x2 swap bytes (not ANSI)
+ head swapbytes,"><",docode
+ shl b,8
+ bor b,ex
+ next
+
+;C 2* x1 -- x2 arithmetic left shift
+ head TWOSTAR,"2*",docode
+ shl b,1
+ next
+
+;C 2/ x1 -- x2 arithmetic right shift
+ head TWOSLASH,"2/",docode
+ asr b,1
+ next
+
+;C LSHIFT x1 u -- x2 logical L shift u places
+ head LSHIFT,"LSHIFT",docode
+ set a,b ; count
+ set b,pop
+ shl b,a
+ next
+
+;C RSHIFT x1 u -- x2 logical R shift u places
+ head RSHIFT,"RSHIFT",docode
+ set a,b ; count
+ set b,pop
+ shr b,a
+ next
+
+;C +! n/u a-addr -- add cell to memory
+ head PLUSSTORE,"+!",docode
+ add [b],pop
+ set b,pop
+ next
+
+; COMPARISON OPERATIONS =========================
+
+;C 0= n/u -- flag return true if TOS=0
+ head ZEROEQUAL,"0=",docode
+ ifn b,0
+ set b,1
+ sub b,1
+ next
+
+;C 0< n -- flag true if TOS negative
+ head ZEROLESS,"0<",docode
+ ifu b,0
+ set pc,tostrue
+:tosfalse
+ set b,0
+ next
+:tostrue
+ set b,-1
+ next
+
+;C = x1 x2 -- flag test x1=x2
+ head EQUAL,"=",docode
+ ife b,pop
+ set pc,tostrue
+ set pc,tosfalse
+
+;X <> x1 x2 -- flag test not eq (not ANSI)
+ head NOTEQUAL,"<>",docolon
+ DW EQUAL,ZEROEQUAL,EXIT
+
+;C < n1 n2 -- flag test n1<n2, signed
+ head LESS,"<",docode
+ set a,pop ; n1
+ ifu a,b
+ set pc,tostrue
+ set pc,tosfalse
+
+;C > n1 n2 -- flag test n1>n2, signed
+ head GREATER,">",docolon
+ DW SWOP,LESS,EXIT
+
+;C U< u1 u2 -- flag test u1<n2, unsigned
+ head ULESS,"U<",docode
+ ifg b,pop
+ set pc,tostrue
+ set pc,tosfalse
+
+;X U> u1 u2 -- flag u1>u2 unsgd (not ANSI)
+ head UGREATER,"U>",docolon
+ DW SWOP,ULESS,EXIT
+
+; LOOP AND BRANCH OPERATIONS ====================
+
+;Z branch -- branch always
+ head branch,"branch",docode
+:dobranch set z,[z] ; get inline value => IP
+ next
+
+;Z ?branch x -- branch if TOS zero
+ head qbranch,"?branch",docode
+ set a,b
+ set b,pop ; pop new TOS
+ ife a,0
+ set pc,dobranch
+ add z,1 ; else skip inline value
+ next
+
+;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2
+;Z run-time code for DO
+; '83 and ANSI standard loops terminate when the
+; boundary of limit-1 and limit is crossed, in
+; either direction. This can be conveniently
+; implemented by making the limit 8000h, so that
+; arithmetic overflow logic can detect crossing.
+; I learned this trick from Laxen & Perry F83.
+; fudge factor = 8000h-limit, to be added to
+; the start value.
+ head xdo,"(do)",docode
+ set c,0x8000
+ sub c,pop ; 0x8000-limit
+ sub x,1
+ set [x],c ; push as fudge factor
+ add b,c ; add fudge to start value
+ sub x,1
+ set [x],b ; push adjusted start value
+ set b,pop
+ next
+
+;Z (loop) R: sys1 sys2 -- | sys1 sys2
+;Z run-time code for LOOP
+; Add 1 to the loop index. If loop terminates,
+; clean up the return stack and skip the branch.
+; Else take the inline branch. Note that LOOP
+; terminates when index=8000h.
+ head xloop,"(loop)",docode
+ set a,1 ; the increment
+:loopad add a,[x] ; get the loop index
+ ife a,0x8000
+ set pc,looptr ; terminate loop
+ set [x],a ; save updated index
+ set pc,dobranch ; continue the loop
+:looptr add x,2 ; discard loop info
+ add z,1 ; skip the inline branch
+ next
+
+;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2
+;Z run-time code for +LOOP
+; Add n to the loop index. If loop terminates,
+; clean up the return stack and skip the branch.
+; Else take the inline branch.
+ head xplusloop,"(+loop)",docode
+ set a,b ; the increment
+ set b,pop ; get new TOX
+ set pc,loopad
+
+;C I -- n R: sys1 sys2 -- sys1 sys2
+;C get the innermost loop index
+ head II,"I",docode
+ set push,b ; push old TOS
+ set b,[x] ; get loop index
+ sub b,[1+x] ; subtract fudge factor though
+ next
+
+;C J -- n R: 4*sys -- 4*sys
+;C get the second loop index
+ head JJ,"J",docode
+ set push,b ; push old TOS
+ set b,[2+x] ; get outer loop index
+ sub b,[3+x] ; subtract fudge factor though
+ next
+
+;C UNLOOP -- R: sys1 sys2 -- drop loop parms
+ head UNLOOP,"UNLOOP",docode
+ add x,2
+ next
+
+; MULTIPLY AND DIVIDE ===========================
+
+;C UM* u1 u2 -- ud unsigned 16x16->32 mult.
+ head UMSTAR,"UM*",docode
+ mul b,pop
+ set push,b
+ set b,ex
+ next
+
+;C UM/MOD ud u1 -- u2 u3 unsigned 32/16->16
+ head UMSLASHMOD,"UM/MOD",docode
+ set a,pop ; AC = dividend, B=divisor
+ set c,pop
+ set i,16 ; loop counter
+ shl c,1 ; sets EX to MSB
+:udloop adx a,a ; rotate
+ ife ex,0
+ set pc,ud16
+:ud17 sub a,b ; always fits
+ set ex,0
+ set pc,udjoin
+:ud16 sub a,b
+ ife ex,0 ; it fit
+ set pc,udjoin
+ add a,b ; restore step
+ set ex,1
+:udjoin adx c,c ; rotate (complemented) result bit in
+ std j,j ; side effect: decrement i, don't clobber EX
+ ife i,0
+ set pc,udfin
+ set pc,udloop
+:udfin xor c,-1 ; de-complement quotient
+ set push,a
+ set b,c
+ next
+
+; BLOCK AND STRING OPERATIONS ===================
+
+;C FILL c-addr u char -- fill memory with char
+ head FILL,"FILL",docode
+ set i,pop
+ set a,pop
+:filoop ife i,0
+ set pc,mdone
+ std [a],b ; decrements i
+ add a,1
+ set pc,filoop
+:mdone set b,pop
+ next
+
+;X CMOVE c-addr1 c-addr2 u -- move from bottom
+; as defined in the ANSI optional String word set
+; On byte machines, CMOVE and CMOVE> are logical
+; factors of MOVE. They are easy to implement on
+; CPUs which have a block-move instruction.
+ head CMOVE,"CMOVE",docode
+ set i,pop ; destination address
+ set j,pop ; source address
+:cmloop ife b,0
+ set pc,mdone
+ sti [i],[j]
+ sub b,1
+ set pc,cmloop
+
+;X CMOVE> c-addr1 c-addr2 u -- move from top
+; as defined in the ANSI optional String word set
+ head CMOVEUP,"CMOVE>",docode
+ set i,pop ; destination address
+ add i,b
+ sub i,1
+ set j,pop ; source address
+ add j,b
+ sub j,1
+:cploop ife b,0
+ set pc,mdone
+ std [i],[j]
+ sub b,1
+ set pc,cploop
+
+;Z SKIP c-addr u c -- c-addr' u'
+;Z skip matching chars
+; Although SKIP, SCAN, and S= are perhaps not the
+; ideal factors of WORD and FIND, they closely
+; follow the string operations available on many
+; CPUs, and so are easy to implement and fast.
+ head skip,"SKIP",docode
+ set c,pop
+ set a,pop
+:skipn ife c,0
+ set pc,skipd
+ ifn [a],b
+ set pc,skipd
+ add a,1
+ sub c,1
+ set pc,skipn
+:skipd set push,a
+ set b,c
+ next
+
+;Z SCAN c-addr u c -- c-addr' u'
+;Z find matching char
+ head scan,"SCAN",docode
+ set c,pop
+ set a,pop
+:scann ife c,0
+ set pc,scand
+ ife [a],b
+ set pc,scand
+ add a,1
+ sub c,1
+ set pc,scann
+:scand set push,a
+ set b,c
+ next
+
+;Z S= c-addr1 c-addr2 u -- n string compare
+;Z n<0: s1<s2, n=0: s1=s2, n>0: s1>s2
+ head sequal,"S=",docode
+ set j,pop ; addr2
+ set i,pop ; addr1
+:sloop ife b,0
+ set pc,smatch ; by definition, match!
+ set a,[i]
+ sub a,[j]
+ ifn a,0
+ set pc,sdiff
+ sub b,1
+ sti pc,sloop
+:sdiff asr a,15 ; smear sign bit across A
+ ife a,0
+ add a,1
+ set b,a
+:smatch next
+
+ INCLUDE camel16d ; CPU Dependencies
+ INCLUDE camel16h ; High Level words
+
+:enddict ; user's code starts here
+
+ ORG $link
+:lastword ; nfa of last word in dict.
+ ORG enddict
View
2,659 camel16.lst
2,659 additions, 0 deletions not shown
View
BIN  camel16.o
Binary file not shown
View
156 camel16d.dasm
@@ -0,0 +1,156 @@
+; LISTING 3.
+;
+; ===============================================
+; CamelForth for the Mojang DCPU-16 (http://0x10c.com)
+; Copyright (c) 2012 Helge Horch
+; CamelForth for the Zilog Z80
+; Copyright (c) 1994,1995 Bradford J. Rodriguez
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 3 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+; Commercial inquiries should be directed to the author at
+; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+; or via email to bj@camelforth.com
+;
+; ===============================================
+; CAMEL16D.S: CPU and Model Dependencies
+; Source code is for the ASM assembler.
+; Forth words are documented as follows:
+;* NAME stack -- stack description
+; Word names in upper case are from the ANS
+; Forth Core word set. Names in lower case are
+; "internal" implementation words & extensions.
+;
+; Direct-Threaded Forth model for Mojang DCPU-16
+; cell size is 16 bits (1 word)
+; char size is 16 bits (1 word)
+; address unit is 16 bits (1 word)
+; ===============================================
+
+; ALIGNMENT AND PORTABILITY OPERATORS ===========
+; Many of these are synonyms for other words,
+; and so are defined as CODE words.
+
+;C ALIGN -- align HERE
+ head ALIGN,"ALIGN",docode
+ next
+
+;C ALIGNED addr -- a-addr align given addr
+ head ALIGNED,"ALIGNED",docode
+ next
+
+;Z CELL -- n size of one cell
+ head CELL,"CELL",docon
+ dw 1
+
+;C CELL+ a-addr1 -- a-addr2 add cell size
+; 1+ ;
+ head CELLPLUS,"CELL+",docode
+ add b,1
+ next
+
+;C CELLS n1 -- n2 cells->adrs units
+ head CELLS,"CELLS",docode
+ next
+
+;C CHAR+ c-addr1 -- c-addr2 add char size
+ head CHARPLUS,"CHAR+",docode
+ add b,1
+ next
+
+;C CHARS n1 -- n2 chars->adrs units
+ head CHARS,"CHARS",docode
+ next
+
+;C >BODY xt -- a-addr adrs of param field
+; 2 + ; DCPU-16 (2 word JSR)
+ head TOBODY,">BODY",docode
+ add b,2
+ next
+
+;X COMPILE, xt -- append execution token
+; I called this word ,XT before I discovered that
+; it is defined in the ANSI standard as COMPILE,.
+; On a DTC Forth this simply appends xt (like , )
+; but on an STC Forth this must append 'CALL xt'.
+ head COMMAXT,'COMPILE,',docode
+ set pc,COMMA
+
+;Z !CF adrs cfa -- set code action of a word
+; 7C20 OVER ! store 'JSR adrs' instr
+; 1+ ! ; DCPU-16 VERSION
+; Depending on the implementation this could
+; append CALL adrs or JUMP adrs.
+ head STORECF,"!CF",docolon
+ DAT LIT,0x7c20,OVER,STORE
+ DAT ONEPLUS,STORE,EXIT
+
+;Z ,CF adrs -- append a code field
+; HERE !CF 2 ALLOT ; DCPU-16 VERSION (2 words)
+ head COMMACF,',CF',docolon
+ DAT HERE,STORECF,LIT,2,ALLOT,EXIT
+
+;Z !COLON -- change code field to docolon
+; -2 ALLOT docolon-adrs ,CF ;
+; This should be used immediately after CREATE.
+; This is made a distinct word, because on an STC
+; Forth, colon definitions have no code field.
+ head STORCOLON,'!COLON',docolon
+ DAT LIT,-2,ALLOT
+ DAT LIT,docolon,COMMACF,EXIT
+
+;Z ,EXIT -- append hi-level EXIT action
+; ['] EXIT ,XT ;
+; This is made a distinct word, because on an STC
+; Forth, it appends a RET instruction, not an xt.
+ head CEXIT,',EXIT',docolon
+ DAT LIT,EXIT,COMMAXT,EXIT
+
+; CONTROL STRUCTURES ============================
+; These words allow Forth control structure words
+; to be defined portably.
+
+;Z ,BRANCH xt -- append a branch instruction
+; xt is the branch operator to use, e.g. qbranch
+; or (loop). It does NOT append the destination
+; address. On the Z80 this is equivalent to ,XT.
+ head COMMABRANCH,',BRANCH',docode
+ set pc,COMMA
+
+;Z ,DEST dest -- append a branch address
+; This appends the given destination address to
+; the branch instruction. On the Z80 this is ','
+; ...other CPUs may use relative addressing.
+ head COMMADEST,',DEST',docode
+ set pc,COMMA
+
+;Z !DEST dest adrs -- change a branch dest'n
+; Changes the destination address found at 'adrs'
+; to the given 'dest'. On the Z80 this is '!'
+; ...other CPUs may need relative addressing.
+ head STOREDEST,'!DEST',docode
+ set pc,STORE
+
+; HEADER STRUCTURE ==============================
+; The structure of the Forth dictionary headers
+; (name, link, immediate flag, and "smudge" bit)
+; does not necessarily differ across CPUs. This
+; structure is not easily factored into distinct
+; "portable" words; instead, it is implicit in
+; the definitions of FIND and CREATE, and also in
+; NFA>LFA, NFA>CFA, IMMED?, IMMEDIATE, HIDE, and
+; REVEAL. These words must be (substantially)
+; rewritten if either the header structure or its
+; inherent assumptions are changed.
+
View
1,004 camel16h.dasm
@@ -0,0 +1,1004 @@
+; LISTING 2.
+;
+; ===============================================
+; CamelForth for the Mojang DCPU-16 (http://0x10c.com)
+; Copyright (c) 2012 Helge Horch
+; CamelForth for the Zilog Z80
+; Copyright (c) 1994,1995 Bradford J. Rodriguez
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 3 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+; Commercial inquiries should be directed to the author at
+; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+; or via email to bj@camelforth.com
+;
+; ===============================================
+; CAMEL16H.S: High Level Words
+; Source code is for the ASM assembler.
+; Forth words are documented as follows:
+;* NAME stack -- stack description
+; Word names in upper case are from the ANS
+; Forth Core word set. Names in lower case are
+; "internal" implementation words & extensions.
+; ===============================================
+
+; SYSTEM VARIABLES & CONSTANTS ==================
+
+;C BL -- char an ASCII space
+ head BL,"BL",docon
+ dw 0x20
+
+;Z tibsize -- n size of TIB
+ head TIBSIZE,"TIBSIZE",docon
+ dw 128
+
+;X tib -- a-addr Terminal Input Buffer
+; HEX 82 CONSTANT TIB CP/M systems: 126 bytes
+; HEX -80 USER TIB others: below user area
+; HEX 80 USER TIB DCPU-16: upper user area
+ head TIB,"TIB",douser
+ dw 0x80
+
+;Z u0 -- a-addr current user area adrs
+; 0 USER U0
+ head U0,"U0",douser
+ dw 0
+
+;C >IN -- a-addr holds offset into TIB
+; 1 USER >IN
+ head TOIN,">IN",douser
+ dw 1
+
+;C BASE -- a-addr holds conversion radix
+; 2 USER BASE
+ head BASE,"BASE",douser
+ dw 2
+
+;C STATE -- a-addr holds compiler state
+; 3 USER STATE
+ head STATE,"STATE",douser
+ dw 3
+
+;Z dp -- a-addr holds dictionary ptr
+; 4 USER DP
+ head DP,"DP",douser
+ dw 4
+
+;Z 'source -- a-addr two cells: len, adrs
+; 5 USER 'SOURCE
+ head TICKSOURCE,"'SOURCE",douser
+ dw 5
+
+;Z latest -- a-addr last word in dict.
+; 7 USER LATEST
+ head LATEST,"LATEST",douser
+ dw 7
+
+;Z hp -- a-addr HOLD pointer
+; 8 USER HP
+ head HP,"HP",douser
+ dw 8
+
+;Z LP -- a-addr Leave-stack pointer
+; 9 USER LP
+ head LP,"LP",douser
+ dw 9
+
+;Z s0 -- a-addr end of parameter stack
+ head S0,"S0",douser
+ dw 0x400
+
+;X PAD -- a-addr user PAD buffer
+; = end of hold area!
+ head PAD,"PAD",douser
+ dw 0x128
+
+;Z l0 -- a-addr bottom of Leave stack
+ head L0,"L0",douser
+ dw 0x180
+
+;Z r0 -- a-addr end of return stack
+ head R0,"R0",douser
+ dw 0x300
+
+;Z uinit -- addr initial values for user area
+ head UINIT,"UINIT",docreate
+ DW 0,0,10,0 ; reserved,>IN,BASE,STATE
+ DW enddict ; DP
+ DW 0,0 ; SOURCE init'd elsewhere
+ DW lastword ; LATEST
+ DW 0 ; HP init'd elsewhere
+
+;Z #init -- n #bytes of user area init data
+ head NINIT,"#INIT",docon
+ DW 9
+
+; ARITHMETIC OPERATORS ==========================
+
+;C S>D n -- d single -> double prec.
+; DUP 0< ;
+ head STOD,"S>D",docolon
+ dw DUP,ZEROLESS,EXIT
+
+;Z ?NEGATE n1 n2 -- n3 negate n1 if n2 negative
+; 0< IF NEGATE THEN ; ...a common factor
+ head QNEGATE,"?NEGATE",docolon
+ DW ZEROLESS,qbranch,QNEG1,NEGATE
+:QNEG1 DW EXIT
+
+;C ABS n1 -- +n2 absolute value
+; DUP ?NEGATE ;
+ head ABS,"ABS",docolon
+ DW DUP,QNEGATE,EXIT
+
+;X DNEGATE d1 -- d2 negate double precision
+; SWAP INVERT SWAP INVERT 1 M+ ;
+ head DNEGATE,"DNEGATE",docolon
+ DW SWOP,INVERT,SWOP,INVERT,LIT,1,MPLUS
+ DW EXIT
+
+;Z ?DNEGATE d1 n -- d2 negate d1 if n negative
+; 0< IF DNEGATE THEN ; ...a common factor
+ head QDNEGATE,"?DNEGATE",docolon
+ DW ZEROLESS,qbranch,DNEG1,DNEGATE
+:DNEG1 DW EXIT
+
+;X DABS d1 -- +d2 absolute value dbl.prec.
+; DUP ?DNEGATE ;
+ head DABS,"DABS",docolon
+ DW DUP,QDNEGATE,EXIT
+
+;C M* n1 n2 -- d signed 16*16->32 multiply
+; 2DUP XOR >R carries sign of the result
+; SWAP ABS SWAP ABS UM*
+; R> ?DNEGATE ;
+ head MSTAR,"M*",docolon
+ DW TWODUP,XOR,TOR
+ DW SWOP,ABS,SWOP,ABS,UMSTAR
+ DW RFROM,QDNEGATE,EXIT
+
+;C SM/REM d1 n1 -- n2 n3 symmetric signed div
+; 2DUP XOR >R sign of quotient
+; OVER >R sign of remainder
+; ABS >R DABS R> UM/MOD
+; SWAP R> ?NEGATE
+; SWAP R> ?NEGATE ;
+; Ref. dpANS-6 section 3.2.2.1.
+ head SMSLASHREM,"SM/REM",docolon
+ DW TWODUP,XOR,TOR,OVER,TOR
+ DW ABS,TOR,DABS,RFROM,UMSLASHMOD
+ DW SWOP,RFROM,QNEGATE,SWOP,RFROM,QNEGATE
+ DW EXIT
+
+;C FM/MOD d1 n1 -- n2 n3 floored signed div'n
+; DUP >R save divisor
+; SM/REM
+; DUP 0< IF if quotient negative,
+; SWAP R> + add divisor to rem'dr
+; SWAP 1- decrement quotient
+; ELSE R> DROP THEN ;
+; Ref. dpANS-6 section 3.2.2.1.
+ head FMSLASHMOD,"FM/MOD",docolon
+ DW DUP,TOR,SMSLASHREM
+ DW DUP,ZEROLESS,qbranch,FMMOD1
+ DW SWOP,RFROM,PLUS,SWOP,ONEMINUS
+ DW branch,FMMOD2
+:FMMOD1 DW RFROM,DROP
+:FMMOD2 DW EXIT
+
+;C * n1 n2 -- n3 signed multiply
+; M* DROP ;
+ head STAR,"*",docolon
+ dw MSTAR,DROP,EXIT
+
+;C /MOD n1 n2 -- n3 n4 signed divide/rem'dr
+; >R S>D R> FM/MOD ;
+ head SLASHMOD,"/MOD",docolon
+ dw TOR,STOD,RFROM,FMSLASHMOD,EXIT
+
+;C / n1 n2 -- n3 signed divide
+; /MOD nip ;
+ head SLASH,"/",docolon
+ dw SLASHMOD,NIP,EXIT
+
+;C MOD n1 n2 -- n3 signed remainder
+; /MOD DROP ;
+ head MOD,"MOD",docolon
+ dw SLASHMOD,DROP,EXIT
+
+;C */MOD n1 n2 n3 -- n4 n5 n1*n2/n3, rem&quot
+; >R M* R> FM/MOD ;
+ head SSMOD,"*/MOD",docolon
+ dw TOR,MSTAR,RFROM,FMSLASHMOD,EXIT
+
+;C */ n1 n2 n3 -- n4 n1*n2/n3
+; */MOD nip ;
+ head STARSLASH,"*/",docolon
+ dw SSMOD,NIP,EXIT
+
+;C MAX n1 n2 -- n3 signed maximum
+; 2DUP < IF SWAP THEN DROP ;
+ head MAX,"MAX",docolon
+ dw TWODUP,LESS,qbranch,MAX1,SWOP
+:MAX1 dw DROP,EXIT
+
+;C MIN n1 n2 -- n3 signed minimum
+; 2DUP > IF SWAP THEN DROP ;
+ head MIN,"MIN",docolon
+ dw TWODUP,GREATER,qbranch,MIN1,SWOP
+:MIN1 dw DROP,EXIT
+
+; DOUBLE OPERATORS ==============================
+
+;C 2@ a-addr -- x1 x2 fetch 2 cells
+; DUP CELL+ @ SWAP @ ;
+; the lower address will appear on top of stack
+ head TWOFETCH,"2@",docolon
+ dw DUP,CELLPLUS,FETCH,SWOP,FETCH,EXIT
+
+;C 2! x1 x2 a-addr -- store 2 cells
+; SWAP OVER ! CELL+ ! ;
+; the top of stack is stored at the lower adrs
+ head TWOSTORE,"2!",docolon
+ dw SWOP,OVER,STORE,CELLPLUS,STORE,EXIT
+
+;C 2DROP x1 x2 -- drop 2 cells
+; DROP DROP ;
+ head TWODROP,"2DROP",docolon
+ dw DROP,DROP,EXIT
+
+;C 2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells
+; OVER OVER ;
+ head TWODUP,"2DUP",docolon
+ dw OVER,OVER,EXIT
+
+;C 2SWAP x1 x2 x3 x4 -- x3 x4 x1 x2 per diagram
+; ROT >R ROT R> ;
+ head TWOSWAP,"2SWAP",docolon
+ dw ROT,TOR,ROT,RFROM,EXIT
+
+;C 2OVER x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2
+; >R >R 2DUP R> R> 2SWAP ;
+ head TWOOVER,"2OVER",docolon
+ dw TOR,TOR,TWODUP,RFROM,RFROM
+ dw TWOSWAP,EXIT
+
+; INPUT/OUTPUT ==================================
+
+;C COUNT c-addr1 -- c-addr2 u counted->adr/len
+; DUP CHAR+ SWAP C@ ;
+ head COUNT,"COUNT",docolon
+ dw DUP,CHARPLUS,SWOP,CFETCH,EXIT
+
+;C SPACE -- output a space
+; BL EMIT ;
+ head SPACE,"SPACE",docolon
+ dw BL,EMIT,EXIT
+
+;C SPACES n -- output n spaces
+; BEGIN DUP WHILE SPACE 1- REPEAT DROP ;
+ head SPACES,"SPACES",docolon
+:SPCS1 DW DUP,qbranch,SPCS2
+ DW SPACE,ONEMINUS,branch,SPCS1
+:SPCS2 DW DROP,EXIT
+
+;Z umin u1 u2 -- u unsigned minimum
+; 2DUP U> IF SWAP THEN DROP ;
+ head UMIN,"UMIN",docolon
+ DW TWODUP,UGREATER,QBRANCH,UMIN1,SWOP
+:UMIN1 DW DROP,EXIT
+
+;Z umax u1 u2 -- u unsigned maximum
+; 2DUP U< IF SWAP THEN DROP ;
+ head UMAX,"UMAX",docolon
+ DW TWODUP,ULESS,QBRANCH,UMAX1,SWOP
+:UMAX1 DW DROP,EXIT
+
+;C ACCEPT c-addr +n -- +n' get line from term'l
+; OVER + 1- OVER -- sa ea a
+; BEGIN KEY -- sa ea a c
+; DUP 0D <> WHILE
+; DUP EMIT -- sa ea a c
+; DUP 8 = IF DROP 1- >R OVER R> UMAX
+; ELSE OVER C! 1+ OVER UMIN
+; THEN -- sa ea a
+; REPEAT -- sa ea a c
+; DROP NIP SWAP - ;
+ head ACCEPT,"ACCEPT",docolon
+ DW OVER,PLUS,ONEMINUS,OVER
+:ACC1 DW KEY,DUP,LIT,0x0D,NOTEQUAL,QBRANCH,ACC5
+ DW DUP,EMIT,DUP,LIT,8,EQUAL,QBRANCH,ACC3
+ DW DROP,ONEMINUS,TOR,OVER,RFROM,UMAX
+ DW BRANCH,ACC4
+:ACC3 DW OVER,CSTORE,ONEPLUS,OVER,UMIN
+:ACC4 DW BRANCH,ACC1
+:ACC5 DW DROP,NIP,SWOP,MINUS,EXIT
+
+;C TYPE c-addr +n -- type line to term'l
+; ?DUP IF
+; OVER + SWAP DO I C@ EMIT LOOP
+; ELSE DROP THEN ;
+ head TYPE,"TYPE",docolon
+ DW QDUP,QBRANCH,TYP4
+ DW OVER,PLUS,SWOP,XDO
+:TYP3 DW II,CFETCH,EMIT,XLOOP,TYP3
+ DW BRANCH,TYP5
+:TYP4 DW DROP
+:TYP5 DW EXIT
+
+;Z (S") -- c-addr u run-time code for S"
+; R> COUNT 2DUP + ALIGNED >R ;
+ head XSQUOTE,'(S")',docolon
+ DW RFROM,COUNT,TWODUP,PLUS,ALIGNED,TOR
+ DW EXIT
+
+;C S" -- compile in-line string
+; COMPILE (S") [ HEX ]
+; 22 WORD C@ 1+ ALIGNED ALLOT ; IMMEDIATE
+ immed SQUOTE,'S"',docolon
+ DW LIT,XSQUOTE,COMMAXT
+ DW LIT,0x22,WORD,CFETCH,ONEPLUS
+ DW ALIGNED,ALLOT,EXIT
+
+;C ." -- compile string to print
+; POSTPONE S" POSTPONE TYPE ; IMMEDIATE
+ immed DOTQUOTE,'."',docolon
+ DW SQUOTE
+ DW LIT,TYPE,COMMAXT
+ DW EXIT
+
+; NUMERIC OUTPUT ================================
+; Numeric conversion is done l.s.digit first, so
+; the output buffer is built backwards in memory.
+
+; Some double-precision arithmetic operators are
+; needed to implement ANSI numeric conversion.
+
+;Z UD/MOD ud1 u2 -- u3 ud4 32/16->32 divide
+; >R 0 R@ UM/MOD ROT ROT R> UM/MOD ROT ;
+ head UDSLASHMOD,"UD/MOD",docolon
+ DW TOR,LIT,0,RFETCH,UMSLASHMOD,ROT,ROT
+ DW RFROM,UMSLASHMOD,ROT,EXIT
+
+;Z UD* ud1 d2 -- ud3 32*16->32 multiply
+; DUP >R UM* DROP SWAP R> UM* ROT + ;
+ head UDSTAR,"UD*",docolon
+ DW DUP,TOR,UMSTAR,DROP
+ DW SWOP,RFROM,UMSTAR,ROT,PLUS,EXIT
+
+;C HOLD char -- add char to output string
+; -1 HP +! HP @ C! ;
+ head HOLD,"HOLD",docolon
+ DW LIT,-1,HP,PLUSSTORE
+ DW HP,FETCH,CSTORE,EXIT
+
+;C <# -- begin numeric conversion
+; PAD HP ! ; (initialize Hold Pointer)
+ head LESSNUM,"<#",docolon
+ DW PAD,HP,STORE,EXIT
+
+;Z >digit n -- c convert to 0..9A..Z
+; [ HEX ] DUP 9 > 7 AND + 30 + ;
+ head TODIGIT,">DIGIT",docolon
+ DW DUP,LIT,9,GREATER,LIT,7,AND,PLUS
+ DW LIT,0x30,PLUS,EXIT
+
+;C # ud1 -- ud2 convert 1 digit of output
+; BASE @ UD/MOD ROT >digit HOLD ;
+ head NUM,"#",docolon
+ DW BASE,FETCH,UDSLASHMOD,ROT,TODIGIT
+ DW HOLD,EXIT
+
+;C #S ud1 -- ud2 convert remaining digits
+; BEGIN # 2DUP OR 0= UNTIL ;
+ head NUMS,"#S",docolon
+:NUMS1 DW NUM,TWODUP,OR,ZEROEQUAL,qbranch,NUMS1
+ DW EXIT
+
+;C #> ud1 -- c-addr u end conv., get string
+; 2DROP HP @ PAD OVER - ;
+ head NUMGREATER,"#>",docolon
+ DW TWODROP,HP,FETCH,PAD,OVER,MINUS,EXIT
+
+;C SIGN n -- add minus sign if n<0
+; 0< IF 2D HOLD THEN ;
+ head SIGN,"SIGN",docolon
+ DW ZEROLESS,qbranch,SIGN1,LIT,0x2D,HOLD
+:SIGN1 DW EXIT
+
+;C U. u -- display u unsigned
+; <# 0 #S #> TYPE SPACE ;
+ head UDOT,"U.",docolon
+ DW LESSNUM,LIT,0,NUMS,NUMGREATER,TYPE
+ DW SPACE,EXIT
+
+;C . n -- display n signed
+; <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ;
+ head DOT,'.',docolon
+ DW LESSNUM,DUP,ABS,LIT,0,NUMS
+ DW ROT,SIGN,NUMGREATER,TYPE,SPACE,EXIT
+
+;C DECIMAL -- set number base to decimal
+; 10 BASE ! ;
+ head DECIMAL,"DECIMAL",docolon
+ DW LIT,10,BASE,STORE,EXIT
+
+;X HEX -- set number base to hex
+; 16 BASE ! ;
+ head HEX,"HEX",docolon
+ DW LIT,16,BASE,STORE,EXIT
+
+; DICTIONARY MANAGEMENT =========================
+
+;C HERE -- addr returns dictionary ptr
+; DP @ ;
+ head HERE,"HERE",docolon
+ dw DP,FETCH,EXIT
+
+;C ALLOT n -- allocate n bytes in dict
+; DP +! ;
+ head ALLOT,"ALLOT",docolon
+ dw DP,PLUSSTORE,EXIT
+
+; Note: , and C, are only valid for combined
+; Code and Data spaces.
+
+;C , x -- append cell to dict
+; HERE ! 1 CELLS ALLOT ;
+ head COMMA,',',docolon
+ dw HERE,STORE,lit,1,CELLS,ALLOT,EXIT
+
+;C C, char -- append char to dict
+; HERE C! 1 CHARS ALLOT ;
+ head CCOMMA,'C,',docolon
+ dw HERE,CSTORE,lit,1,CHARS,ALLOT,EXIT
+
+; INTERPRETER ===================================
+; Note that NFA>LFA, NFA>CFA, IMMED?, and FIND
+; are dependent on the structure of the Forth
+; header. This may be common across many CPUs,
+; or it may be different.
+
+;C SOURCE -- adr n current input buffer
+; 'SOURCE 2@ ; length is at lower adrs
+ head SOURCE,"SOURCE",docolon
+ DW TICKSOURCE,TWOFETCH,EXIT
+
+;X /STRING a u n -- a+n u-n trim string
+; ROT OVER + ROT ROT - ;
+ head SLASHSTRING,"/STRING",docolon
+ DW ROT,OVER,PLUS,ROT,ROT,MINUS,EXIT
+
+;Z >counted src n dst -- copy to counted str
+; 2DUP C! CHAR+ SWAP CMOVE ;
+ head TOCOUNTED,">COUNTED",docolon
+ DW TWODUP,CSTORE,CHARPLUS,SWOP,CMOVE,EXIT
+
+;C WORD char -- c-addr n word delim'd by char
+; DUP SOURCE >IN @ /STRING -- c c adr n
+; DUP >R ROT SKIP -- c adr' n'
+; OVER >R ROT SCAN -- adr" n"
+; DUP IF CHAR- THEN skip trailing delim.
+; R> R> ROT - >IN +! update >IN offset
+; TUCK - -- adr' N
+; HERE >counted --
+; HERE -- a
+; BL OVER COUNT + C! ; append trailing blank
+ head WORD,"WORD",docolon
+ DW DUP,SOURCE,TOIN,FETCH,SLASHSTRING
+ DW DUP,TOR,ROT,SKIP
+ DW OVER,TOR,ROT,SCAN
+ DW DUP,qbranch,WORD1,ONEMINUS ; char-
+:WORD1 DW RFROM,RFROM,ROT,MINUS,TOIN,PLUSSTORE
+ DW TUCK,MINUS
+ DW HERE,TOCOUNTED,HERE
+ DW BL,OVER,COUNT,PLUS,CSTORE,EXIT
+
+;Z NFA>LFA nfa -- lfa name adr -> link field
+; 2 - ;
+ head NFATOLFA,"NFA>LFA",docolon
+ DW LIT,2,MINUS,EXIT
+
+;Z NFA>CFA nfa -- cfa name adr -> code field
+; COUNT 7F AND + ; mask off 'smudge' bit
+ head NFATOCFA,"NFA>CFA",docolon
+ DW COUNT,LIT,0x7F,AND,PLUS,EXIT
+
+;Z IMMED? nfa -- f fetch immediate flag
+; 1- C@ ; nonzero if immed
+ head IMMEDQ,"IMMED?",docolon
+ DW ONEMINUS,CFETCH,EXIT
+
+;C FIND c-addr -- c-addr 0 if not found
+;C xt 1 if immediate
+;C xt -1 if "normal"
+; LATEST @ BEGIN -- a nfa
+; 2DUP OVER C@ CHAR+ -- a nfa a nfa n+1
+; S= -- a nfa f
+; DUP IF
+; DROP
+; NFA>LFA @ DUP -- a link link
+; THEN
+; 0= UNTIL -- a nfa OR a 0
+; DUP IF
+; NIP DUP NFA>CFA -- nfa xt
+; SWAP IMMED? -- xt iflag
+; 0= 1 OR -- xt 1/-1
+; THEN ;
+ head FIND,"FIND",docolon
+ DW LATEST,FETCH
+:FIND1 DW TWODUP,OVER,CFETCH,CHARPLUS
+ DW SEQUAL,DUP,qbranch,FIND2
+ DW DROP,NFATOLFA,FETCH,DUP
+:FIND2 DW ZEROEQUAL,qbranch,FIND1
+ DW DUP,qbranch,FIND3
+ DW NIP,DUP,NFATOCFA
+ DW SWOP,IMMEDQ,ZEROEQUAL,LIT,1,OR
+:FIND3 DW EXIT
+
+;C LITERAL x -- append numeric literal
+; STATE @ IF ['] LIT ,XT , THEN ; IMMEDIATE
+; This tests STATE so that it can also be used
+; interpretively. (ANSI doesn't require this.)
+ immed LITERAL,"LITERAL",docolon
+ DW STATE,FETCH,qbranch,LITER1
+ DW LIT,LIT,COMMAXT,COMMA
+:LITER1 DW EXIT
+
+;Z DIGIT? c -- n -1 if c is a valid digit
+;Z -- x 0 otherwise
+; [ HEX ] DUP 39 > 100 AND + silly looking
+; DUP 140 > 107 AND - 30 - but it works!
+; DUP BASE @ U< ;
+ head DIGITQ,"DIGIT?",docolon
+ DW DUP,LIT,0x39,GREATER,LIT,0x100,AND,PLUS
+ DW DUP,LIT,0x140,GREATER,LIT,0x107,AND
+ DW MINUS,LIT,0x30,MINUS
+ DW DUP,BASE,FETCH,ULESS,EXIT
+
+;Z ?SIGN adr n -- adr' n' f get optional sign
+;Z advance adr/n if sign; return NZ if negative
+; OVER C@ -- adr n c
+; 2C - DUP ABS 1 = AND -- +=-1, -=+1, else 0
+; DUP IF 1+ -- +=0, -=+2
+; >R 1 /STRING R> -- adr' n' f
+; THEN ;
+ head QSIGN,"?SIGN",docolon
+ DW OVER,CFETCH,LIT,0x2C,MINUS,DUP,ABS
+ DW LIT,1,EQUAL,AND,DUP,qbranch,QSIGN1
+ DW ONEPLUS,TOR,LIT,1,SLASHSTRING,RFROM
+:QSIGN1 DW EXIT
+
+;C >NUMBER ud adr u -- ud' adr' u'
+;C convert string to number
+; BEGIN
+; DUP WHILE
+; OVER C@ DIGIT?
+; 0= IF DROP EXIT THEN
+; >R 2SWAP BASE @ UD*
+; R> M+ 2SWAP
+; 1 /STRING
+; REPEAT ;
+ head TONUMBER,">NUMBER",docolon
+:TONUM1 DW DUP,qbranch,TONUM3
+ DW OVER,CFETCH,DIGITQ
+ DW ZEROEQUAL,qbranch,TONUM2,DROP,EXIT
+:TONUM2 DW TOR,TWOSWAP,BASE,FETCH,UDSTAR
+ DW RFROM,MPLUS,TWOSWAP
+ DW LIT,1,SLASHSTRING,branch,TONUM1
+:TONUM3 DW EXIT
+
+;Z ?NUMBER c-addr -- n -1 string->number
+;Z -- c-addr 0 if convert error
+; DUP 0 0 ROT COUNT -- ca ud adr n
+; ?SIGN >R >NUMBER -- ca ud adr' n'
+; IF R> 2DROP 2DROP 0 -- ca 0 (error)
+; ELSE 2DROP NIP R>
+; IF NEGATE THEN -1 -- n -1 (ok)
+; THEN ;
+ head QNUMBER,"?NUMBER",docolon
+ DW DUP,LIT,0,DUP,ROT,COUNT
+ DW QSIGN,TOR,TONUMBER,qbranch,QNUM1
+ DW RFROM,TWODROP,TWODROP,LIT,0
+ DW branch,QNUM3
+:QNUM1 DW TWODROP,NIP,RFROM,qbranch,QNUM2,NEGATE
+:QNUM2 DW LIT,-1
+:QNUM3 DW EXIT
+
+;Z INTERPRET i*x c-addr u -- j*x
+;Z interpret given buffer
+; This is a common factor of EVALUATE and QUIT.
+; ref. dpANS-6, 3.4 The Forth Text Interpreter
+; 'SOURCE 2! 0 >IN !
+; BEGIN
+; BL WORD DUP C@ WHILE -- textadr
+; FIND -- a 0/1/-1
+; ?DUP IF -- xt 1/-1
+; 1+ STATE @ 0= OR immed or interp?
+; IF EXECUTE ELSE ,XT THEN
+; ELSE -- textadr
+; ?NUMBER
+; IF POSTPONE LITERAL converted ok
+; ELSE COUNT TYPE 3F EMIT CR ABORT err
+; THEN
+; THEN
+; REPEAT DROP ;
+ head INTERPRET,"INTERPRET",docolon
+ DW TICKSOURCE,TWOSTORE,LIT,0,TOIN,STORE
+:INTER1 DW BL,WORD,DUP,CFETCH,qbranch,INTER9
+ DW FIND,QDUP,qbranch,INTER4
+ DW ONEPLUS,STATE,FETCH,ZEROEQUAL,OR
+ DW qbranch,INTER2
+ DW EXECUTE,branch,INTER3
+:INTER2 DW COMMAXT
+:INTER3 DW branch,INTER8
+:INTER4 DW QNUMBER,qbranch,INTER5
+ DW LITERAL,branch,INTER6
+:INTER5 DW COUNT,TYPE,LIT,0x3F,EMIT,CR,ABORT
+:INTER6
+:INTER8 DW branch,INTER1
+:INTER9 DW DROP,EXIT
+
+;C EVALUATE i*x c-addr u -- j*x interprt string
+; 'SOURCE 2@ >R >R >IN @ >R
+; INTERPRET
+; R> >IN ! R> R> 'SOURCE 2! ;
+ head EVALUATE,"EVALUATE",docolon
+ DW TICKSOURCE,TWOFETCH,TOR,TOR
+ DW TOIN,FETCH,TOR,INTERPRET
+ DW RFROM,TOIN,STORE,RFROM,RFROM
+ DW TICKSOURCE,TWOSTORE,EXIT
+
+;C QUIT -- R: i*x -- interpret from kbd
+; L0 LP ! R0 RP! 0 STATE !
+; BEGIN
+; TIB DUP TIBSIZE ACCEPT SPACE
+; INTERPRET
+; STATE @ 0= IF CR ." OK" THEN
+; AGAIN ;
+ head QUIT,"QUIT",docolon
+ DW L0,LP,STORE
+ DW R0,RPSTORE,LIT,0,STATE,STORE
+:QUIT1 DW TIB,DUP,TIBSIZE,ACCEPT,SPACE
+ DW INTERPRET
+ DW STATE,FETCH,ZEROEQUAL,qbranch,QUIT2
+ DW CR,XSQUOTE
+ DW 3,'ok '
+ DW TYPE
+:QUIT2 DW branch,QUIT1
+
+;C ABORT i*x -- R: j*x -- clear stk & QUIT
+; S0 SP! QUIT ;
+ head ABORT,"ABORT",docolon
+ DW S0,SPSTORE,QUIT ; QUIT never returns
+
+;Z ?ABORT f c-addr u -- abort & print msg
+; ROT IF TYPE ABORT THEN 2DROP ;
+ head QABORT,"?ABORT",docolon
+ DW ROT,qbranch,QABO1,TYPE,ABORT
+:QABO1 DW TWODROP,EXIT
+
+;C ABORT" i*x 0 -- i*x R: j*x -- j*x x1=0
+;C i*x x1 -- R: j*x -- x1<>0
+; POSTPONE S" POSTPONE ?ABORT ; IMMEDIATE
+ immed ABORTQUOTE,'ABORT"',docolon
+ DW SQUOTE
+ DW LIT,QABORT,COMMAXT
+ DW EXIT
+
+;C ' -- xt find word in dictionary
+; BL WORD FIND
+; 0= ABORT" ?" ;
+ head TICK,"'",docolon
+ DW BL,WORD,FIND,ZEROEQUAL,XSQUOTE
+ DW 1,'?'
+ DW QABORT,EXIT
+
+;C CHAR -- char parse ASCII character
+; BL WORD 1+ C@ ;
+ head CHAR,"CHAR",docolon
+ DW BL,WORD,ONEPLUS,CFETCH,EXIT
+
+;C [CHAR] -- compile character literal
+; CHAR ['] LIT ,XT , ; IMMEDIATE
+ immed BRACCHAR,"[CHAR]",docolon
+ DW CHAR
+ DW LIT,LIT,COMMAXT
+ DW COMMA,EXIT
+
+;C ( -- skip input until )
+; [ HEX ] 29 WORD DROP ; IMMEDIATE
+ immed PAREN,"(",docolon
+ DW LIT,0x29,WORD,DROP,EXIT
+
+; COMPILER ======================================
+
+;C CREATE -- create an empty definition
+; LATEST @ , 0 C, link & immed field
+; HERE LATEST ! new "latest" link
+; BL WORD C@ 1+ ALLOT name field
+; docreate ,CF code field
+ head CREATE,"CREATE",docolon
+ DW LATEST,FETCH,COMMA,LIT,0,CCOMMA
+ DW HERE,LATEST,STORE
+ DW BL,WORD,CFETCH,ONEPLUS,ALLOT
+ DW LIT,docreate,COMMACF,EXIT
+
+;Z (DOES>) -- run-time action of DOES>
+; R> adrs of headless DOES> def'n
+; LATEST @ NFA>CFA code field to fix up
+; !CF ;
+ head XDOES,"(DOES>)",docolon
+ DW RFROM,LATEST,FETCH,NFATOCFA,STORECF
+ DW EXIT
+
+;C DOES> -- change action of latest def'n
+; COMPILE (DOES>)
+; dodoes ,CF ; IMMEDIATE
+ immed DOES,"DOES>",docolon
+ DW LIT,XDOES,COMMAXT
+ DW LIT,dodoes,COMMACF,EXIT
+
+;C RECURSE -- recurse current definition
+; LATEST @ NFA>CFA ,XT ; IMMEDIATE
+ immed RECURSE,"RECURSE",docolon
+ DW LATEST,FETCH,NFATOCFA,COMMAXT,EXIT
+
+;C [ -- enter interpretive state
+; 0 STATE ! ; IMMEDIATE
+ immed LEFTBRACKET,"[",docolon
+ DW LIT,0,STATE,STORE,EXIT
+
+;C ] -- enter compiling state
+; -1 STATE ! ;
+ head RIGHTBRACKET,"]",docolon
+ DW LIT,-1,STATE,STORE,EXIT
+
+;Z HIDE -- "hide" latest definition
+; LATEST @ DUP C@ 80 OR SWAP C! ;
+ head HIDE,"HIDE",docolon
+ DW LATEST,FETCH,DUP,CFETCH,LIT,0x80,OR
+ DW SWOP,CSTORE,EXIT
+
+;Z REVEAL -- "reveal" latest definition
+; LATEST @ DUP C@ 7F AND SWAP C! ;
+ head REVEAL,"REVEAL",docolon
+ DW LATEST,FETCH,DUP,CFETCH,LIT,0x7F,AND
+ DW SWOP,CSTORE,EXIT
+
+;C IMMEDIATE -- make last def'n immediate
+; 1 LATEST @ 1- C! ; set immediate flag
+ head IMMEDIATE,"IMMEDIATE",docolon
+ DW LIT,1,LATEST,FETCH,ONEMINUS,CSTORE
+ DW EXIT
+
+;C : -- begin a colon definition
+; CREATE HIDE ] !COLON ;
+ head COLON,":",docolon
+ DW CREATE,HIDE,RIGHTBRACKET,STORCOLON
+ DW EXIT
+
+;C ;
+; REVEAL ,EXIT
+; POSTPONE [ ; IMMEDIATE
+ immed SEMICOLON,';',docolon
+ DW REVEAL,CEXIT
+ DW LEFTBRACKET,EXIT
+
+;C ['] -- find word & compile as literal
+; ' ['] LIT ,XT , ; IMMEDIATE
+; When encountered in a colon definition, the
+; phrase ['] xxx will cause LIT,xxt to be
+; compiled into the colon definition (where
+; (where xxt is the execution token of word xxx).
+; When the colon definition executes, xxt will
+; be put on the stack. (All xt's are one cell.)
+ immed BRACTICK,"[']",docolon
+ DW TICK ; get xt of 'xxx'
+ DW LIT,LIT,COMMAXT ; append LIT action
+ DW COMMA,EXIT ; append xt literal
+
+;C POSTPONE -- postpone compile action of word
+; BL WORD FIND
+; DUP 0= ABORT" ?"
+; 0< IF -- xt non immed: add code to current
+; def'n to compile xt later.
+; ['] LIT ,XT , add "LIT,xt,COMMAXT"
+; ['] ,XT ,XT to current definition
+; ELSE ,XT immed: compile into cur. def'n
+; THEN ; IMMEDIATE
+ immed POSTPONE,"POSTPONE",docolon
+ DW BL,WORD,FIND,DUP,ZEROEQUAL,XSQUOTE
+ DW 1,'?'
+ DW QABORT,ZEROLESS,qbranch,POST1
+ DW LIT,LIT,COMMAXT,COMMA
+ DW LIT,COMMAXT,COMMAXT,branch,POST2
+:POST1 DW COMMAXT
+:POST2 DW EXIT
+
+;Z COMPILE -- append inline execution token
+; R> DUP CELL+ >R @ ,XT ;
+; The phrase ['] xxx ,XT appears so often that
+; this word was created to combine the actions
+; of LIT and ,XT. It takes an inline literal
+; execution token and appends it to the dict.
+; head COMPILE,7,COMPILE,docolon
+; DW RFROM,DUP,CELLPLUS,TOR
+; DW FETCH,COMMAXT,EXIT
+; N.B.: not used in the current implementation
+
+; CONTROL STRUCTURES ============================
+
+;C IF -- adrs conditional forward branch
+; ['] qbranch ,BRANCH HERE DUP ,DEST ;
+; IMMEDIATE
+ immed IF,"IF",docolon
+ DW LIT,qbranch,COMMABRANCH
+ DW HERE,DUP,COMMADEST,EXIT
+
+;C THEN adrs -- resolve forward branch
+; HERE SWAP !DEST ; IMMEDIATE
+ immed THEN,"THEN",docolon
+ DW HERE,SWOP,STOREDEST,EXIT
+
+;C ELSE adrs1 -- adrs2 branch for IF..ELSE
+; ['] branch ,BRANCH HERE DUP ,DEST
+; SWAP POSTPONE THEN ; IMMEDIATE
+ immed ELSE,"ELSE",docolon
+ DW LIT,branch,COMMABRANCH
+ DW HERE,DUP,COMMADEST
+ DW SWOP,THEN,EXIT
+
+;C BEGIN -- adrs target for bwd. branch
+; HERE ; IMMEDIATE
+ immed BEGIN,"BEGIN",docode
+ set pc,HERE
+
+;C UNTIL adrs -- conditional backward branch
+; ['] qbranch ,BRANCH ,DEST ; IMMEDIATE
+; conditional backward branch
+ immed UNTIL,"UNTIL",docolon
+ DW LIT,qbranch,COMMABRANCH
+ DW COMMADEST,EXIT
+
+;X AGAIN adrs -- uncond'l backward branch
+; ['] branch ,BRANCH ,DEST ; IMMEDIATE
+; unconditional backward branch
+ immed AGAIN,"AGAIN",docolon
+ DW LIT,branch,COMMABRANCH
+ DW COMMADEST,EXIT
+
+;C WHILE -- adrs branch for WHILE loop
+; POSTPONE IF ; IMMEDIATE
+ immed WHILE,"WHILE",docode
+ set pc,IF
+
+;C REPEAT adrs1 adrs2 -- resolve WHILE loop
+; SWAP POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE
+ immed REPEAT,"REPEAT",docolon
+ DW SWOP,AGAIN,THEN,EXIT
+
+;Z >L x -- L: -- x move to leave stack
+; CELL LP +! LP @ ! ; (L stack grows up)
+ head TOL,">L",docolon
+ DW CELL,LP,PLUSSTORE,LP,FETCH,STORE,EXIT
+
+;Z L> -- x L: x -- move from leave stack
+; LP @ @ CELL NEGATE LP +! ;
+ head LFROM,"L>",docolon
+ DW LP,FETCH,FETCH
+ DW CELL,NEGATE,LP,PLUSSTORE,EXIT
+
+;C DO -- adrs L: -- 0
+; ['] xdo ,XT HERE target for bwd branch
+; 0 >L ; IMMEDIATE marker for LEAVEs
+ immed DO,"DO",docolon
+ DW LIT,xdo,COMMAXT,HERE
+ DW LIT,0,TOL,EXIT
+
+;Z ENDLOOP adrs xt -- L: 0 a1 a2 .. aN --
+; ,BRANCH ,DEST backward loop
+; BEGIN L> ?DUP WHILE POSTPONE THEN REPEAT ;
+; resolve LEAVEs
+; This is a common factor of LOOP and +LOOP.
+ head ENDLOOP,"ENDLOOP",docolon
+ DW COMMABRANCH,COMMADEST
+:LOOP1 DW LFROM,QDUP,qbranch,LOOP2
+ DW THEN,branch,LOOP1
+:LOOP2 DW EXIT
+
+;C LOOP adrs -- L: 0 a1 a2 .. aN --
+; ['] xloop ENDLOOP ; IMMEDIATE
+ immed LOOP,"LOOP",docolon
+ DW LIT,xloop,ENDLOOP,EXIT
+
+;C +LOOP adrs -- L: 0 a1 a2 .. aN --
+; ['] xplusloop ENDLOOP ; IMMEDIATE
+ immed PLUSLOOP,"+LOOP",docolon
+ DW LIT,xplusloop,ENDLOOP,EXIT
+
+;C LEAVE -- L: -- adrs
+; ['] UNLOOP ,XT
+; ['] branch ,BRANCH HERE DUP ,DEST >L
+; ; IMMEDIATE unconditional forward branch
+ immed LEAVE,"LEAVE",docolon
+ DW LIT,unloop,COMMAXT
+ DW LIT,branch,COMMABRANCH
+ DW HERE,DUP,COMMADEST,TOL,EXIT
+
+; OTHER OPERATIONS ==============================
+
+;X WITHIN n1|u1 n2|u2 n3|u3 -- f n2<=n1<n3?
+; OVER - >R - R> U< ; per ANS document
+ head WITHIN,"WITHIN",docolon
+ DW OVER,MINUS,TOR,MINUS,RFROM,ULESS,EXIT
+
+;C MOVE addr1 addr2 u -- smart move
+; VERSION FOR 1 ADDRESS UNIT = 1 CHAR
+; >R 2DUP SWAP DUP R@ + -- ... dst src src+n
+; WITHIN IF R> CMOVE> src <= dst < src+n
+; ELSE R> CMOVE THEN ; otherwise
+ head MOVE,"MOVE",docolon
+ DW TOR,TWODUP,SWOP,DUP,RFETCH,PLUS
+ DW WITHIN,qbranch,MOVE1
+ DW RFROM,CMOVEUP,branch,MOVE2
+:MOVE1 DW RFROM,CMOVE
+:MOVE2 DW EXIT
+
+;C DEPTH -- +n number of items on stack
+; SP@ S0 SWAP - ;
+ head DEPTH,"DEPTH",docolon
+ DW SPFETCH,S0,SWOP,MINUS,EXIT
+
+;C ENVIRONMENT? c-addr u -- false system query
+; -- i*x true
+; 2DROP 0 ; the minimal definition!
+ head ENVIRONMENTQ,"ENVIRONMENT?",docolon
+ DW TWODROP,LIT,0,EXIT
+
+; UTILITY WORDS AND STARTUP =====================
+
+;X WORDS -- list all words in dict.
+; LATEST @ BEGIN
+; DUP COUNT TYPE SPACE
+; NFA>LFA @
+; DUP 0= KEY? OR UNTIL
+; DROP ;
+ head WORDS,"WORDS",docolon
+ DW LATEST,FETCH
+:WDS1 DW DUP,COUNT,TYPE,SPACE,NFATOLFA,FETCH
+ DW DUP,ZEROEQUAL,querykey,or,qbranch,WDS1
+ DW DROP,EXIT
+
+;X .S -- print stack contents
+; SP@ S0 - IF
+; SP@ S0 1- DO I @ U. LOOP
+; THEN ;
+ head DOTS,".S",docolon
+ DW SPFETCH,S0,MINUS,qbranch,DOTS2
+ DW SPFETCH,S0,ONEMINUS,XDO
+:DOTS1 DW II,FETCH,UDOT,XLOOP,DOTS1
+:DOTS2 DW EXIT
+
+;Z COLD -- cold start Forth system
+; UINIT U0 #INIT CMOVE init user area
+; 80 COUNT INTERPRET interpret CP/M cmd
+; ." Z80 CamelForth etc."
+; ABORT ;
+ head COLD,"COLD",docolon
+ DW UINIT,U0,NINIT,CMOVE
+ DW CLS,XSQUOTE
+ DW 23,'DCPU-16 CamelForth v1.0'
+ DW TYPE,CR,ABORT ; ABORT never returns
+
View
BIN  screenshot.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
Please sign in to comment.
Something went wrong with that request. Please try again.