forth5mx_extend.fs
Descripción del contenido de la página
Fichero fuente con las extensiones en Forth de Forth 5mx, un Forth para la computadora Psion 5mx, escrito en OPL+.
Código fuente
\ forth5mx_extend.fs
\ Copyright (C) 2005-2010 Marcos Cruz (http://programandala.net)
\ This file is part of Forth 5mx.
\ Forth 5mx 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 2
\ 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://gnu.org/licenses>.
\ Comment marks:
\ :!!! = not finished
\ ?!!! = to be explored
\ *!!! = debug
\ Notation for the data stack arguments:
\ a-addr = cell-aligned address
\ addr = address
\ b = byte
\ c = printable character
\ char = printable character
\ c-addr = character-aligned address
\ f = flag
\ fam = file access method
\ fid = file identifier
\ ior = input/output result
\ n = signed number
\ +n = positive number
\ nt = name token
\ pfa = parameter field address (data field)
\ d = double number
\ u = unsigned number
\ ud = unsigned double number
\ x = unspecified cell
\ xt = execution token
10 BASE ! UNUSED
\ MARKER forth5mx_extend
.( Extending...) CR
\ ************************
\ .( -Core )
: ' ( -- xt ) \ Core
BL WORD DUP FIND
0= ROT COUNT ?abort
;
: ." \ Core
?compiling
POSTPONE S" POSTPONE TYPE
; IMMEDIATE
: <resolve ( -- )
HERE CELL+ - ,
;
: resolve> ( a-addr -- )
HERE OVER CELL+ - SWAP !
;
: <mark ( -- a-addr )
\ Set up a backward branch by leaving the current address on the stack.
HERE
;
: mark> ( -- a-addr )
\ Mark the point of a forward branch by saving its address on the stack.
HERE 0 ,
;
1 CONSTANT if-mark
2 CONSTANT else-mark
3 CONSTANT begin-mark
4 CONSTANT while-mark
5 CONSTANT do-mark
6 CONSTANT endof-mark
7 CONSTANT of-mark
: IF \ Core
?compiling
POSTPONE 0branch mark> if-mark
; IMMEDIATE
: THEN \ Core
?compiling
DUP if-mark <> SWAP else-mark <> AND
S" IF missing" ?abort
resolve>
; IMMEDIATE
: unstructured ( u1 u2 c-addr3 u3 -- )
2SWAP <> IF error THEN 2DROP
;
: ELSE \ Core
?compiling
if-mark S" IF missing" unstructured
POSTPONE branch mark> SWAP resolve> else-mark
; IMMEDIATE
: BEGIN \ Core
?compiling
<mark begin-mark
; IMMEDIATE
: UNTIL \ Core
?compiling
begin-mark S" BEGIN missing" unstructured
POSTPONE 0branch <resolve
; IMMEDIATE
: WHILE \ Core
?compiling
begin-mark S" BEGIN missing" unstructured
POSTPONE 0branch mark> while-mark
; IMMEDIATE
: REPEAT \ Core
?compiling
while-mark S" WHILE missing" unstructured
POSTPONE branch SWAP <resolve resolve>
; IMMEDIATE
: DO \ Core
?compiling
POSTPONE (do) mark> <mark do-mark
; IMMEDIATE
: ?DO \ Core
?compiling
POSTPONE (?do) mark> <mark do-mark
; IMMEDIATE
: LOOP \ Core
?compiling
do-mark S" DO missing" unstructured
POSTPONE (loop) <resolve resolve>
; IMMEDIATE
: +LOOP \ Core
?compiling
do-mark S" DO missing" unstructured
POSTPONE (+loop) <resolve resolve>
; IMMEDIATE
: -LOOP \ gforth
\ :!!! *!!! experimental
?compiling
do-mark S" DO missing" unstructured
POSTPONE (-loop) <resolve resolve>
; IMMEDIATE
: ABORT" ( f -- ) \ Core
?compiling POSTPONE S" POSTPONE ?abort
; IMMEDIATE
: 2! \ Core
SWAP OVER ! CELL+ !
;
: 2@ \ Core
DUP CELL+ @ SWAP @
;
: BLANK \ Core
BL FILL
;
: S>D \ Core
\ Taken from gforth.
DUP 0<
;
: LITERAL ( Compile time: x -- ; Run time: -- x ) \ Core
?compiling POSTPONE (literal) ,
; IMMEDIATE
: ['] \ Core ( -- )
?compiling ' POSTPONE LITERAL
; IMMEDIATE
\ : literal, POSTPONE (literal) , ;
\ : ['] ?compiling ' literal, ; IMMEDIATE
\ : LITERAL ?compiling literal, ; IMMEDIATE
: use ( xt -- ) \ PsiForth
\ xt or cfa ?!!!
\ Modify the code field content of the latest word, thereby
\ giving it a different run time behaviour.
\ latest name> ! \ PsiForth
@ latest name> ! \ Forth 5mx
;
: CHAR ( "<spaces>name" -- c ) \ Core
BL WORD CHAR+ C@
;
: [CHAR] ( Compilation: "<spaces>name" -- ; Run-time: -- c ) \ Core
?compiling
CHAR POSTPONE LITERAL
; IMMEDIATE
: DECIMAL ( -- ) \ Core
10 BASE !
;
: next-header ( nt1 -- nt2 ) \ PsiForth
1-
;
: headers ( xt -- ) \ PsiForth
\ Executes xt for every word in the dictionary.
\ In the first execution, the nt of the last word is on the stack.
>R latest
BEGIN ?DUP WHILE R@ EXECUTE REPEAT
R> DROP
;
: >name ( xt -- nt ) \ Forth 5mx
cell- @
;
: DOES> ( -- ) \ Core
R> latest name> ['] (does>) >name
OVER ! CELL+ !
;
: RECURSE ( -- ) \ Core
latest name> POSTPONE LITERAL POSTPONE EXECUTE
; IMMEDIATE
\ WORDLIST CONSTANT environment-wordlist
\ environment-wordlist DEFINITIONS
\ ENVIRONTMENT? strings:
\ /COUNTED-STRING is a high level constant
\ /HOLD is undefined
\ /PAD is a high level constant
FALSE CONSTANT BLOCK
FALSE CONSTANT BLOCK-EXT
FALSE CONSTANT CORE
FALSE CONSTANT CORE-EXT
FALSE CONSTANT DOUBLE
FALSE CONSTANT DOUBLE-EXT
FALSE CONSTANT EXCEPTION
FALSE CONSTANT EXCEPTION-EXT
FALSE CONSTANT FACILITY
FALSE CONSTANT FACILITY-EXT
FALSE CONSTANT FILE
FALSE CONSTANT FILE-EXT
FALSE CONSTANT FLOATING
FALSE CONSTANT FLOATING-EXT
\ FALSE CONSTANT FLOATING-STACK
\ FALSE CONSTANT FLOORED
\ FALSE CONSTANT MAX-D
\ FALSE CONSTANT MAX-FLOAT
\ FALSE CONSTANT MAX-N
\ FALSE CONSTANT MAX-U
\ FALSE CONSTANT MAX-UD
FALSE CONSTANT MEMORY-ALLOC
\ RETURN-STACK-CELLS is a high level constant
\ STACK-CELLS is a high level constant
FALSE CONSTANT SEARCH-ORDER
FALSE CONSTANT SEARCH-ORDER-EXT
FALSE CONSTANT STRINGS
FALSE CONSTANT TOOLS
FALSE CONSTANT TOOLS-EXT
\ WORDLISTS is a high level constant
: ENVIRONMENT? ( c-addr u -- false | i*x true )
\ Unfinished!!!
\ environtment-wordlist search-wordlist \ :!!! Gforth
find-name DUP IF
name> EXECUTE TRUE
THEN
;
\ FORTH DEFINITIONS
\ ************************
\ .( -Core Ext )
\ Commented out untill >NUMBER is defined:
\ : CONVERT ( ud1 c-addr1 -- ud2 c-addr2 ) CHAR+ 65535 >NUMBER DROP ;
: HEX ( -- ) \ Core Ext
16 BASE !
;
: AGAIN \ Core Ext
?compiling
begin-mark S" BEGIN missing" unstructured
POSTPONE branch <resolve
; IMMEDIATE
: CASE ( Compilation: -- 0 u ; Run-time: x -- x ) \ Core Ext
?compiling
0 endof-mark
; IMMEDIATE
: OF ( u endof-mark -- addr u of-mark ) \ Core Ext
?compiling
endof-mark pluck IF S" ENDOF missing" ELSE S" CASE missing" THEN unstructured
>R
POSTPONE (of)
mark>
R> 1+ of-mark
; IMMEDIATE
: ENDOF ( addr u of-mark -- addr u endof-mark ) \ Core Ext
?compiling
of-mark S" OF missing" unstructured
>R
POSTPONE branch
mark> SWAP
resolve>
R> endof-mark
; IMMEDIATE
: ENDCASE ( Compile: addr_1...addr_u u endof-mark -- ; Run-time: x -- ) \ Core Ext
?compiling
endof-mark S" ENDOF missing" unstructured
POSTPONE DROP
?DUP IF
0 DO resolve> LOOP
THEN
; IMMEDIATE
: VALUE ( x -- ) \ Core Ext
CREATE , ['] (value) use
;
: <to> ( x "<spaces>name" -- ) \ Forth 5mx
' >BODY !
;
: [to] ( Compile: "<spaces>name" -- ; Run: x -- ) \ Forth 5mx
' >BODY POSTPONE LITERAL POSTPONE !
; IMMEDIATE
: TO ( Interpretation: x "<spaces>name" -- ; Compilation: "<spaces>name" -- ; Run-time: x -- ) \ Core Ext
STATE @
IF POSTPONE [to]
ELSE <to>
THEN
; IMMEDIATE
-1 CONSTANT -1
0 CONSTANT 0
1 CONSTANT 1
2 CONSTANT 2
: link ( addr -- ) \ PsiForth
\ ?!!! unused
HERE SWAP exchange ,
\ ?!!! exchange used only here
;
: ERASE ( addr u -- ) \ Core Ext
0 FILL
;
: WITHIN ( test low high -- f ) \ Core Ext
\ Taken from the ANS Forth documentation.
OVER - >R - R> U<
;
: sconstant ( c-addr u -- ) \ Forth 5mx
CREATE s, ALIGN
DOES> COUNT
;
: message: ( c-addr u -- ) \ PsiForth
CREATE s, ALIGN
DOES> COUNT TYPE SPACE
;
: error: ( c-addr u -- ) \ PsiForth
CREATE S, ALIGN
DOES> COUNT error
;
: array ( u -- ) \ PsiForth
CREATE
['] doarray use
CELLS ALLOT
;
: table \ PsiForth
CREATE
['] dotable use
;
: lookup:
CREATE HERE 0 ,
DOES> lookup
;
: ;lookup
HERE OVER CELL+ -
2 CELLS / SWAP !
;
: follow
0 BEGIN
SWAP ?DUP WHILE
thread SWAP 1+
REPEAT
;
: threads ( -- )
\ show # members per thread
#threads 0 DO
I DUP 7 AND 0= IF CR THEN
DUP 4 .R 1+ thread follow 2 .R
LOOP
;
\ ************************
\ CR .( -Double)
: 2VARIABLE \ Double
CREATE 2 CELLS ALLOT
;
: 2LITERAL ( d -- ) \ Double
\ Taken from eForth.
SWAP POSTPONE LITERAL POSTPONE LITERAL
; IMMEDIATE
\ : DNEGATE ( d -- -d )
\ Taken from eForth.
\ INVERT >R INVERT 1 UM+ R> +
\ ;
\ : D- ( d1 d2 -- d3 ) \ Double
\ Taken from hForth and eForth.
\ DNEGATE D+
\ ;
\ : DNEGATE ( d -- -d )
\ Taken from pForth.
\ 0 0 2SWAP d-
\ ;
: D>S ( d -- n ) \ Double
DROP
;
\ ************************
\ CR .( -Double Ext)
: 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) \ Double Ext
2>R 2SWAP 2R> 2SWAP
;
\ ************************
\ .(-File )
KIoOpenModeOpen
KIoOpenFormatBinary or
KIoOpenAccessRandom or
CONSTANT r/o \ read only file access method
\ This access method sets the file position to the start.
KIoOpenModeAppend
KIoOpenFormatBinary or
KIoOpenAccessRandom or
KIoOpenAccessUpdate or
DUP
CONSTANT w/o \ write only file access method
CONSTANT r/w \ read and write file access method
\ This access methods set the file position to the end.
: BIN ( fam1 -- fam2 ) \ File
\ Change file access method from text to binary.
\ It does nothing, because all files are opened in binary mode.
\ Old code:
\ KIoOpenFormatText INVERT AND KIoOpenFormatBinary OR
;
: REPOSITION-FILE ( ud fid -- ior ) \ File
\ Reset the file position to ud .
\ It doesn't work with files opened in text mode.
>R D>S R> \ :!!!
1 ( mode) SWAP seek-file
SWAP DROP
;
: rewind-file ( fid -- ior ) \ Forth 5mx
\ System specific version of REPOSITION-FILE .
\ Rewind a text file to the start.
\ It doesn't work with files opened in binary mode.
0 ( offset) 6 ( mode) ROT seek-file
SWAP DROP
;
\ not finished
\ defer (rewind)
\ ' REPOSITION-FILE is (rewind)
\ : rewind ( fid -- ) \ Common use
\ 0 DUP ROT
\ ;
: FILE-POSITION ( fid -- ud ior ) \ File
\ Return the current file position.
\ It doesn't work with files opened in text mode.
0 ( offset) 3 ( mode) ROT seek-file
>R S>D R>
;
: FILE-SIZE ( fid -- ud ior ) \ File
\ Return the file size.
\ Unfinished:
\ It doesn't work with files opened in text mode.
\ It returns a dummy ior flag, always false :!!!
DUP DUP file-position ( fid fid d ior -- ) \ current file position
ABORT" file-position error in file-size"
ROT 0 ( offset) 2 ( mode) ROT seek-file \ move file pointer to the end to get the file size
ABORT" seek-file error in file-size"
>R ROT REPOSITION-FILE \ preserve the file size and restore the file pointer
ABORT" reposition-file error in file-size"
R> S>D \ file lenght
FALSE \ dummy ior flag :!!!
;
: include? ( "<spaces>word<spaces>filename" -- ) \ Taken from pForth
BL WORD FIND
IF BL WORD 2DROP
ELSE DROP include
THEN
;
' include? alias require \ a more common name
\ ************************
\ .(-String )
: /STRING ( c-addr1 u1 +n -- c-addr2 u2 ) \ String
DUP >R - SWAP R> + SWAP
;
: str= ( c-addr1 u1 c-addr2 u2 -- f ) \ gforth
COMPARE 0=
;
: str< ( c-addr1 u1 c-addr2 u2 -- f ) \ gforth
COMPARE 0<
;
: string-prefix? ( c-addr1 u1 c-addr2 u2 -- f ) \ gforth
\ Is c-addr2 u2 a prefix of c-addr1 u1 ?
TUCK 2>R MIN 2R> str=
;
\ ************************
\ .(-Tools )
: ? ( addr -- ) \ Tools
@ .
;
: .S ( -- ) \ Tools
DEPTH DUP 0> IF
BEGIN DUP
WHILE DUP PICK . 1-
REPEAT
ELSE
S" stack empty" TYPE
THEN DROP
;
: more ( -- f) \ PsiForth
\ f = TRUE (no key pressed, or other than Escape)
\ f = FALSE (Escape key pressed)
KEY? DUP IF
KEY esc <> IF
CR S" --- more ---" TYPE
KEY esc = AND
THEN
THEN
NOT
;
15 CONSTANT #creators
#creators array creator
: creator" ( n -- ) \ PsiForth
HERE SWAP creator !
[CHAR] " WORD COUNT S,
;
0 creator" primitive"
1 creator" :"
2 creator" variable"
3 creator" variable" \ primitive variable
4 creator" constant"
5 creator" 2constant"
6 creator" does>"
7 creator" defer"
8 creator" uvariable" \ ?!!! psiforth
9 creator" array" \ ?!!! psiforth
10 creator" table" \ ?!!! psiforth
11 creator" code" \ ?!!! psiforth
12 creator" create"
13 creator" value"
14 creator" marker"
ALIGN
: .creator ( nt -- ) \ Forth 5mx
DUP #creators > AND
DUP IF
name> @ DUP #creators < AND
THEN
creator @ COUNT 11 OVER - SPACES TYPE SPACE
;
: .header ( nt -- nt ) \ PsiForth
CR DUP 6 .R
DUP name> 7 .R
BL OVER immediate? IF DROP [CHAR] # THEN EMIT
DUP .creator
DUP .name
next-header more AND
;
: WORDS ( -- ) \ Tool
['] .header headers
;
\ ************************
\ .(-Tools Ext )
\ The data stack is used as control stack:
' pick alias CS-PICK
' roll alias CS-ROLL
\ S" forth5mx_extend_[if].fs" INCLUDED
: [if]? ( c-addr u -- f )
S" [IF]" COMPARE 0=
;
: [else]? ( c-addr u -- f )
S" [ELSE]" COMPARE 0=
;
: [then]? ( c-addr u -- f )
S" [THEN]" COMPARE 0=
;
: [ELSE] ( -- ) \ Tools Ext
\ Skip the code until [THEN] is found.
\ Code taken from pforth.
1 \ recursion level
BEGIN
BEGIN
\ parse-word DUP \ (this some times causes a "string too long OPL error" because of the parse-word implementation)
BL WORD COUNT DUP \ (the classic way
WHILE
2DUP upper
2DUP [if]?
IF
2DROP 1+
ELSE
2DUP [else]?
IF
2DROP 1- DUP IF 1+ THEN
ELSE
[then]? IF 1- THEN
THEN
THEN
?DUP 0= IF EXIT THEN
REPEAT
2DROP REFILL 0=
UNTIL
; IMMEDIATE
: [IF] ( f -- ) \ Tools Ext
\ If TOS is true, skip the code until [THEN] is found.
\ Code taken from pforth.
0= IF POSTPONE [ELSE] THEN
; IMMEDIATE
: [THEN] ( -- ) \ Tools Ext
; IMMEDIATE
\ ************************
\ .( -Facility Ext )
: TIME&DATE ( -- sec min hour day month year )
second minute hour day month year
;
\ ************************
\ .(-Not ANS ) \ common use
: on ( a-addr -- ) \ Common use
TRUE SWAP !
;
: off ( a-addr -- ) \ Common use
FALSE SWAP !
;
: [defined] \ Common use
BL WORD FIND NIP 0<>
; IMMEDIATE
: [ifdef] \ Common use
POSTPONE [defined]
POSTPONE [IF]
; IMMEDIATE
: [undefined] \ Common use
POSTPONE [defined] INVERT
; IMMEDIATE
: [ifundef] \ Common use
POSTPONE [undefined]
POSTPONE [IF]
; IMMEDIATE
: endif \ Common use
POSTPONE THEN ; IMMEDIATE
: defer ( "<spaces>name" -- ) \ Common use
CREATE ['] noop , ['] (defer) use
;
: <is> ( xt "<spaces>name" -- ) \ gforth
' >BODY !
;
: [is] ( compilation: "<spaces>name" -- ; run-time: xt -- ) \ gforth
' >BODY POSTPONE LITERAL POSTPONE !
; IMMEDIATE
: is ( xt "<spaces>name" -- ) \ Common use
STATE @ IF POSTPONE [is]
ELSE <is>
THEN
; IMMEDIATE
: svariable ( "<spaces>name" -- ) \ Common use
CREATE 256 CHARS ALLOT ALIGNED
;
: place ( c-addr1 u1 c-addr2 --) \ Common use
\ From "An so Forth..." by J.L. Bezemer (2001-04-06):
\ OVER OVER >R >R CHAR+ SWAP CHARS CMOVE R> R> C!
\ My own version, from my fstr toolkit (I called it STR! ):
2DUP C! 1+ SWAP CMOVE
;
: binary ( -- ) \ Common use
2 BASE !
;
FALSE [IF]
: alias ( xt "<spaces>name" -- ) \ Common use
CREATE ,
DOES> @ EXECUTE
;
[THEN]
: under+ ( n1 n2 n3 -- n4 n2 ) \ Common use
ROT + SWAP
;
: bounds ( c-addr1 u1 -- c-addr2 c-addr1 ) \ Common use
OVER + SWAP
;
: under ( x1 x2 x3 -- x3 x2 ) \ Common use
ROT DROP SWAP
;
\ ************************
\ Facility Ext (defered)
defer EMIT?
' TRUE is EMIT?
\ ************************
\ - Not ANS - Forth 5mx
: -seconds \ Forth 5mx
( second minute hour day month year -- seconds )
\ Calculates time diference in seconds between the date given and now.
date>secs TIME&DATE date>secs SWAP -
;
: pwd \ Forth 5mx
path TYPE
;
create 'newline
2 c, 13 c, 10 c, \ dos: cr lf
: newline ( -- c-addr u )
\ Used in Gforth.
\ Needed by the Forth Foundation Libray (in config.fs).
\ 2010-03-21
'newline count
;
: string, ( -- c-addr u )
\ Used in Gforth.
\ Needed by the Forth Foundation Libray (in config.fs).
\ 2010-03-21
dup c, here swap dup allot move
;
\ ************************
\ - Sound
: play:
\ 2006 08 16 I Simplified the PsiForth version: no sound path.
CREATE ( c-addr u -- )
s, ALIGN
DOES> ( pfa -- )
COUNT play
;
\ Examples:
\ S" c:\sounds\01" play: one
\ S" d:\doc\tmp\cock" play: cock
: bell 16 200 beep ;
: error-bell bell bell bell ;
\ ' error-bell error-sound-xt !
error-sound? on
\ ************************
\ Drafts and debugging
0 [IF]
: MARKER ( "<spaces>name" -- ) \ Core Ext
\ :!!!
HERE latest
CREATE , ,
DOES> DUP @ (latest) ! CELL+ @ dp !
;
[THEN]
: .thread ( -- )
#threads 1+ 1
DO
I thread CR .
LOOP
;
\ ************************
\ Debug tools
: debug-included
\ Redefine INCLUDED to detect unbalanced stack.
\ 2007-06-19
S" ' INCLUDED : INCLUDED LITERAL EXECUTE DEPTH IF 10 10 beep [CHAR] * EMIT KEY DROP THEN ;" EVALUATE
;
\ ************************
\ Provisional
\ Words that must exist but are not developed yet.
: FORTH ;
: ONLY ;
: ALSO ;
: root ;
: DEFINITIONS CONTEXT @ CURRENT ! ;
: SET-CURRENT ( wid -- ) CURRENT ! ;
: GET-CURRENT ( -- @ ) CURRENT @ ;
: environment ; \ in the future this will be a word-list
: forth5mx ; \ this will be in the environment word-list and will return some info
: FALIGNED ALIGNED ;
\ ************************
\ Dummy
: · CR ." Warning: Char · found" ; \ just to avoid the error caused by this symbol, left at the end of file texts by some editors
\ ************************
\ License
: license ( -- )
cr
." This program is free software; you can redistribute it and/or modify" cr
." it under the terms of the GNU General Public License as published by" cr
." the Free Software Foundation; either version 2 of the License, or" cr
." (at your option) any later version." cr cr
." This program is distributed in the hope that it will be useful," cr
." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr
." GNU General Public License for more details." cr cr
." You should have received a copy of the GNU General Public License" cr
." along with this program. If not, see <http://gnu.org/licenses>." cr
;
\ ************************
\ Preferences
error-sound? on
debug? on
\ ************************
\ Free memory
UNUSED TUCK -
CR .( Memory stats: )
. .( bytes compiled, )
. .( bytes free)
CR