Sfera development history
Description of the page content
Development history of Sfera, a library for QL SuperForth.
Tags:
2015-12-31
Forked the library of Solo Forth and removed most of the ZX Spectrum specific code. Started adapting some modules, to make a temporary boot file for SuperForth. Added some optional code bundled with SuperForth, and started a generic module to define windows, based on the Reversi game listed on the SuperForth manual. First tries to write a nestable include based on load_file.
( ============================================================== )
( Basic extensions )
LOWER
( ---------------------------------------------- )
( Comments )
: \ ( "ccc<eol>" -- )
10 word drop ; immediate
\ ----------------------------------------------
\ Address artithmetic
: cell+ ( a1 -- a2 ) 2+ ;
: cell- ( a1 -- a2 ) 2- ;
: cells ( a1 -- a2 ) 2* ;
: chars ( ca1 -- ca2 ) ; immediate
\ ----------------------------------------------
\ Stack
: nip ( x1 x2 -- x2 ) swap drop ;
: bounds ( ca len -- ca2 ca ) over + swap ;
\ ----------------------------------------------
\ Operators
: 0<> ( x1 x2 -- f ) = 0= ;
\ ----------------------------------------------
\ Word headers
: traverse ( a1 n -- a2 )
swap begin over + 127 over c@ < until
swap drop ;
\ Move across a name field. _a1_ is the address of either the
\ length byte or the last letter. If _n_=1, the motion is
\ toward hi memory; if _n_=-l, the motion is toward low
\ memory. The _a2_ resulting is the address of the other end
\ of the name.
\
\ Origin: fig-Forth.
: >name ( cfa -- nfa ) 1- -1 traverse ;
: name> ( nfa -- cfa ) 1 traverse 1+ ;
: name>link ( nfa -- lfa ) cell- ;
: name>body ( nfa -- pfa ) name> >body ;
: >link ( cfa -- lfa ) >name name>link ;
: body> ( pfa -- cfa ) cell- ;
: body>name ( pfa -- nfa ) body> >name ;
: executing? ( -- f ) state @ 0= ;
: compiling? ( -- f ) executing? 0= ;
64 constant immediate-mask
: immediate? ( cfa -- f ) >name c@ immediate-mask and ;
\ ----------------------------------------------
\ Parsing
: parse-word ( "name" -- ca ) bl word ;
: parse-name ( "name" -- ca len ) parse-word count ;
: defined ( "name" -- ca 0 | cfa 1 | cfa -1 ) parse-word find ;
: [undefined] ( "name" -- f ) defined nip 0= ; immediate
: [defined] ( "name" -- f ) [compile] [undefined] 0= ; immediate
\ ----------------------------------------------
\ Compiling
: compile, ( cfa -- ) , ;
: postpone ( "name" -- )
defined dup 0= 0 ?error ( cfa 1 | cfa -1 )
-1 = if compile compile \ non-immediate
then compile,
; immediate
\ ----------------------------------------------
\ Number prefixes
: c# ( "name" -- c )
parse-name drop c@
compiling? if postpone literal then ; immediate
\ Parse a name and return the code of the its first
\ character. This is an alternative to the standard words
\ `char` and `[char]`.
\ ----------------------------------------------
\ Strings
: s" ( "ccc<quote>" --- ca len )
c# " word dup count pad swap cmove c@ pad swap ;
\ ==============================================================
\ Tools
: binary ( -- ) 2 base ! ;
: hex. ( n -- ) base @ >r hex u. r> base ! ;
: bin. ( n -- ) base @ >r binary u. r> base ! ;
: (d.) ( d n -- ca len ) <# 0 do # loop #> ;
variable base'
: <hex ( -- ) base @ base' ! hex ; \ switch to hex
: hex> ( -- ) base' @ base ! ; \ and back
: (dhex.) ( d n -- ) <hex (d.) hex> type space ;
: 32hex. ( d -- ) 8 (dhex.) ;
: 16hex. ( n -- ) s->d 4 (dhex.) ;
: 8hex. ( b -- ) s->d 2 (dhex.) ;
: words ( -- )
latest ( lfa )
begin
dup id. space
@ dup 32768 = \ last?
until drop ;
: xwords ( -- )
latest ( lfa )
begin
dup link> 16hex dup id. space
@ dup 32768 = \ last?
until drop ;
: .n ( cfa -- ) >link id. ;
: .dump-address ( a -- ) cr 16hex. space ;
: (dump) ( ca len -- )
8 2dup mod - + 8 / 0
do
dup .dump-address
8 0 do i over + c@ 8hex. loop
dup 8 type
8 + loop drop ;
\ Show the contents of _n_ bytes starting from _ca_.
: dump ( ca len -- )
?dup if (dump) else drop then ;
\ Show the contents of _n_ bytes starting from _ca_.
: (wdump) ( a n -- )
0 do
i 4 mod 0= if dup .dump-address then
dup @ 16hex. cell+
loop drop ;
\ Show the contents of _n_ cells starting from _a_.
: wdump ( a n -- )
?dup if (wdump) else drop then ;
\ Show the contents of _n_ cells starting from _a_.
\ ==============================================================
\ Windows
\ Note: The main window can not be changed during interpretation
\ of a file, because `#in` is used to redirect the file being
\ interpreted to the keyboard (see section 10.1 of the
\ SuperForth manual).
exvec: default-colors ( -- )
: (default-colors) ( -- )
0 paper 4 ink 0 strip 0 set_mode 2 1 csize 2 1 border ;
assign default-colors to-do (default-colors)
default-colors cls
: set-window ( d -- )
2dup #in 2! #out 2! ;
\ Make channel _d_ the current window.
: set-default-channel ( d -- )
#default close ['] #default >body 2! ;
\ Make channel _d_ the default main window,
\ which is restored after an error.
: window ( d "name" -- )
2constant
does> ( -- ) ( dfa ) 2@ set-window ;
\ Create a word called "name" that, when executed,
\ will set channel _d_ as the current window.
: set-main-window ( d -- )
2dup set-window set-default-channel default-colors cls ;
\ Make channel _d_ the main window.
: main-window ( d "name" -- )
2constant
does> ( -- ) ( dfa )
2@ set-main-window ;
\ Create a word called "name" that, when executed,
\ will set channel _d_ as the main window.
0 open con_800x600a0x0 2dup 2constant #800x600
0 open con_1280x800a0x0 2dup 2constant #1280x800
: w800 ( -- ) #800x600 set-main-window ;
: w1280 ( -- ) #1280x800 set-main-window ;
cr
.( Words to change the main window:) cr
.( w800 = 800x600) cr
.( w1280 = 1280x800) cr
\ ==============================================================
\ Devices
: create_device ( "name" -- )
\ creates a new default device and enables you to
\ switch between it and mdv1_ etc. use is eg
\ create_device fdr1_ then fdr1_ will set a
\ device called fdr1_ as the default
create
latest 5 + @ \ get characters 3 and 4
dup 63 and 48 - , \ compile device number
, \ compile characters 3 and 4
latest 3 + @ , \ compile first 2 characters
does> ( -- ) ( pfa )
>r r@ @
r@ cell+ @
r> [ 2 cells ] literal + @
\ ." sdv parameters: " .s cr \ XXX INFORMER
sdv
;
create_device win1_
create_device nfa1_
create_device nfa4_
nfa4_
\ ==============================================================
\ Files
: include ( "name" -- )
cr .s \ XXX INFORMER
\ #in 2@ >r >r
#file 2@ >r >r
load_file \ XXX FIXME does nothing
\ XXX FIXME the channels are wrong
r> r> #file 2!
\ r> r> #in 2!
;
end_file
2016-01-01
Many changes and improvements:
( ============================================================== )
LOWER ( case-insensitive mode )
: noop ( -- ) ;
( ============================================================== )
( Comments )
: \ ( "ccc<eol>" -- )
10 word drop ; immediate
\ Ignore the rest of the input stream line.
: ?\ ( f "ccc<eol>" -- )
if [compile] \
then ; immediate
\ If _f_ is not zero, ignore the rest of the input stream line
\ ;
\ : Stack
: nip ( x1 x2 -- x2 ) swap drop ;
: tuck ( x1 x2 -- x2 x1 x2 ) swap over ;
: bounds ( ca len -- ca2 ca ) over + swap ;
\ ============================================================ ;
\ : Text output
: home ( -- ) 0 0 at ;
\ ============================================================ ;
\ : : Parsing
: parse-word ( "name" -- ca ) bl word ;
: parse-name ( "name" -- ca len ) parse-word count ;
: defined ( "name" -- ca 0 | cfa 1 | cfa -1 ) parse-word find ;
: [undefined] ( "name" -- f ) defined nip 0= ; immediate
: [defined] ( "name" -- f ) [compile] [undefined] 0= ; immediate
\ ============================================================ ;
\ : Compiling
: compile, ( cfa -- ) , ;
: postpone ( "name" -- )
defined dup 0= 0 ?error ( cfa 1 | cfa -1 )
-1 = if compile compile \ non-immediate
then compile,
; immediate
: executing? ( -- f ) state @ 0= ;
: compiling? ( -- f ) executing? 0= ;
\ ============================================================ ;
\ : Address artithmetic
: cell+ ( a1 -- a2 )
compiling? if postpone 2+ else 2+ then ; immediate
: cell- ( a1 -- a2 )
compiling? if postpone 2- else 2- then ; immediate
: cells ( a1 -- a2 )
compiling? if postpone 2* else 2* then ; immediate
: chars ( ca1 -- ca2 ) ; immediate
: char+ ( ca1 -- ca2 )
compiling? if postpone 1+ else 1+ then ; immediate
: char- ( ca1 -- ca2 )
compiling? if postpone 1- else 1- then ; immediate
\ ============================================================ ;
\ : Operators
: 0<> ( x -- f ) 0 <> ;
0 dup constant false
dup constant [false] immediate
0= dup constant true
constant [true] immediate
: on ( a -- ) true swap ! ;
: off ( a -- ) false swap ! ;
\ ============================================================ ;
\ : Word headers
: traverse ( ca1 n -- ca2 )
swap begin over + 127 over c@ < until
swap drop ;
\ Move across a name field. _ca1_ is the address of either the
\ length byte or the last letter. If _n_=1, the motion is
\ toward hi memory; if _n_=-l, the motion is toward low
\ memory. _ca2_ is the address of the other end
\ of the name.
\
\ Origin: fig-Forth.
: >name ( cfa -- nfa )
1- dup c@ bl = + \ skip a possible padding space
-1 traverse ;
: name> ( nfa -- cfa ) 1 traverse 1+ ;
: name>link ( nfa -- lfa ) cell- ;
: name>body ( nfa -- pfa ) name> >body ;
: >link ( cfa -- lfa ) >name name>link ;
: link>name ( lfa -- nfa ) cell+ ;
: link> ( lfa -- ffa ) link>name name> ;
: body> ( pfa -- cfa ) cell- ;
: body>name ( pfa -- nfa ) body> >name ;
: body>link ( pfa -- lfa ) body>name name>link ;
64 constant immediate-mask
: immediate? ( cfa -- f ) >name c@ immediate-mask and ;
31 constant /name
\ maximum length of a word name, also used as bitmask
: name>length ( nfa -- len )
dup >r c@ /name and dup
r> dup 1 traverse - abs <> abort" invalid name field"
dup 0= abort" name empty" ;
create name /name 1+ allot
0 name c! name 1+ /name blank
\ Name buffer.
: clean-name-bound ( ca -- ) dup c@ 127 and swap c! ;
\ Remove bit 7 from _ca_.
: clean-name ( -- )
name dup dup 1+ clean-name-bound
c@ + clean-name-bound ;
\ Remove bit 7 from the bounds of the name stored in the name buffer.
: name>string ( nfa -- ca len )
dup name>length dup name c! >r
1+ name 1+ r@ cmove clean-name name 1+ r> ;
: .name ( nfa -- )
name>string type ;
\ ============================================================ ;
\ : Number prefixes
exvec: adjust-number ( d -- d | n )
: single-number-prefix ( -- )
assign adjust-number to-do drop ;
: double-number-prefix ( -- )
assign adjust-number to-do noop ;
: numeric-prefix ( b "name" -- )
create c, immediate
does> ( "name" -- d | n ) ( pfa )
base @ >r c@ base !
parse-word number adjust-number postpone literal
r> base ! ;
: 2numeric-prefix ( b "name" -- )
double-number-prefix numeric-prefix single-number-prefix ;
2 numeric-prefix b# ( "name" -- n )
10 numeric-prefix d# ( "name" -- n )
16 numeric-prefix h# ( "name" -- n )
2 2numeric-prefix 2b# ( "name" -- d )
10 2numeric-prefix 2d# ( "name" -- d )
16 2numeric-prefix 2h# ( "name" -- d )
: c# ( "name" -- c )
parse-name drop c@
compiling? if postpone literal then ; immediate
\ Parse a name and return the code of the its first
\ character. This is an alternative to the standard words
\ `char` and `[char]`.
\ ============================================================ ;
\ : Number output
: binary ( -- ) 2 base ! ;
\ XXX OLD -- SuperForth has `h.`
\ : hex. ( n -- ) base @ >r hex u. r> base ! ;
: bin. ( n -- ) base @ >r binary u. r> base ! ;
: (d.) ( d n -- ca len ) <# 0 do # loop #> ;
variable base'
: <hex ( -- ) base @ base' ! hex ; \ switch to hex
: hex> ( -- ) base' @ base ! ; \ and back
: (dhex.) ( d n -- ) <hex (d.) hex> type space ;
: 32hex. ( d -- ) 8 (dhex.) ;
: 16hex. ( n -- ) s->d 4 (dhex.) ;
: 8hex. ( b -- ) s->d 2 (dhex.) ;
: <bin ( -- ) base @ base' ! binary ; \ switch to binary
: bin> ( -- ) base' @ base ! ; \ and back
: (dbin.) ( d n -- ) <bin (d.) bin> type space ;
: 32bin. ( d -- ) 32 (dbin.) ;
: 16bin. ( n -- ) s->d 16 (dbin.) ;
: 8bin. ( b -- ) s->d 8 (dbin.) ;
\ ============================================================ ;
\ : Control structures
: again ( -- ) postpone 0 postpone until ; immediate
\ ============================================================ ;
\ : Strings
: s" ( "ccc<quote>" --- ca len )
c# " word dup count pad swap cmove c@ pad swap ;
\ ============================================================ ;
\ : Keyboard
: .keyrow ( n -- )
0 over at dup . keyrow 8bin. ;
\ Print keyrow _n_.
: .keyrows ( n -- )
s->d time d+
begin
8 0 do i .keyrow loop 2dup time d<
until 2drop ;
\ Print the keyboard matrix during _n_ seconds.
: control-key? ( -- f ) 7 keyrow b# 00000010 and 0<> ;
: shift-key? ( -- f ) 7 keyrow b# 00000001 and 0<> ;
: alt-key? ( -- f ) 7 keyrow b# 00000100 and 0<> ;
: space-key? ( -- f ) 1 keyrow b# 01000000 and 0<> ;
: escape-key? ( -- f ) 1 keyrow b# 00001000 and 0<> ;
: enter-key? ( -- f ) 1 keyrow b# 00000001 and 0<> ;
: tab-key? ( -- f ) 5 keyrow b# 00001000 and 0<> ;
: break-key? ( -- f ) control-key? space-key? and ;
: key? ( -- f )
0 8 0 do i keyrow or loop 0<> ;
\ XXX FIXME -- never returns, why?
: no-key ( -- ) begin key? 0= until ;
: timeout! ( n -- ) [ ' timeout >body ] literal ! ;
\ Store _n_ into the constant `timeout`.
\ XXX FIXME
: inkey ( -- c )
timeout >r 1 timeout! key r> timeout! ;
\ Key the pressed key, if any (without waiting for a key
\ press).
\ XXX OLD
: aborted? ( c -- f )
key? if no-key key = else drop false then ;
\ If no key is pressed return _false_. If a key is pressed,
\ discard it and wait for a second key. Ther return _true_ if
\ it's _c_, else return _false_.
\ Usage example:
\
\ : listing ( -- )
\ begin ." bla " bl aborted? until ." Aborted" ;
\ XXX OLD
10 constant 'cr' \ code of carriage return
: nuf? ( -- f ) 'cr' aborted? ;
: wait-space-key-pressed ( -- ) begin space-key? 0= until ;
: wait-space-key-released ( -- ) begin space-key? until ;
: space-paused ( -- )
space-key? if
wait-space-key-pressed
wait-space-key-released
wait-space-key-pressed
then ;
: wait-enter-key-pressed ( -- ) begin enter-key? 0= until ;
: wait-enter-key-released ( -- ) begin enter-key? until ;
: enter-paused ( -- )
enter-key? if
wait-enter-key-pressed
wait-enter-key-released
wait-enter-key-pressed
then ;
\ ============================================================ ;
\ : Tools
: first-word? ( lfa1 -- lfa2 f ) @ dup 32768 = ;
: words ( -- )
latest ( lfa )
begin
dup id. space space-paused
first-word? escape-key? or
until drop ;
2016-01-02
This tool prints a table of all SuperForth words, with their header data, which makes me think the author obfuscated the code.
: first-word? ( lfa1 -- lfa2 f ) @ dup 32768 = ;
: words ( -- )
latest ( lfa )
begin
dup id. space space-paused
first-word? escape-key? or
until drop ;
: | ( -- ) ." | " ;
: table ( -- ) cr ." |===" ;
: .xheader-field ( n -- ) | 16hex. ;
: .xtype ( cfa -- )
dup @ over >body = if drop ." CODE " exit then
dup @ h# 87C6 = if drop ." : " exit then
dup @ h# 879A = if drop ." CREATE " exit then
dup @ h# 96D0 = if drop ." 2CONSTANT " exit then
dup @ h# 877C = if drop ." CONSTANT " exit then
@ h# 9542 = if ." EXVECT: " exit then
." unknown " ;
: .xheader ( lfa -- )
cr dup .xheader-field dup link> >r
r@ >name .xheader-field
r@ .xheader-field
r@ @ .xheader-field space
r@ >body .xheader-field
r> | .xtype
| id. ;
: xwords ( -- )
table
cr ." | LFA | NFA | CFA | Code | PFA | Type | Name" cr
latest ( lfa )
begin
dup .xheader space-paused
first-word? escape-key? or
until drop table ;
\ File access methods
0 constant old-exclusive
1 constant old-shared
2 constant new-exclusive
3 constant directory
status nfa4_printout.txt ( ior )
\ file does not exist: ior = 0
\ file already exist: ior = -8 (other errors are ignored)
0= abs 2* \ calculate file access method
open nfa4_printout.txt #print 2!
: xwords>printer ( -- )
printer_on xwords printer_off ;
Added xstack, needed to try a different approach for include. The code is modified in order to use the data space instead of the heap, which is not implemented.
\ ============================================================ ;
\ xstack
\ Creation and core manipulation of xstacks
\ Code adapted from Solo Forth
0 value xsize 0 value xp 0 value xp0
\ Values of the current xstack:
\ xsize = size in address units (constant)
\ xp = address of the xstack pointer (variable)
\ xp0 = initial value of the xstack pointer (constant)
: xstack ( n "name" -- )
\ Create a new xstack of _n_ cells.
create
cells \ size
here [ 3 cells cell- ] literal + dup \ bottom and top
, , ,
\ +0 = xp0
\ +2 = xp
\ +4 = xsize
allot
does> ( -- )
\ Make an xstack the current one.
( pfa ) dup @ to xp0 cell+ dup to xp cell+ @ to xsize ;
: xp@ ( -- a ) xp @ ;
: xp! ( a -- ) xp ! ;
: xp+! ( n -- ) xp +! ;
: xclear ( -- ) xp0 xp! ;
\ xstack single-number operations
: >x ( x -- ) ( X: -- x ) cell xp+! xp@ ! ;
: x@ ( -- x ) ( X: x -- x ) xp@ @ ;
: xdrop ( X: x -- ) [ cell negate ] literal xp+! ;
: x> ( -- x ) ( X: x -- ) x@ xdrop ;
: xdup ( X: x -- x x ) x@ >x ;
: xpick ( n -- x'n ) ( X: x'n ... x'0 -- x'n ... x'0 )
xp@ swap cells - @ ;
: xover ( X: x1 x2 -- x1 x2 x1 ) 1 xpick >x ;
\ xstack double-number operations
: 2x@ ( -- x1 x2 ) ( X: x1 x2 -- x1 x2 ) x@ 1 xpick swap ;
: 2>x ( x1 x2 -- ) ( X: -- x1 x2 ) swap >x >x ;
: 2x> ( -- x1 x2 ) ( X: x1 x2 -- ) x> x> swap ;
: 2xdrop ( X: x1 x2 -- ) [ -2 cells ] literal xp+! ;
: 2xdup ( X: x1 x2 -- x1 x2 x1 x2 ) xover xover ;
\ xstack tools
: xlen ( -- n ) xp@ xp0 - ;
\ Length of the current xstack, in address units.
: xdepth ( -- n ) xlen cell / ;
\ Depth of the current xstack.
: xdepth. ( -- ) ." <" s->d <# #s #> type ." > " ;
: (.x) ( -- ) xp0 cell+ xlen bounds do i @ . cell +loop ;
\ Display a list of the items in the xstack; TOS is the right-most item.
: .x ( -- ) xdepth dup xdepth. if (.x) then ;
\ Display the number of items on the current xstack,
\ followed by a list of the items, if any; TOS is the right-most item.
After several tries, include and end-of-file are ready. They are wrappers of the original load_file and end_file respectively, allowing nesting of sources. The next step is require. Then the library will be divided into modules.
\ ============================================================ ;
\ : Files
\ ----------------------------------------------
\ XXX try 8
\ XXX it works!
: include ( "name" -- d1 d2 )
#in 2@ #file 2@ load_file ;
: end-of-file ( d1 d2 -- )
end_file #file 2! 2dup #in 2!
#default d= 0= if assign prompt to-do noop then ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 7
\ XXX it works, but error "invalid channel id" is shown at the
\ end, and then "enter" produces spaces without solution
8 xstack include-stack
\ stack to nest the included files
: include ( "name" -- )
assign prompt to-do noop
#in 2@ include-stack 2>x
0 open 2dup #file 2!
2dup 2>x
#in 2! ;
: end-of-file ( -- )
include-stack 2x@ close
include-stack 2x@ 2dup #in 2!
#default d= if assign prompt to-do ok then ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 6
\ XXX it works, but prints "ok" after every source line, and
\ causes error invalid channel id" at the end
8 xstack include-stack
\ stack to nest the included files
: include ( "name" -- )
#in 2@ include-stack 2>x
0 open 2dup #file 2!
2dup 2>x
#in 2! ;
: end-of-file ( -- )
include-stack 2x@ close
include-stack 2x@ #in 2! ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 5
\ XXX it works, but prints "ok" after every source line, and
\ causes error invalid channel id" at the end
8 xstack include-stack
\ stack to nest the included files
: include ( "name" -- )
#in 2@ include-stack 2>x
0 open 2dup #file 2!
#in 2! ;
: end-of-file ( -- )
#file 2@ close
include-stack 2x@
#in 2! ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 4
\ XXX it works, but at the end doesn't print "ok" anymore,
\ until you force an error, and then error "invalid channel id"
\ happens.
: include ( "name" -- d1 d2 )
#in 2@ #file 2@ load_file ;
: end-of-file ( d1 d2 -- )
#file 2@ close #file 2! #in 2! ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 3
\ XXX it works, but gives error "invalid channel id" at the
\ end
: include ( "name" -- d )
#in 2@ load_file ;
: end-of-file ( d -- )
end_file #in 2! ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 2
\ XXX it works, but prints 4 "ok" at the end
: include ( "name" -- d1 d2 )
#in 2@ #file 2@ load_file ;
: end-of-file ( d1 d2 -- )
end_file #file 2! #in 2! ;
end_file \ XXX TMP
\ ----------------------------------------------
\ XXX try 1
\ XXX FIXME -- freeze!
: include ( "name" -- )
r>
#in 2@ >r >r
#file 2@ >r >r
load_file
>r
;
: end-of-file ( -- )
r>
r> r> #file 2!
r> r> #in 2!
>r
;
end_file \ XXX TMP
2016-01-03
New version of include, which replaces load_file with equivalent code. This change was needed in order to implement included, required and require:
: include ( "name" -- d1 d2 )
#in 2@ #file 2@
\ load_file \ XXX OLD
0 open 2dup #file 2! #in 2! \ XXX NEW
assign prompt to-do noop
;
: end-of-file ( d1 d2 -- )
end_file
#file 2! 2dup #in 2!
#default d= 0= if assign prompt to-do noop then ;
Improved version, which uses an extra stack for nesting, instead of the data stack. This is needed in order to make all these words standard.
8 2 * xstack include-stack
\ Stack to nest the included files.
\ 8 nestings, 2 cells each.
: include ( "name" -- )
include-stack
#in 2@ 2>x
#file 2@ 2>x
load_file ;
: end-of-file ( -- )
end_file
include-stack
2x> #file 2!
2x> 2dup #in 2!
#default d= 0= if assign prompt to-do noop then ;
Improved version with included:
8 constant include-levels
include-levels 2 * xstack include-stack
\ Stack for the included files.
\ 2 cells per include level.
41 constant /filename
/filename string filename
: filename-included ( -- )
include-stack #in 2@ 2>x #file 2@ 2>x
0 filename open_device 2dup #file 2! #in 2!
assign prompt to-do noop ;
: included ( ca len -- )
filename string! filename-included ;
: include ( "name" -- )
parse-name included ;
: end-of-file ( -- )
end_file
include-stack
2x> #file 2!
2x> 2dup #in 2!
#default d= 0= if assign prompt to-do noop then ;
2016-01-04
Implementation of string lists.
\ Code based on Gforth's public-domain file
\ <compat/required.fs>. Modified to use SuperForth's counted
\ strings, and data space instead of the heap.
: string>list ( ca a -- )
here >r
dup @ , \ point this node to the previous one
r> swap ! \ point the list to this node
, ; \ point to the string pair in node
\ Add string _ca_ to the list pointed by _a_.
exvec: string= ( ca1 ca2 -- f )
\ Compare two strings.
assign string= to-do $==
\ Case-insensitive comparison by default.
: string-listed? ( ca a -- f )
swap >r
begin ( a ) ( R: ca ) dup while
dup cell+ @ r@ string= if
drop r> drop true exit
then @
repeat drop r> drop false ;
\ Is the filename stored in _ca_ in the list pointed by _a_?
: ?string>list ( ca len a -- )
2dup string-listed? if 2drop else string>list then ;
\ Add string _ca len_ to
Fixed >name and name>, which caused the wrong results of xwords; aligned and invert were needed.
: invert ( x1 -- x2 ) -1 xor ;
: aligned ( a -- a' )
[ cell 1 - dup ] literal + [ invert ] literal and ;
\ Code adapted from eForth.
: >name ( cfa -- nfa )
\ 1- dup c@ bl = + \ skip a possible padding space
dup 1- c@ 0= 2* + \ skip a possible padding zero
-1 traverse ;
: name> ( nfa -- cfa ) 1 traverse 1+ aligned ;
: first-word? ( lfa1 -- lfa2 f ) @ dup 32768 = ;
: words ( -- )
latest ( lfa )
begin
dup id. space space-paused
first-word? escape-key? or
until drop ;
: | ( -- ) ." | " ;
: table ( -- ) cr ." |===" ;
: .xheader-field ( n -- ) | 16hex. ;
: .xtype ( cfa -- )
dup @ over >body = if drop ." CODE " exit then
dup @ h# 87C6 = if drop ." : " exit then
dup @ h# 87AA = if drop ." USER " exit then
dup @ h# 879A = if drop ." CREATE " exit then
dup @ h# 96D0 = if drop ." 2CONSTANT " exit then
dup @ h# 877C = if drop ." CONSTANT " exit then
dup @ h# 960A = if drop ." VOCABULARY " exit then
@ h# 9542 = if ." EXVECT: " exit then
." CODE (not at PFA) " ;
: .xheader ( lfa -- )
cr dup .xheader-field dup link> >r
r@ >name .xheader-field
r@ .xheader-field
r@ @ .xheader-field
r@ >body .xheader-field
r> | .xtype
| id. ;
: xwords ( -- )
table
cr ." | LFA | NFA | CFA | Code | PFA | Type | Name" cr
latest ( lfa )
begin
dup .xheader space-paused
first-word? escape-key? or
until drop table ;
2016-01-05
Fixed >name again. The mistery is solved: System words pad the name fields with a zero, while user words use a space. The new calculation works in both cases:
: >name ( cfa -- nfa )
1- dup c@ 128 and 0= + \ skip a possible padding
-1 traverse ;
2016-01-06
First modules extracted from the main file: decode, dump, words, xwords.
First working version of decode, with two important improvements: automatic mode and headerless words.
Fixed [else]: the problem was the string comparison operators compare also the max length bytes. A new operator was coded, based on locate:
: different-lengths? ( ca1 ca2 -- f )
length swap length <> ;
: $$= ( ca1 ca2 -- f )
2dup different-lengths? if 2drop false exit then
1 0 locate ( 1 | 0 ) negate ;
\ Case-sensitive comparison of counted strings.
: $$== ( ca1 ca2 -- f )
2dup different-lengths? if 2drop false exit then
1 1 locate ( 1 | 0 ) negate ;
\ Case-insensitive comparison of counted strings.
\ Alternatives:
: $$= ( ca1 ca2 -- f )
2dup length swap length - 0= >r
1 0 locate ( 1 | 0 ) negate r> and ;
\ Case-sensitive comparison of counted strings.
: $$== ( ca1 ca2 -- f )
2dup length swap length - 0= >r
1 1 locate ( 1 | 0 ) negate r> and ;
\ Case-insensitive comparison of counted strings.
But [else] is not finished: it works only on the current source line. refill is needed.
2016-01-07
Started adapting the assembler of F83-68K.
Improved decode with a useful factor in order to decode from an arbitrary address. Added more headerless words.
2016-01-08
Simplifed the number prefixes. Now one single set is used for both single and double numbers; dpl is checked at the end in order to convert the final double number to single or not.
Wrote first versions of code and end-code.
Added the original floating point module from SuperForth, renamed all words after standard Forth, and used code and end-code.
Improved decode with support for variables, user variables, constants, and double constants. More headerless words are recognized.
2016-01-09
Made endcase standard and modified default accordingly.
Improved and fixed decode: support for code words; invalid names caused by headerless words are detected and a warning is shown instead, they don't cause trouble anymore.
Added load-code, after the original load_bin.
Created an include file with the macros required to assemble code words, from the example file included with SuperForth. Tried the first example, 3dup. Both assembly files were adapted to the syntax of the (asmx assembler).
Realized that the SuperForth IP is an actual 32-bit address, and so it occupies two cells on the return stack. This is reason the usual definitions of 2>r and 2r> didn't work:
\ XXX OLD
\ : 2>r ( x1 x2 -- ) ( R: -- x1 x2 ) r> rot >r swap >r >r ;
\ XXX NEW
: 2>r ( x1 x2 -- ) ( R: -- x1 x2 ) r> r> 2swap swap >r >r >r >r ;
\ XXX OLD
\ : 2r> ( -- x1 x2 ) ( R: x1 x2 -- ) r> r> r> swap rot >r ;
\ XXX NEW
: 2r> ( -- x1 x2 ) ( R: x1 x2 -- ) r> r> r> r> swap 2swap >r >r ;
Implemented the first words in assembler: rdrop, 2rdrop and unloop.
Rewrote again as postpone branch <resolve instead of postpone 0 postpone until.
2016-01-10
Wrote refill, finished [if] [else] [then].
2016-01-11
Rewrote nip and tuck in assembly.
Fixed again; ?pairs was missing, but it's headerless, so it must be recreated:
: ?pairs ( -- ) ?comp [ h# 930E ] compile, ; immediate
: again ( -- ) ?pairs postpone branch <resolve ; immediate
Started writting set-font in assembly.
Wrote float and floats in assembly.
Wrote >a, origin and +origin, but there are some issues with absolute addresses.
2016-01-12
Wrote adump to examine memory regions outside the SuperForth memory space.
Started debugging the list of included files.
Started adapting turnkey and related words.
Started adapting SuperBASIC's scr_base, scr_xlim, scr_ylim and scr_llen, using the sources of SMSQ/E.
2016-01-13
Fixed >a and wrote aorigin instead of origin.
2016-01-14
Finished the pop_l assembly macro.
word_marker equ $4AFB ; to mark the start of a code word
next macro ; Forth next
; a1 = Forth IP
move.w (a1)+,d1 ; d1 = cfa of the next word
movea.w 0(a2,d1.w),a5 ; a5 = content of its code
jmp 0(a2,a5.w) ; execute the code
endm
code macro name,after
dc.w word_marker ; start of a definition
dc.b .name_end-.name_start ; name length
.name_start
dc.b name ; name
.name_end
even ; pad to an even address
dc.w after-*-2 ; code length
endm
end_code_definitions macro ; must be placed at end of the code
dc.w 0
endm
push_w macro register
; Push _register_ on the Forth data stack as a 1-cell number.
move.w d2,-(a3) ; TOS -> NOS
move.w register,d2 ; register -> TOS
endm
pop_w macro register
; Pop 1-cell number from the Forth data stack and move it to
; _register_.
move.w d2,register ; TOS -> register
move.w (a3)+,d2 ; NOS -> TOS
endm
push_l macro register
; Push _register_ on the Forth data stack as a 2-cell number.
move.w d2,-(a3) ; TOS -> NOS
move.w register,-(a3) ; low part of register -> NOS
move.l register,d2
swap d2 ; high part of register -> TOS
endm
pop_l macro register
; Pop 2-cell number from the Forth data stack and move it to
; _register_.
move.w d2,register ; high cell to low half of register
swap register ; high cell to high half of register
move.w (a3)+,d2 ; low cell to low half of d2
swap d2
clr.w d2 ; clear high half of d2
swap d2
or.l d2,register ; combine
move.w (a3)+,d2 ; new TOS
endm
Started some code definitions, based on code written by Dilwyn Jones for his Display Extensions V2.01. Finished one of them:
include 'inc_macros_asm'
include 'inc_labels_asm'
code 'GET-MODE',get_mode_end ; ( -- n )
move.w d2,-(sp) ; save SuperForth's TOS
moveq #mt_dmode,d0
move.b #-1,d1 ;READ mode
move.b #-1,d2 ;READ display (incidental here)
trap #1
; d1.b=display mode number
clr.l d0 ;empty top 3 bytes
move.b d1,d0 ;mode number for conversion to fp
move.w (sp)+,d2 ; restore SuperForth's TOS
push_w d0
next
get_mode_end equ *
end_code_definitions
end
Fixed save-string: the length byte was not included in the alloted space, so the last char of the string was overwritten later.
: save-string ( ca1 len1 -- ca2 )
dup c, \ max length
here >r dup 1+ allot r@ string! r> ;
\ Compile a string _ca1 len1_ a return its address.
Removed all old code from the main file.
Wrote screen-size in assembly:
include 'inc_macros_asm'
include 'inc_labels_asm'
code 'SCREEN-SIZE',screen_size_end ; ( -- x y )
move.l a0,-(sp) ; save SuperForth's a0
moveq.l #mt_inf,d0
trap #1 ; call mt.inf
; a0 = address of system variables
move.l sys_clnk(a0),a5 ; a5 = console linkage block
move.w pt_xscrs(a5),d0 ; d0 = x
push_w d0 ; push x on the Forth stack
move.w pt_yscrs(a5),d0 ; d0 = y
push_w d0 ; push y on the Forth stack
move.l (sp)+,a0 ; restore SuperForth's a0
next
screen_size_end equ *
end_code_definitions
end
2016-01-15
Wrote os-version in assembly.
include 'inc_macros_asm'
include 'inc_labels_asm'
code 'OS-VERSION',os_version_end ; ( -- d )
; d = OS version in ASCII (n.nn)
move.l a0,-(sp) ; save the SuperForth a0
move.w d2,-(sp) ; save the SuperForth TOS
moveq #mt_inf,d0
trap #1
move.l d2,d3 ; preserve the result
move.w (sp)+,d2 ; restore the SuperForth TOS
move.l (sp)+,a0 ; restore the SuperForth a0
push_l d3 ; result
next
os_version_end equ *
Moved the standard endcase to its own file. So far it's required only by decode.
Finished version 0.1.0. Uploaded the repository to GitHub.
2016-01-17
Wrote new words in assembly: machine, processor, display. The Forth 68000 assembler would be a better choice, in order to reuse the code. Anyway these words can be written in Forth, they only need sys-vars.
2016-01-22
Wrote aallocate, afree and aunused.
2016-01-23
Rewrote aunused.
Renamed screen-size to get-display-size.
Fixed, improved and documented aallocate and afree.
2016-01-25
Implemented defer, defer!, defer@, defers, is, action-of, adapted from Solo Forth and Afera.
2016-01-26
Finished version 0.2.0. Updated the GitHub repository.
2016-01-28
Changed the stack macros suffixes after the Forth notations n and d. Added a new stack macro push_l which puts the low part on TOS, after the memory order. This is useful to fetch certain values which are interpreted as strings, like the system identifier "SMSQ".
2016-02-07
Wrote an improved version of include and related words, which don't need end-of-file.
false [if] \ XXX OLD method -- `end-of-file` is needed
: nest-included ( -- )
include-stack #in 2@ 2>x #file 2@ 2>x
0 filename open_device 2dup #file 2! #in 2!
no-prompt ;
: unnest-included ( -- )
2x> #file 2! 2x> 2dup #in 2!
#default d= 0= if no-prompt then ;
: end-of-file ( -- )
end_file include-stack xdepth if unnest-included then ;
[else] \ XXX NEW method -- no word needed at the end of the files
\ Improved version of `include` that does not need a word to
\ mark the end of the file.
: default-errors ( -- )
assign error to-do (error) ;
exvec: including-error
: catch-eof-error ( -- )
assign error to-do including-error ;
: including-mode-off ( -- ) default-errors default-prompt ;
: including-mode-on ( -- ) catch-eof-error no-prompt ;
: unnest-included ( -- )
2x> #file 2! 2x> 2dup #in 2!
#default d= if including-mode-off then ;
: end-of-included ( -- )
end_file including-mode-on
include-stack xdepth if unnest-included then ;
: (including-error) ( n -- )
dup -10 = \ end of file?
if drop end-of-included
else including-mode-off error then ;
assign including-error to-do (including-error)
: nest-included ( -- )
include-stack #in 2@ 2>x #file 2@ 2>x
0 filename open_device 2dup #file 2! #in 2!
including-mode-on ;
: end-of-file ( -- ) ; \ XXX TMP -- for backward compatibility
[then]
: included ( ca len -- ) ?filename>list nest-included ;
: include ( "name" -- ) parse-word included ;
: required ( ca len -- )
2dup included? if 2drop
else filename>list nest-included then ;
: require ( "name" -- ) parse-word required ;
2016-02-08
Added a Forth source file wrapper for every binary extension. This way the including does not depend on haw the words were implemented.
2016-02-09
Added a circular string buffer and more string words.
Added dp, align, move.
2016-02-10
- Finished the path system for source files.
\ ============================================================ ;
\ : Paths
5 constant /device
\ Maximum length of a device.
36 constant /filename
\ Maximum length of a filename.
/device /filename + string filename
\ A temporary string variable which holds the current filename.
: filename! ( ca len -- ) filename string! ;
8 constant paths \ paths in the table
2 cells constant /path \ bytes per path item in the table
paths /path * constant /paths-table \ length of the paths table
create paths-table /paths-table allot \ paths table
: erase-paths ( -- ) paths-table /paths-table erase ;
erase-paths
: >path ( n -- a ) /path * paths-table + ;
\ Return address _a_ of path number _n_.
: path! ( ca len n -- ) >path 2! ;
: path@ ( n -- ca len ) >path 2@ ;
: (pathed) ( ca len -- ca' len' )
paths 0 do
i path@
\ 2dup cr ." path " i . ." =" type \ XXX INFORMER
2over s+
\ 2dup cr type \ XXX INFORMER
2dup file-exists? if 2swap 2drop unloop exit
else 2drop then
loop ;
: .paths ( -- ) paths 0 do i . i path@ type cr loop ;
: pathed ( ca len -- ca' len' )
2dup file-exists? 0= if (pathed) then ;
\ Add to filename _ca len_ the first path the file can be
\ found in, if needed.
Added trap1, trap3, trap3*, ?os-error.
2016-02-11
Simplified the path searching: created one more path in the table, removed pathed and renamed (pathed) to pathed. The trick is keeping path 0 empty, and configuring only paths 1..8.
Fixed set-default-channel: it closed #default, which frozed the system the second time.
Improved the path system with >path (after Gforth's >order), also-path and previous-path (after standard Forth's also and previous:
: >path-address ( n -- a ) /path * paths-table + ;
\ Return address _a_ of path number _n_.
: path! ( ca len n -- ) >path-address 2! ;
: path@ ( n -- ca len ) >path-address 2@ ;
: copy-paths ( a1 a2 -- )
[ paths 2- /path * ] literal move ;
\ Copy all paths from _a1_ to _a2_.
: also-path ( -- )
[ 1 >path-address ] literal \ origin
[ 2 >path-address ] literal \ destination
copy-paths ;
\ Copy all paths from path 1 to path 2.
\ The first two paths become identical.
\ The last path is lost.
: previous-path ( -- )
[ 2 >path-address ] literal \ origin
[ 1 >path-address ] literal \ destination
copy-paths ;
\ Copy all paths from path 2 to path 1.
\ Path 1 is lost.
\ The last two paths become identical.
: >path ( ca len -- ) also-path 1 path! ;
\ Add path _ca len_ to the top of the paths list.
\ The last path is lost.
Fixed boot: closing errors are catched and ignored:
: closing-error ( n -- )
dup -6 = \ channel not open?
if drop else (error) then ;
: catch-close-error ( -- )
assign error to-do closing-error ;
: boot ( -- )
catch-close-error
#print 2@ close #file 2@ close
default-errors
boot-device cold ;
\ Boot the system.
\ XXX FIXME `fence` is restored by `cold`
Added a source file bench_fs with basic words for benchmarking.
Benchmarked the alternative definitions of $$= and $$== and discarded them.
Moved ?\ to its own file.
2016-02-12
Fixed the renaming of unused to spared, which marked "r" as the final character.
Wrote ununderscore, a utility for replacing underscores with hyphens in the original words of SuperForth.
Checked no-key and key?: they work fine. It seems the problem was the sticky keys programmed on the keyboard.