Commit 9aa981da authored by anton's avatar anton

added code.fs (code, ;code, end-code, assembler)

renamed dostruc to dofield
made index and doc-entries nicer
Only words containing 'e' or 'E' are converted to FP numbers.
added many wordset comments
added flush-icache primitive and FLUSH_ICACHE macro
added +DO, U+DO, -DO, U-DO and -LOOP
added code address labels (`docol:' etc.)
fixed sparc cache_flush
parent 1c166a20
......@@ -55,7 +55,7 @@ KERN_SRC = main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs version.fs extend.fs tools.fs toolsext.fs
FORTH_SRC = anslocal.fs add.fs assert.fs ansi.fs blocks.fs bufio.fs checkans.fs \
colorize.fs cross.fs debug.fs debugging.fs doskey.fs ds2texi.fs \
code.fs colorize.fs cross.fs debug.fs debugging.fs doskey.fs ds2texi.fs \
dumpimage.fs environ.fs errore.fs etags.fs extend.fs filedump.fs \
float.fs glocals.fs glosgen.fs gray.fs hash.fs history.fs \
kernal.fs locals-test.fs look.fs main.fs makedoc.fs \
......@@ -181,7 +181,7 @@ test: gforth
@echo 'Expect to see INCORRECT RESULT: { GS1 -> <TRUE> <TRUE> }'
@echo 'This is a bug of the testing program'
$(FORTH) tester.fs coretest.fs -e bye
$(FORTH) startup.fs blocks.fs checkans.fs -e bye
$(FORTH) startup.fs blocks.fs code.fs checkans.fs -e bye
@echo 'Expect no differences'
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-c process-file bye"| diff -c - primitives.i
......@@ -273,8 +273,8 @@ version.c: Makefile.in
doc.fd: makedoc.fs float.fs search-order.fs glocals.fs environ.fs \
toolsext.fs wordinfo.fs \
vt100.fs colorize.fs see.fs bufio.fs debug.fs history.fs \
doskey.fs vt100key.fs startup.fs assert.fs debugging.fs
$(FORTH) -e "s\" doc.fd\"" makedoc.fs startup.fs -e bye
doskey.fs vt100key.fs startup.fs assert.fs debugging.fs code.fs
$(FORTH) -e "s\" doc.fd\"" makedoc.fs startup.fs code.fs -e bye
gforth.texi: gforth.ds primitives.b ds2texi.fs prims2x.fs doc.fd crossdoc.fd
$(FORTH) ds2texi.fs >$@
......
......@@ -3,19 +3,20 @@ distribution for the general public, since it is not yet mature
enough. There is no warranty of any kind; this program is
distributed under the GNU General Public license (see COPYING).
Read INSTALL for installation instructions. Mail us if you have
problems.
Read INSTALL for installation instructions. Mail us
(anton@mips.complang.tuwien.ac.at,paysan@informatik.tu-muenchen.de) if
you have problems.
To start the system just say `gforth'. This gives you a pretty barren
system. `gforth startup.fs' gives you most ANSI wordsets. If you miss
a word, just grep for it in *.fs.
If you want to work on gforth, mail me. Tasks to be done can be found
in ToDo; but if you would like to do something not mentioned there,
it's ok, too. In any case, we would like to hear what you are
doing. The most important tasks IMO are the missing ANS Forth words
(musts before the alpha release), the documentation and the foreign
language interface for C.
If you want to work on gforth, mail me. Tasks to be done can be found in
ToDo; but if you would like to do something not mentioned there, it's
ok, too. In any case, we would like to hear what you are doing. The
most important tasks IMO are the missing ANS Forth words (musts before
the alpha release), the documentation and the foreign language
interface for C.
On popular request, here are the meanings of unusual file extensions:
......@@ -27,3 +28,5 @@ On popular request, here are the meanings of unusual file extensions:
*TAGS etags files
- anton
anton@mips.complang.tuwien.ac.at
http://www.complang.tuwien.ac.at/anton/home.html
\ No newline at end of file
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.28 1995-09-06 21:00:11 pazsan Exp $
\ $Id: cross.fs,v 1.29 1995-10-07 17:38:11 anton Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992-94 by the GNU Forth Development Group
......@@ -120,7 +120,7 @@ H
-4 Constant :dovar
-5 Constant :douser
-6 Constant :dodefer
-7 Constant :dostruc
-7 Constant :dofield
-8 Constant :dodoes
-9 Constant :doesjump
......@@ -483,7 +483,7 @@ ghost (loop) ghost (+loop) 2drop
ghost (next) drop
ghost unloop ghost ;S 2drop
ghost lit ghost (compile) ghost ! 2drop drop
ghost (;code) ghost noop 2drop
ghost (does>) ghost noop 2drop
ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost '
......@@ -571,7 +571,7 @@ Cond: [ restrict? state off ;Cond
>TARGET
Cond: DOES> restrict?
compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
compile (does>) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
;Cond
: DOES> dodoes, T here H !does depth T ] H ;
......@@ -695,7 +695,7 @@ Build: >r rot r@ nalign dup T , H ( align1 size offset )
+ swap r> nalign ;
DO: T @ H + ;DO
Builder Field
by Field :dostruc resolve
by Field :dofield resolve
: struct T 0 1 chars H ;
: end-struct T 2Constant H ;
......
......@@ -9,9 +9,10 @@
script? [IF]
warnings off
include search-order.fs
include struct.fs
include debugging.fs
require search-order.fs
require float.fs
require struct.fs
require debugging.fs
[THEN]
wordlist constant documentation
......@@ -72,12 +73,17 @@ create description-buffer 4096 chars allot
drop ;
: print-short ( doc-entry -- )
>r ." @format" cr
>r
." @findex "
r@ doc-name 2@ typetexi
." @var{ " r@ doc-stack-effect 2@ type ." } "
r@ doc-wordset 2@ type
cr
." @format" cr
." @code{" r@ doc-name 2@ typetexi ." } "
." @i{" r@ doc-stack-effect 2@ type ." } "
r@ doc-wordset 2@ type ." ``"
r@ doc-pronounciation 2@ type ." ''" cr ." @end format" cr
." @findex " r@ doc-name 2@ typetexi cr
rdrop ;
: print-doc ( doc-entry -- )
......@@ -85,7 +91,8 @@ create description-buffer 4096 chars allot
r@ print-short
r@ doc-description 2@ dup 0<>
if
type ." @*" cr
." @iftex" cr ." @vskip-3ex" cr ." @end iftex" cr
type cr cr \ ." @ifinfo" cr ." @*" cr ." @end ifinfo" cr cr
else
2drop cr
endif
......@@ -133,7 +140,7 @@ create docline doclinelength chars allot
drop rdrop ;
script? [IF]
include prims2x.fs
require prims2x.fs
s" primitives.b" ' register-doc process-file
require doc.fd
require crossdoc.fd
......
......@@ -261,7 +261,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
&&dovar,
&&douser,
&&dodefer,
&&dostruc,
&&dofield,
&&dodoes,
&&dodoes, /* dummy for does handler address */
#include "prim_labels.i"
......@@ -357,9 +357,9 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
cfa = *(Xt *)PFA1(cfa);
NEXT1;
dostruc:
dofield:
#ifdef DEBUG
fprintf(stderr,"%08x: struc: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
fprintf(stderr,"%08x: field: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
TOS += *(Cell*)PFA1(cfa);
NEXT_P0;
......
......@@ -26,9 +26,10 @@
: f, ( f -- ) here 1 floats allot f! ;
: fconstant ( r -- )
: fconstant ( r -- ) \ float
Create f,
DOES> f@ ;
DOES> ( -- r )
f@ ;
: fdepth ( -- n ) f0 @ fp@ - [ 1 floats ] Literal / ;
......@@ -68,16 +69,26 @@
scratch over c@ emit '. emit 1 /string type
'E emit . ;
require debugging.fs
: sfnumber ( c-addr u -- r / )
2dup >float
2dup [CHAR] e scan
dup 0=
IF
2drop 2dup [CHAR] E scan
THEN
nip
IF
2drop state @
2dup >float
IF
postpone FLiteral
2drop state @
IF
POSTPONE FLiteral
THEN
EXIT
THEN
ELSE
defers notfound
THEN ;
THEN
defers notfound ;
' sfnumber IS notfound
......@@ -105,10 +116,20 @@
\ : facosh fdup fdup f* 1.0e0 f- fsqrt f+ fln ;
\ : fasinh fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ;
: f~ ( f1 f2 f3 -- flag ) fdup f0= IF fdrop f= EXIT THEN
fdup f0> IF frot frot f- fabs fswap
ELSE fnegate frot frot fover fabs fover fabs f+ frot frot
f- fabs frot frot f* THEN f< ;
\ !! factor out parts
: f~ ( f1 f2 f3 -- flag ) \ float-ext
fdup f0=
IF
fdrop f= EXIT
THEN
fdup f0>
IF
frot frot f- fabs fswap
ELSE
fnegate frot frot fover fabs fover fabs f+ frot frot
f- fabs frot frot f*
THEN
f< ;
: f.s ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0
?DO dup i - 1- floats fp@ + f@ f. LOOP drop ;
......@@ -74,6 +74,12 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
#define CF_NIL -1
#ifndef CACHE_FLUSH
# define CACHE_FLUSH(addr,size)
#ifndef FLUSH_ICACHE
# define FLUSH_ICACHE(addr,size) 0
#endif
#ifdef DIRECT_THREADED
#define CACHE_FLUSH(addr,size) FLUSH_ICACHE(addr,size)
#else
#define CACHE_FLUSH(addr,size) 0
#endif
......@@ -35,3 +35,7 @@ The GForth manual is available in hypertext (Info, HTML) and printable
(TeX, PS) forms.
The ANS Forth document (i.e., the standard).
More information on Gforth (e.g., pointers to new versions, to the
manual on the WWW and to papers about Gforth) is available through
\fChttp://www.complang.tuwien.ac.at/projects/forth.html\fR.
......@@ -269,6 +269,7 @@ then in @file{~}, then in the normal path (see above).
* Blocks::
* Other I/O::
* Programming Tools::
* Assembler and Code words::
* Threading Words::
@end menu
......@@ -808,13 +809,27 @@ There are several variations on the counted loop:
@code{LEAVE} leaves the innermost counted loop immediately.
If @var{start} is greater than @var{limit}, a @code{?DO} loop is entered
(and @code{LOOP} iterates until they become equal by wrap-around
arithmetic). This behaviour is usually not what you want. Therefore,
Gforth offers @code{+DO} and @code{U+DO} (as replacements for
@code{?DO}), which do not enter the loop if @var{start} is greater than
@var{limit}; @code{+DO} is for signed loop parameters, @code{U+DO} for
unsigned loop parameters. These words can be implemented easily on
standard systems, so using them does not make your programs hard to
port; e.g.:
@example
: +DO ( compile-time: -- do-sys; run-time: n1 n2 -- )
POSTPONE over POSTPONE min POSTPONE ?DO ; immediate
@end example
@code{LOOP} can be replaced with @code{@var{n} +LOOP}; this updates the
index by @var{n} instead of by 1. The loop is terminated when the border
between @var{limit-1} and @var{limit} is crossed. E.g.:
@code{4 0 ?DO i . 2 +LOOP} prints @code{0 2}
@code{4 0 +DO i . 2 +LOOP} prints @code{0 2}
@code{4 1 ?DO i . 2 +LOOP} prints @code{1 3}
@code{4 1 +DO i . 2 +LOOP} prints @code{1 3}
The behaviour of @code{@var{n} +LOOP} is peculiar when @var{n} is negative:
......@@ -822,23 +837,34 @@ The behaviour of @code{@var{n} +LOOP} is peculiar when @var{n} is negative:
@code{ 0 0 ?DO i . -1 +LOOP} prints nothing
Therefore we recommend avoiding using @code{@var{n} +LOOP} with negative
@var{n}. One alternative is @code{@var{n} S+LOOP}, where the negative
case behaves symmetrical to the positive case:
Therefore we recommend avoiding @code{@var{n} +LOOP} with negative
@var{n}. One alternative is @code{@var{u} -LOOP}, which reduces the
index by @var{u} each iteration. The loop is terminated when the border
between @var{limit+1} and @var{limit} is crossed. Gforth also provides
@code{-DO} and @code{U-DO} for down-counting loops. E.g.:
@code{-2 0 ?DO i . -1 S+LOOP} prints @code{0 -1}
@code{-2 0 -DO i . 1 -LOOP} prints @code{0 -1}
@code{-1 0 ?DO i . -1 S+LOOP} prints @code{0}
@code{-1 0 -DO i . 1 -LOOP} prints @code{0}
@code{ 0 0 ?DO i . -1 S+LOOP} prints nothing
@code{ 0 0 -DO i . 1 -LOOP} prints nothing
The loop is terminated when the border between @var{limit@minus{}sgn(n)} and
@var{limit} is crossed. However, @code{S+LOOP} is not part of the ANS
Forth standard.
Another alternative is @code{@var{n} S+LOOP}, where the negative
case behaves symmetrical to the positive case:
@code{-2 0 -DO i . -1 S+LOOP} prints @code{0 -1}
@code{?DO} can be replaced by @code{DO}. @code{DO} enters the loop even
when the start and the limit value are equal. We do not recommend using
@code{DO}. It will just give you maintenance troubles.
The loop is terminated when the border between @var{limit@minus{}sgn(n)}
and @var{limit} is crossed. Unfortunately, neither @code{-LOOP} nor
@code{S+LOOP} are part of the ANS Forth standard, and they are not easy
to implement using standard words. If you want to write standard
programs, just avoid counting down.
@code{?DO} can also be replaced by @code{DO}. @code{DO} always enters
the loop, independent of the loop parameters. Do not use @code{DO}, even
if you know that the loop is entered in any case. Such knowledge tends
to become invalid during maintenance of a program, and then the
@code{DO} will make trouble.
@code{UNLOOP} is used to prepare for an abnormal loop exit, e.g., via
@code{EXIT}. @code{UNLOOP} removes the loop control parameters from the
......@@ -894,11 +920,16 @@ doc-repeat
Counted loop words constitute a separate group of words:
doc-?do
doc-+do
doc-u+do
doc--do
doc-u-do
doc-do
doc-for
doc-loop
doc-s+loop
doc-+loop
doc--loop
doc-next
doc-leave
doc-?leave
......@@ -1526,7 +1557,7 @@ locals wordset.
@node Other I/O, Programming Tools, Blocks, Words
@section Other I/O
@node Programming Tools, Threading Words, Other I/O, Words
@node Programming Tools, Assembler and Code words, Other I/O, Words
@section Programming Tools
@menu
......@@ -1625,7 +1656,43 @@ If there is interest, we will introduce a special throw code. But if you
intend to @code{catch} a specific condition, using @code{throw} is
probably more appropriate than an assertion).
@node Threading Words, , Programming Tools, Words
@node Assembler and Code words, Threading Words, Programming Tools, Words
@section Assembler and Code words
Gforth provides some words for defining primitives (words written in
machine code), and for defining the the machine-code equivalent of
@code{DOES>}-based defining words. However, the machine-independent
nature of Gforth poses a few problems: First of all. Gforth runs on
several architectures, so it can provide no standard assembler. What's
worse is that the register allocation not only depends on the processor,
but also on the gcc version and options used.
The words Gforth offers encapsulate some system dependences (e.g., the
header structure), so a system-independent assembler may be used in
Gforth. If you do not have an assembler, you can compile machine code
directly with @code{,} and @code{c,}.
doc-assembler
doc-code
doc-end-code
doc-;code
doc-flush-icache
If @code{flush-icache} does not work correctly, @code{code} words
etc. will not work (reliably), either.
These words are rarely used. Therefore they reside in @code{code.fs},
which is usually not loaded (except @code{flush-icache}, which is always
present). You can load it with @code{require code.fs}.
Another option for implementing normal and defining words efficiently
is: adding the wanted functionality to the source of Gforth. For normal
words you just have to edit @file{primitives}, defining words (for fast
defined words) probably require changes in @file{engine.c},
@file{kernal.fs}, @file{prims2x.fs}, and possibly @file{cross.fs}.
@node Threading Words, , Assembler and Code words, Words
@section Threading Words
These words provide access to code addresses and other threading stuff
......@@ -1643,7 +1710,20 @@ doc-does-code!
doc-does-handler!
doc-/does-handler
The code addresses produced by various defining words are produced by
the following words:
doc-docol:
doc-docon:
doc-dovar:
doc-douser:
doc-dodefer:
doc-dofield:
Currently there is no installation-independent way for recogizing words
defined by a @code{CREATE}...@code{DOES>} word; however, once you know
that a word is defined by a @code{CREATE}...@code{DOES>} word, you can
use @code{>DOES-CODE}.
@node ANS conformance, Model, Words, Top
@chapter ANS conformance
......@@ -1670,7 +1750,7 @@ ANS Forth System
@item providing the Memory-Allocation word set
@item providing the Memory-Allocation Extensions word set (that one's easy)
@item providing the Programming-Tools word set
@item providing @code{AHEAD}, @code{BYE}, @code{CS-PICK}, @code{CS-ROLL}, @code{STATE}, @code{[ELSE]}, @code{[IF]}, @code{[THEN]} from the Programming-Tools Extensions word set
@item providing @code{;code}, @code{AHEAD}, @code{ASSEMBLER}, @code{BYE}, @code{CODE}, @code{CS-PICK}, @code{CS-ROLL}, @code{STATE}, @code{[ELSE]}, @code{[IF]}, @code{[THEN]} from the Programming-Tools Extensions word set
@item providing the Search-Order word set
@item providing the Search-Order Extensions word set
@item providing the String word set
......@@ -3100,14 +3180,14 @@ Sieve benchmark on a 486DX2/66 than Gforth compiled with
However, this potential advantage of assembly language implementations
is not necessarily realized in complete Forth systems: We compared
Gforth (compiled with @code{gcc-2.6.3} and @code{-DFORCE_REG}) with
Win32Forth and LMI's NT Forth, two systems written in assembly, and with
two systems written in C: PFE-0.9.11 (compiled with @code{gcc-2.6.3}
with the default configuration for Linux: @code{-O2 -fomit-frame-pointer
-DUSE_REGS}) and ThisForth Beta (compiled with gcc-2.6.3 -O3
-fomit-frame-pointer). We benchmarked Gforth, PFE and ThisForth on a
486DX2/66 under Linux. Kenneth O'Heskin kindly provided the results for
Win32Forth and NT Forth on a 486DX2/66 with similar memory performance
under Windows NT.
Win32Forth 1.2093 and LMI's NT Forth (Beta, May 1994), two systems
written in assembly, and with two systems written in C: PFE-0.9.11
(compiled with @code{gcc-2.6.3} with the default configuration for
Linux: @code{-O2 -fomit-frame-pointer -DUSE_REGS}) and ThisForth Beta
(compiled with gcc-2.6.3 -O3 -fomit-frame-pointer). We benchmarked
Gforth, PFE and ThisForth on a 486DX2/66 under Linux. Kenneth O'Heskin
kindly provided the results for Win32Forth and NT Forth on a 486DX2/66
with similar memory performance under Windows NT.
We used four small benchmarks: the ubiquitous Sieve; bubble-sorting and
matrix multiplication come from the Stanford integer benchmarks and have
......@@ -3197,7 +3277,8 @@ information about Forth there.
@node Word Index, Node Index, Pedigree, Top
@chapter Word Index
This index is as incomplete as the manual.
This index is as incomplete as the manual. Each word is listed with
stack effect and wordset.
@printindex fn
......
......@@ -20,7 +20,7 @@
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.13 1995-09-06 21:00:15 pazsan Exp $
;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.14 1995-10-07 17:38:15 anton Exp $
;;-------------------------------------------------------------------
;; A Forth indentation, documentation search and interaction library
......@@ -37,19 +37,19 @@
(defvar forth-positives
" : :noname begin do ?do while if ?dup-if ?dup-not-if else case struct [if] [else] "
" : :noname code does> begin do ?do while if ?dup-if ?dup-not-if else case struct [if] [else] "
"Contains all words which will cause the indent-level to be incremented
on the next line.
OBS! All words in forth-positives must be surrounded by spaces.")
(defvar forth-negatives
" ; until repeat while +loop loop s+loop else then endif again endcase end-struct [then] [else] [endif]"
" ; end-code does> until repeat while +loop loop s+loop else then endif again endcase end-struct [then] [else] [endif]"
"Contains all words which will cause the indent-level to be decremented
on the current line.
OBS! All words in forth-negatives must be surrounded by spaces.")
(defvar forth-zeroes
" : :noname "
" : :noname code "
"Contains all words which causes the indent to go to zero")
(defvar forth-prefixes
......@@ -240,12 +240,12 @@ programmers who tend to fill code won't use emacs anyway:-)."
(beginning-of-line)
(while (and
(= (forward-line -1) 0)
(looking-at "[ \t]*\\\\[ \t]+")))
(if (not (looking-at "[ \t]*\\\\[ \t]+"))
(looking-at "[ \t]*\\\\g?[ \t]+")))
(if (not (looking-at "[ \t]*\\\\g?[ \t]+"))
(forward-line 1))
(let ((from (point))
(to (save-excursion (forward-paragraph) (point))))
(if (looking-at "[ \t]*\\\\[ \t]+")
(if (looking-at "[ \t]*\\\\g?[ \t]+")
(progn (goto-char (match-end 0))
(set-fill-prefix)
(fill-region from to nil))))))
......
......@@ -475,7 +475,7 @@ forth definitions
: definer! ( definer xt -- )
\ gives the word represented by xt the behaviour associated with definer
over 1 and if
does-code!
swap [ 1 invert ] literal and does-code!
else
code-address!
then ;
......
/*
$Id: hppa.h,v 1.8 1995-09-06 21:00:18 pazsan Exp $
$Id: hppa.h,v 1.9 1995-10-07 17:38:16 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
This is the machine-specific part for a HPPA running HP-UX
......@@ -16,19 +16,16 @@
#endif
/* cache flush stuff */
#ifdef DIRECT_THREADED
extern void * cacheflush(void *, int, int);
#ifdef DEBUG
# define CACHE_FLUSH(addr,size) \
# define FLUSH_ICACHE(addr,size) \
({ fprintf(stderr,"Flushing Cache at %08x:%08x\n",(int) addr, size); \
fflush(stderr); \
fprintf(stderr,"Cache flushed, final address: %08x\n", \
(int)cacheflush((void *)(addr), (int)(size), 32)); })
#else
# define CACHE_FLUSH(addr,size) \
# define FLUSH_ICACHE(addr,size) \
({ (void)cacheflush((void *)(addr), (int)(size), 32); })
# endif
#endif
#include "32bit.h"
......
......@@ -31,6 +31,32 @@
HEX
\ labels for some code addresses
: docon: ( -- addr ) \ gforth
\ the code address of a @code{CONSTANT}
['] bl >code-address ;
: docol: ( -- addr ) \ gforth
\ the code address of a colon definition
['] docon: >code-address ;
: dovar: ( -- addr ) \ gforth
\ the code address of a @code{CREATE}d word
['] udp >code-address ;
: douser: ( -- addr ) \ gforth
\ the code address of a @code{USER} variable
['] s0 >code-address ;
: dodefer: ( -- addr ) \ gforth
\ the code address of a @code{defer}ed word
['] source >code-address ;
: dofield: ( -- addr ) \ gforth
\ the code address of a @code{field}
['] reveal-method >code-address ;
\ Bit string manipulation 06oct92py
Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
......@@ -115,7 +141,7 @@ DOES> ( n -- ) + c@ ;
\ input stream primitives 23feb93py
: tib >tib @ ;
Defer source
Defer source \ used by dodefer:, must be defer
: (source) ( -- addr count ) tib #tib @ ;
' (source) IS source
......@@ -736,11 +762,25 @@ Avariable leave-sp leave-stack 3 cells + leave-sp !
POSTPONE begin drop do-dest
( 0 0 0 >leave ) ; immediate restrict
: ?DO ( -- do-sys )
: ?do-like ( -- do-sys )
( 0 0 0 >leave )
POSTPONE (?do)
>mark >leave
POSTPONE begin drop do-dest ; immediate restrict
POSTPONE begin drop do-dest ;
: ?DO ( -- do-sys ) \ core-ext question-do
POSTPONE (?do) ?do-like ; immediate restrict
: +DO ( -- do-sys ) \ gforth plus-do
POSTPONE (+do) ?do-like ; immediate restrict
: U+DO ( -- do-sys ) \ gforth u-plus-do
POSTPONE (u+do) ?do-like ; immediate restrict
: -DO ( -- do-sys ) \ gforth minus-do
POSTPONE (-do) ?do-like ; immediate restrict
: U-DO ( -- do-sys ) \ gforth u-minus-do
POSTPONE (u-do) ?do-like ; immediate restrict
: FOR ( -- do-sys )
POSTPONE (for)
......@@ -753,17 +793,21 @@ Avariable leave-sp leave-stack 3 cells + leave-sp !
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
until-like POSTPONE done POSTPONE unloop ;
: LOOP ( do-sys -- )
: LOOP ( do-sys -- ) \ core
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
: +LOOP ( do-sys -- )
: +LOOP ( do-sys -- ) \ core plus-loop
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
\ !! should the compiler warn about +DO..-LOOP?
: -LOOP ( do-sys -- ) \ gforth minus-loop
['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
\ will iterate as often as "high low ?DO inc S+LOOP". For positive
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
\ negative increments.
: S+LOOP ( do-sys -- )
: S+LOOP ( do-sys -- ) \ gforth s-plus-loop
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
: NEXT ( do-sys -- )
......@@ -902,31 +946,31 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
cell +loop
drop ??? ( wouldn't 0 be better? ) ;
\ indirect threading 17mar93py
\ threading 17mar93py
: cfa, ( code-address -- )
here lastcfa !
here 0 A, 0 , code-address! ;
: compile, ( xt -- ) A, ;
: !does ( addr -- ) lastcfa @ does-code! ;
: (;code) ( R: addr -- ) r> /does-handler + !does ;
: cfa, ( code-address -- ) \ gforth
here
dup lastcfa !
0 A, 0 , code-address! ;
: compile, ( xt -- ) \ core-ext
A, ;
: !does ( addr -- ) lastxt does-code! ;
: (does>) ( R: addr -- ) r> /does-handler + !does ;
: dodoes, ( -- )
here /does-handler allot does-handler! ;
\ direct threading is implementation dependent
: Create Header reveal [ :dovar ] Literal cfa, ;
: Create Header reveal dovar: cfa, ;
\ DOES> 17mar93py
: DOES> ( compilation: -- )
: DOES> ( compilation: -- ) \ core
state @
IF
;-hook postpone (;code) dodoes,
;-hook postpone (does>) ?struc dodoes,
ELSE
dodoes, here !does 0 ]
align dodoes, here !does ]
THEN
:-hook ; immediate
defstart :-hook ; immediate
\ Create Variable User Constant 17mar93py
......@@ -938,7 +982,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
: User Variable ;
: AUser AVariable ;
: (Constant) Header reveal [ :docon ] Literal cfa, ;
: (Constant) Header reveal docon: cfa, ;
: Constant (Constant) , ;
: AConstant (Constant) A, ;
......@@ -952,7 +996,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
: Defer ( -- )
\ !! shouldn't it be initialized with abort or something similar?
Header Reveal [ :dodefer ] Literal cfa,
Header Reveal dodefer: cfa,
['] noop A, ;
\ Create ( -- )
\ ['] noop A,
......@@ -978,13 +1022,13 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
defer :-hook ( sys1 -- sys2 )
defer ;-hook ( sys2 -- sys1 )
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ;
: : ( -- colon-sys ) Header docol: cfa, defstart ] :-hook ;
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ;
immediate restrict