|
version 1.45, 1995/10/29 21:35:13
|
version 1.59, 1996/05/13 16:37:00
|
|
Line 1
|
Line 1
|
| \ KERNAL.FS GForth kernal 17dec92py |
\ KERNAL.FS GForth kernal 17dec92py |
| \ $ID: |
|
| |
\ Copyright (C) 1995 Free Software Foundation, Inc. |
| |
|
| |
\ This file is part of Gforth. |
| |
|
| |
\ Gforth 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, write to the Free Software |
| |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
| |
|
| \ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
| \ Copyright 1992 by the ANSI figForth Development Group |
|
| |
|
| \ Log: ', '- usw. durch [char] ... ersetzt |
\ Log: ', '- usw. durch [char] ... ersetzt |
| \ man sollte die unterschiedlichen zahlensysteme |
\ man sollte die unterschiedlichen zahlensysteme |
|
Line 59 HEX
|
Line 76 HEX
|
| |
|
| \ Bit string manipulation 06oct92py |
\ Bit string manipulation 06oct92py |
| |
|
| Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
\ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
| DOES> ( n -- ) + c@ ; |
\ DOES> ( n -- ) + c@ ; |
| |
|
| : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; |
\ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; |
| : +bit ( addr n -- ) >bit over c@ or swap c! ; |
\ : +bit ( addr n -- ) >bit over c@ or swap c! ; |
| |
|
| : relinfo ( -- addr ) forthstart dup @ + ; |
\ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ; |
| : >rel ( addr -- n ) forthstart - ; |
\ : >rel ( addr -- n ) forthstart - ; |
| : relon ( addr -- ) relinfo swap >rel cell / +bit ; |
\ : relon ( addr -- ) relinfo swap >rel cell / +bit ; |
| |
|
| \ here allot , c, A, 17dec92py |
\ here allot , c, A, 17dec92py |
| |
|
|
Line 111 DOES> ( n -- ) + c@ ;
|
Line 128 DOES> ( n -- ) + c@ ;
|
| ; immediate |
; immediate |
| |
|
| |
|
| : A! ( addr1 addr2 -- ) \ gforth |
\ : A! ( addr1 addr2 -- ) \ gforth |
| dup relon ! ; |
\ dup relon ! ; |
| : A, ( addr -- ) \ gforth |
\ : A, ( addr -- ) \ gforth |
| here cell allot A! ; |
\ here cell allot A! ; |
| |
' ! alias A! ( addr1 addr2 -- ) \ gforth |
| |
' , alias A, ( addr -- ) \ gforth |
| |
|
| |
|
| \ on off 23feb93py |
\ on off 23feb93py |
| |
|
|
Line 125 DOES> ( n -- ) + c@ ;
|
Line 145 DOES> ( n -- ) + c@ ;
|
| |
|
| \ name> found 17dec92py |
\ name> found 17dec92py |
| |
|
| : (name>) ( nfa -- cfa ) |
$80 constant alias-mask \ set when the word is not an alias! |
| count $1F and + cfaligned ; |
$40 constant immediate-mask |
| |
$20 constant restrict-mask |
| |
|
| |
: (name>) ( nfa+cell -- cfa ) |
| |
1 cells - name>string + cfaligned ; |
| : name> ( nfa -- cfa ) \ gforth |
: name> ( nfa -- cfa ) \ gforth |
| cell+ |
cell+ |
| dup (name>) swap c@ $80 and 0= IF @ THEN ; |
dup (name>) swap c@ alias-mask and 0= IF @ THEN ; |
| |
|
| : found ( nfa -- cfa n ) \ gforth |
: found ( nfa -- cfa n ) \ gforth |
| cell+ |
cell+ |
| dup c@ >r (name>) r@ $80 and 0= IF @ THEN |
dup c@ >r (name>) r@ alias-mask and 0= IF @ THEN |
| -1 r@ $40 and IF 1- THEN |
-1 r@ restrict-mask and IF 1- THEN |
| r> $20 and IF negate THEN ; |
r> immediate-mask and IF negate THEN ; |
| |
|
| \ (find) 17dec92py |
\ (find) 17dec92py |
| |
|
| \ : (find) ( addr count nfa1 -- nfa2 / false ) |
\ : (find) ( addr count nfa1 -- nfa2 / false ) |
| \ BEGIN dup WHILE dup >r |
\ BEGIN dup WHILE dup >r |
| \ cell+ count $1F and dup >r 2over r> = |
\ name>string dup >r 2over r> = |
| \ IF -text 0= IF 2drop r> EXIT THEN |
\ IF -text 0= IF 2drop r> EXIT THEN |
| \ ELSE 2drop drop THEN r> @ |
\ ELSE 2drop drop THEN r> @ |
| \ REPEAT nip nip ; |
\ REPEAT nip nip ; |
|
Line 227 Defer source ( -- addr count ) \ core
|
Line 251 Defer source ( -- addr count ) \ core
|
| \ Literal 17dec92py |
\ Literal 17dec92py |
| |
|
| : Literal ( compilation n -- ; run-time -- n ) \ core |
: Literal ( compilation n -- ; run-time -- n ) \ core |
| state @ IF postpone lit , THEN ; immediate |
postpone lit , ; immediate restrict |
| : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth |
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth |
| state @ IF postpone lit A, THEN ; |
postpone lit A, ; immediate restrict |
| immediate |
|
| |
|
| : char ( 'char' -- n ) \ core |
: char ( 'char' -- n ) \ core |
| bl word char+ c@ ; |
bl word char+ c@ ; |
| : [char] ( compilation 'char' -- ; run-time -- n ) |
: [char] ( compilation 'char' -- ; run-time -- n ) |
| char postpone Literal ; immediate |
char postpone Literal ; immediate restrict |
| ' [char] Alias Ascii immediate |
|
| |
|
| : (compile) ( -- ) \ gforth |
: (compile) ( -- ) \ gforth |
| r> dup cell+ >r @ compile, ; |
r> dup cell+ >r @ compile, ; |
|
Line 433 hex
|
Line 455 hex
|
| |
|
| : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
| ?DUP IF |
?DUP IF |
| [ here 4 cells ! ] |
[ here 9 cells ! ] |
| handler @ rp! |
handler @ rp! |
| r> handler ! |
r> handler ! |
| r> lp! |
r> lp! |
|
Line 466 Defer parser
|
Line 488 Defer parser
|
| Defer name ( -- c-addr count ) \ gforth |
Defer name ( -- c-addr count ) \ gforth |
| \ get the next word from the input buffer |
\ get the next word from the input buffer |
| ' (name) IS name |
' (name) IS name |
| Defer notfound ( c-addr count -- ) |
Defer compiler-notfound ( c-addr count -- ) |
| |
Defer interpreter-notfound ( c-addr count -- ) |
| |
|
| : no.extensions ( addr u -- ) |
: no.extensions ( addr u -- ) |
| 2drop -&13 bounce ; |
2drop -&13 bounce ; |
| ' no.extensions IS notfound |
' no.extensions IS compiler-notfound |
| |
' no.extensions IS interpreter-notfound |
| |
|
| |
: compile-only ( ... -- ) |
| |
-&14 throw ; |
| |
Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt? |
| |
' compile-only IS interpret-special |
| |
|
| : interpret ( ?? -- ?? ) \ gforth |
: interpret ( ?? -- ?? ) \ gforth |
| \ interpret/compile the (rest of the) input buffer |
\ interpret/compile the (rest of the) input buffer |
|
Line 491 Defer notfound ( c-addr count -- )
|
Line 520 Defer notfound ( c-addr count -- )
|
| IF \ not restricted to compile state? |
IF \ not restricted to compile state? |
| nip nip execute EXIT |
nip nip execute EXIT |
| THEN |
THEN |
| -&14 throw |
interpret-special exit |
| THEN |
THEN |
| drop |
drop |
| 2dup 2>r snumber? |
2dup 2>r snumber? |
| IF |
IF |
| 2rdrop |
2rdrop |
| ELSE |
ELSE |
| 2r> notfound |
2r> interpreter-notfound |
| THEN ; |
THEN ; |
| |
|
| ' interpreter IS parser |
' interpreter IS parser |
|
Line 523 Defer notfound ( c-addr count -- )
|
Line 552 Defer notfound ( c-addr count -- )
|
| postpone Literal |
postpone Literal |
| 2drop |
2drop |
| ELSE |
ELSE |
| drop notfound |
drop compiler-notfound |
| THEN ; |
THEN ; |
| |
|
| : [ ( -- ) \ core left-bracket |
: [ ( -- ) \ core left-bracket |
|
Line 703 variable backedge-locals
|
Line 732 variable backedge-locals
|
| |
|
| : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
| \ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
| \ better handled by tools like stack checkers |
\ better handled by tools like stack checkers. Besides, it's faster. |
| POSTPONE ?dup POSTPONE if ; immediate restrict |
POSTPONE ?dup-?branch >mark ; immediate restrict |
| |
|
| : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
| POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
POSTPONE ?dup-0=-?branch >mark ; immediate restrict |
| |
|
| : THEN ( compilation orig -- ; run-time -- ) \ core |
: THEN ( compilation orig -- ; run-time -- ) \ core |
| dup orig? |
dup orig? |
|
Line 861 Avariable leave-sp leave-stack 3 cells
|
Line 891 Avariable leave-sp leave-stack 3 cells
|
| : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
| POSTPONE (?do) ?do-like ; immediate restrict |
POSTPONE (?do) ?do-like ; immediate restrict |
| |
|
| : +DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth plus-do |
: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do |
| POSTPONE (+do) ?do-like ; immediate restrict |
POSTPONE (+do) ?do-like ; immediate restrict |
| |
|
| : U+DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-plus-do |
: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do |
| POSTPONE (u+do) ?do-like ; immediate restrict |
POSTPONE (u+do) ?do-like ; immediate restrict |
| |
|
| : -DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth minus-do |
: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do |
| POSTPONE (-do) ?do-like ; immediate restrict |
POSTPONE (-do) ?do-like ; immediate restrict |
| |
|
| : U-DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-minus-do |
: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do |
| POSTPONE (u-do) ?do-like ; immediate restrict |
POSTPONE (u-do) ?do-like ; immediate restrict |
| |
|
| : FOR ( compilation -- do-sys ; run-time w -- loop-sys ) \ gforth |
: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth |
| POSTPONE (for) |
POSTPONE (for) |
| POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
| ( 0 0 0 >leave ) ; immediate restrict |
( 0 0 0 >leave ) ; immediate restrict |
|
Line 927 Avariable leave-sp leave-stack 3 cells
|
Line 957 Avariable leave-sp leave-stack 3 cells
|
| immediate restrict |
immediate restrict |
| create s"-buffer /line chars allot |
create s"-buffer /line chars allot |
| : S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote |
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote |
| [char] " parse |
[char] " parse postpone SLiteral ; immediate restrict |
| state @ |
|
| IF |
|
| postpone SLiteral |
|
| ELSE |
|
| /line min >r s"-buffer r@ cmove |
|
| s"-buffer r> |
|
| THEN ; immediate |
|
| |
|
| : ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote |
: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote |
| state @ IF postpone (.") ," align |
postpone (.") ," align ; immediate restrict |
| ELSE [char] " parse type THEN ; immediate |
|
| : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
| [char] ) parse 2drop ; immediate |
BEGIN |
| |
>in @ [char] ) parse nip >in @ rot - = |
| |
WHILE |
| |
loadfile @ IF |
| |
refill 0= abort" missing ')' in paren comment" |
| |
THEN |
| |
REPEAT ; immediate |
| : \ ( -- ) \ core-ext backslash |
: \ ( -- ) \ core-ext backslash |
| blk @ |
blk @ |
| IF |
IF |
|
Line 966 create s"-buffer /line chars allot
|
Line 994 create s"-buffer /line chars allot
|
| |
|
| \ Header states 23feb93py |
\ Header states 23feb93py |
| |
|
| : flag! ( 8b -- ) |
: cset ( bmask c-addr -- ) |
| last @ dup 0= abort" last word was headerless" |
tuck c@ or swap c! ; |
| cell+ tuck c@ xor swap c! ; |
: creset ( bmask c-addr -- ) |
| : immediate $20 flag! ; |
tuck c@ swap invert and swap c! ; |
| : restrict $40 flag! ; |
: ctoggle ( bmask c-addr -- ) |
| \ ' noop alias restrict |
tuck c@ xor swap c! ; |
| |
|
| |
: lastflags ( -- c-addr ) |
| |
\ the address of the flags byte in the last header |
| |
\ aborts if the last defined word was headerless |
| |
last @ dup 0= abort" last word was headerless" cell+ ; |
| |
|
| |
: immediate immediate-mask lastflags cset ; |
| |
: restrict restrict-mask lastflags cset ; |
| |
|
| \ Header 23feb93py |
\ Header 23feb93py |
| |
|
|
Line 987 defer header ( -- ) \ gforth
|
Line 1023 defer header ( -- ) \ gforth
|
| \ puts down string as cstring |
\ puts down string as cstring |
| dup c, here swap chars dup allot move ; |
dup c, here swap chars dup allot move ; |
| |
|
| : name, ( "name" -- ) \ gforth |
: header, ( c-addr u -- ) \ gforth |
| name name-too-short? name-too-long? |
name-too-long? |
| string, cfalign ; |
align here last ! |
| : input-stream-header ( "name" -- ) |
current @ 1 or A, \ link field; before revealing, it contains the |
| \ !! this is f83-implementation-dependent |
\ tagged reveal-into wordlist |
| align here last ! -1 A, |
string, cfalign |
| name, $80 flag! ; |
alias-mask lastflags cset ; |
| |
|
| |
: input-stream-header ( "name" -- ) |
| |
name name-too-short? header, ; |
| : input-stream ( -- ) \ general |
: input-stream ( -- ) \ general |
| \ switches back to getting the name from the input stream ; |
\ switches back to getting the name from the input stream ; |
| ['] input-stream-header IS (header) ; |
['] input-stream-header IS (header) ; |
|
Line 1005 defer header ( -- ) \ gforth
|
Line 1043 defer header ( -- ) \ gforth
|
| create nextname-buffer 32 chars allot |
create nextname-buffer 32 chars allot |
| |
|
| : nextname-header ( -- ) |
: nextname-header ( -- ) |
| \ !! f83-implementation-dependent |
nextname-buffer count header, |
| nextname-buffer count |
|
| align here last ! -1 A, |
|
| string, cfalign |
|
| $80 flag! |
|
| input-stream ; |
input-stream ; |
| |
|
| \ the next name is given in the string |
\ the next name is given in the string |
|
Line 1032 create nextname-buffer 32 chars allot
|
Line 1066 create nextname-buffer 32 chars allot
|
| lastcfa @ ; |
lastcfa @ ; |
| |
|
| : Alias ( cfa "name" -- ) \ gforth |
: Alias ( cfa "name" -- ) \ gforth |
| Header reveal , $80 flag! ; |
Header reveal |
| |
alias-mask lastflags creset |
| |
dup A, lastcfa ! ; |
| |
|
| : name>string ( nfa -- addr count ) \ gforth name-to-string |
: name>string ( nfa -- addr count ) \ gforth name-to-string |
| cell+ count $1F and ; |
cell+ count $1F and ; |
|
Line 1040 create nextname-buffer 32 chars allot
|
Line 1076 create nextname-buffer 32 chars allot
|
| Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
| : >name ( cfa -- nfa ) \ gforth to-name |
: >name ( cfa -- nfa ) \ gforth to-name |
| $21 cell do |
$21 cell do |
| dup i - count $9F and + cfaligned over $80 + = if |
dup i - count $9F and + cfaligned over alias-mask + = if |
| i - cell - unloop exit |
i - cell - unloop exit |
| then |
then |
| cell +loop |
cell +loop |
|
Line 1067 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1103 Create ??? 0 , 3 c, char ? c, char ? c,
|
| \ DOES> 17mar93py |
\ DOES> 17mar93py |
| |
|
| : DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does |
: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does |
| state @ |
;-hook postpone (does>) ?struc dodoes, |
| IF |
defstart :-hook ; immediate restrict |
| ;-hook postpone (does>) ?struc dodoes, |
|
| ELSE |
|
| align dodoes, here !does ] |
|
| THEN |
|
| defstart :-hook ; immediate |
|
| |
|
| \ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
| |
|
|
Line 1110 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1141 Create ??? 0 , 3 c, char ? c, char ? c,
|
| \ Create ( -- ) |
\ Create ( -- ) |
| \ ['] noop A, |
\ ['] noop A, |
| \ DOES> ( ??? ) |
\ DOES> ( ??? ) |
| \ @ execute ; |
\ perform ; |
| |
|
| : IS ( addr "name" -- ) \ gforth |
: IS ( addr "name" -- ) \ gforth |
| ' >body |
' >body postpone ALiteral postpone ! ; immediate restrict |
| state @ |
|
| IF postpone ALiteral postpone ! |
|
| ELSE ! |
|
| THEN ; immediate |
|
| ' IS Alias TO ( addr "name" -- ) \ core-ext |
' IS Alias TO ( addr "name" -- ) \ core-ext |
| immediate |
immediate restrict |
| |
|
| : What's ( "name" -- addr ) \ gforth |
: What's ( "name" -- addr ) \ gforth |
| ' >body |
' >body postpone ALiteral postpone @ ; immediate restrict |
| state @ |
|
| IF |
|
| postpone ALiteral postpone @ |
|
| ELSE |
|
| @ |
|
| THEN ; immediate |
|
| : Defers ( "name" -- ) \ gforth |
: Defers ( "name" -- ) \ gforth |
| ' >body @ compile, ; immediate |
' >body @ compile, ; immediate |
| |
|
|
Line 1152 AVariable current ( -- addr ) \ gforth
|
Line 1174 AVariable current ( -- addr ) \ gforth
|
| |
|
| : last? ( -- false / nfa nfa ) |
: last? ( -- false / nfa nfa ) |
| last @ ?dup ; |
last @ ?dup ; |
| : (reveal) ( -- ) |
: (reveal) ( nfa wid -- ) |
| last? |
( wid>wordlist-id ) dup >r |
| IF |
@ over ( name>link ) ! |
| dup @ 0< |
r> ! ; |
| IF |
|
| current @ @ over ! current @ ! |
|
| ELSE |
|
| drop |
|
| THEN |
|
| THEN ; |
|
| |
|
| \ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
| |
|
|
Line 1169 AVariable current ( -- addr ) \ gforth
|
Line 1185 AVariable current ( -- addr ) \ gforth
|
| |
|
| struct |
struct |
| 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
| 1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field |
1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field |
| 1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field rehash-method \ xt: ( wid -- ) |
| \ \ !! what else |
\ \ !! what else |
| end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
|
Line 1181 struct
|
Line 1197 struct
|
| 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
| end-struct wordlist-struct |
end-struct wordlist-struct |
| |
|
| : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
: f83find ( addr len wordlist -- nfa / false ) |
| |
( wid>wordlist-id ) @ (f83find) ; |
| |
|
| \ Search list table: find reveal |
\ Search list table: find reveal |
| Create f83search ' f83find A, ' (reveal) A, ' drop A, |
Create f83search ( -- wordlist-map ) |
| |
' f83find A, ' (reveal) A, ' drop A, |
| |
|
| Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
| AVariable lookup G forth-wordlist lookup T ! |
AVariable lookup G forth-wordlist lookup T ! |
| G forth-wordlist current T ! |
G forth-wordlist current T ! |
| |
|
| : (search-wordlist) ( addr count wid -- nfa / false ) |
: (search-wordlist) ( addr count wid -- nfa / false ) |
| dup wordlist-map @ find-method @ execute ; |
dup wordlist-map @ find-method perform ; |
| |
|
| : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
| (search-wordlist) dup IF found THEN ; |
(search-wordlist) dup IF found THEN ; |
|
Line 1213 G -1 warnings T !
|
Line 1231 G -1 warnings T !
|
| then |
then |
| 2drop 2drop ; |
2drop 2drop ; |
| |
|
| |
: (sfind) ( c-addr u -- nfa | 0 ) |
| |
lookup @ (search-wordlist) ; |
| |
|
| : sfind ( c-addr u -- xt n / 0 ) \ gforth |
: sfind ( c-addr u -- xt n / 0 ) \ gforth |
| lookup @ search-wordlist ; |
lookup @ search-wordlist ; |
| |
|
|
Line 1223 G -1 warnings T !
|
Line 1244 G -1 warnings T !
|
| then ; |
then ; |
| |
|
| : reveal ( -- ) \ gforth |
: reveal ( -- ) \ gforth |
| last? if |
last? |
| name>string current @ check-shadow |
if \ the last word has a header |
| then |
dup ( name>link ) @ 1 and |
| current @ wordlist-map @ reveal-method @ execute ; |
if \ it is still hidden |
| |
dup ( name>link ) @ 1 xor ( nfa wid ) |
| |
2dup >r name>string r> check-shadow ( nfa wid ) |
| |
dup wordlist-map @ reveal-method perform |
| |
then |
| |
then ; |
| |
|
| : rehash ( wid -- ) |
: rehash ( wid -- ) |
| dup wordlist-map @ rehash-method @ execute ; |
dup wordlist-map @ rehash-method perform ; |
| |
|
| : ' ( "name" -- addr ) \ core tick |
: ' ( "name" -- addr ) \ core tick |
| name sfind 0= if -&13 bounce then ; |
name sfind 0= if -&13 bounce then ; |
| : ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick |
: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick |
| ' postpone ALiteral ; immediate |
' postpone ALiteral ; immediate restrict |
| \ Input 13feb93py |
\ Input 13feb93py |
| |
|
| 07 constant #bell ( -- c ) \ gforth |
07 constant #bell ( -- c ) \ gforth |
|
Line 1247 G -1 warnings T !
|
Line 1273 G -1 warnings T !
|
| 0A constant #lf ( -- c ) \ gforth |
0A constant #lf ( -- c ) \ gforth |
| |
|
| : bell #bell emit ; |
: bell #bell emit ; |
| |
: cr ( -- ) \ core |
| |
\ emit a newline |
| |
#lf ( sic! ) emit ; |
| |
|
| \ : backspaces 0 ?DO #bs emit LOOP ; |
\ : backspaces 0 ?DO #bs emit LOOP ; |
| |
|
| |
Variable ^d-mode -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line |
| |
|
| : >string ( span addr pos1 -- span addr pos1 addr2 len ) |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
| over 3 pick 2 pick chars /string ; |
over 3 pick 2 pick chars /string ; |
| : type-rest ( span addr pos1 -- span addr pos1 back ) |
: type-rest ( span addr pos1 -- span addr pos1 back ) |
|
Line 1264 G -1 warnings T !
|
Line 1296 G -1 warnings T !
|
| : (ret) type-rest drop true space ; |
: (ret) type-rest drop true space ; |
| : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
| : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
| : eof 2 pick 0= IF bye ELSE (ret) THEN ; |
: eof ^d-mode @ IF |
| |
bye |
| |
ELSE 2 pick over <> |
| |
IF forw drop (del) ELSE #bell emit THEN 0 |
| |
THEN ; |
| |
|
| Create ctrlkeys |
Create ctrlkeys |
| ] false false back false eof false forw false |
] false false back false eof false forw false |
|
Line 1278 defer everychar
|
Line 1314 defer everychar
|
| : decode ( max span addr pos1 key -- max span addr pos2 flag ) |
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
| everychar |
everychar |
| dup #del = IF drop #bs THEN \ del is rubout |
dup #del = IF drop #bs THEN \ del is rubout |
| dup bl < IF cells ctrlkeys + @ execute EXIT THEN |
dup bl < IF cells ctrlkeys + perform EXIT THEN |
| >r 2over = IF rdrop bell 0 EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
| r> (ins) 0 ; |
r> (ins) 0 ; |
| |
|
| \ decode should better use a table for control key actions |
|
| \ to define keyboard bindings later |
|
| |
|
| : accept ( addr len -- len ) \ core |
: accept ( addr len -- len ) \ core |
| dup 0< IF abs over dup 1 chars - c@ tuck type |
dup 0< IF abs over dup 1 chars - c@ tuck type |
| \ this allows to edit given strings |
\ this allows to edit given strings |
| ELSE 0 THEN rot over |
ELSE 0 THEN rot over |
| BEGIN key decode UNTIL |
BEGIN key decode dup ^d-mode ! UNTIL |
| 2drop nip ; |
2drop nip ; |
| |
|
| \ Output 13feb93py |
\ Output 13feb93py |
| |
|
| |
: (type) ( c-addr u -- ) \ gforth |
| |
outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? |
| |
; |
| |
|
| Defer type ( c-addr u -- ) \ core |
Defer type ( c-addr u -- ) \ core |
| \ defer type for a output buffer or fast |
\ defer type for a output buffer or fast |
| \ screen write |
\ screen write |
| |
|
| \ : (type) ( addr len -- ) |
|
| \ bounds ?DO I c@ emit LOOP ; |
|
| |
|
| ' (type) IS Type |
' (type) IS Type |
| |
|
| |
: (emit) ( c -- ) \ gforth |
| |
outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? |
| |
; |
| |
|
| Defer emit ( c -- ) \ core |
Defer emit ( c -- ) \ core |
| ' (Emit) IS Emit |
' (Emit) IS Emit |
| |
|
| Defer key ( -- c ) \ core |
Defer key ( -- c ) \ core |
| ' (key) IS key |
' (key) IS key |
| |
|
| \ : form ( -- rows cols ) &24 &80 ; |
|
| \ form should be implemented using TERMCAPS or CURSES |
|
| \ : rows form drop ; |
|
| \ : cols form nip ; |
|
| |
|
| \ Query 07apr93py |
\ Query 07apr93py |
| |
|
| : refill ( -- flag ) \ core-ext,block-ext,file-ext |
: refill ( -- flag ) \ core-ext,block-ext,file-ext |
|
Line 1321 Defer key ( -- c ) \ core
|
Line 1354 Defer key ( -- c ) \ core
|
| tib /line |
tib /line |
| loadfile @ ?dup |
loadfile @ ?dup |
| IF read-line throw |
IF read-line throw |
| ELSE loadline @ 0< IF 2drop false EXIT THEN |
ELSE sourceline# 0< IF 2drop false EXIT THEN |
| accept true |
accept true |
| THEN |
THEN |
| 1 loadline +! |
1 loadline +! |
|
Line 1338 Defer key ( -- c ) \ core
|
Line 1371 Defer key ( -- c ) \ core
|
| \ 2 c, here char r c, char + c, 0 c, |
\ 2 c, here char r c, char + c, 0 c, |
| \ 2 c, here char w c, char + c, 0 c, align |
\ 2 c, here char w c, char + c, 0 c, align |
| 4 Constant w/o ( -- fam ) \ file w-o |
4 Constant w/o ( -- fam ) \ file w-o |
| 2 Constant r/w ( -- fam ) \ file r-o |
2 Constant r/w ( -- fam ) \ file r-w |
| 0 Constant r/o ( -- fam ) \ file r-w |
0 Constant r/o ( -- fam ) \ file r-o |
| |
|
| \ BIN WRITE-LINE 11jun93jaw |
\ BIN WRITE-LINE 11jun93jaw |
| |
|
|
Line 1363 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1396 create nl$ 1 c, A c, 0 c, \ gnu includes
|
| \ include-file 07apr93py |
\ include-file 07apr93py |
| |
|
| : push-file ( -- ) r> |
: push-file ( -- ) r> |
| loadline @ >r loadfile @ >r |
sourceline# >r loadfile @ >r |
| blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; |
blk @ >r tibstack @ >r >tib @ >r #tib @ >r |
| |
>tib @ tibstack @ = IF r@ tibstack +! THEN |
| |
tibstack @ >tib ! >in @ >r >r ; |
| |
|
| : pop-file ( throw-code -- throw-code ) |
: pop-file ( throw-code -- throw-code ) |
| dup IF |
dup IF |
| source >in @ loadline @ loadfilename 2@ |
source >in @ sourceline# sourcefilename |
| error-stack dup @ dup 1+ |
error-stack dup @ dup 1+ |
| max-errors 1- min error-stack ! |
max-errors 1- min error-stack ! |
| 6 * cells + cell+ |
6 * cells + cell+ |
|
Line 1377 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1412 create nl$ 1 c, A c, 0 c, \ gnu includes
|
| -1 cells +LOOP |
-1 cells +LOOP |
| THEN |
THEN |
| r> |
r> |
| r> >in ! r> #tib ! r> >tib ! r> blk ! |
r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> blk ! |
| r> loadfile ! r> loadline ! >r ; |
r> loadfile ! r> loadline ! >r ; |
| |
|
| : read-loop ( i*x -- j*x ) |
: read-loop ( i*x -- j*x ) |
|
Line 1436 create pathfilenamebuf 256 chars allot \
|
Line 1471 create pathfilenamebuf 256 chars allot \
|
| pathfilenamebuf swap ; |
pathfilenamebuf swap ; |
| |
|
| create included-files 0 , 0 , ( pointer to and count of included files ) |
create included-files 0 , 0 , ( pointer to and count of included files ) |
| create image-included-files 0 , 0 , ( pointer to and count of included files ) |
here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells - |
| |
create image-included-files 1 , A, ( pointer to and count of included files ) |
| \ included-files points to ALLOCATEd space, while image-included-files |
\ included-files points to ALLOCATEd space, while image-included-files |
| \ points to ALLOTed objects, so it survives a save-system |
\ points to ALLOTed objects, so it survives a save-system |
| |
|
| |
: loadfilename ( -- a-addr ) |
| |
\ a-addr 2@ produces the current file name ( c-addr u ) |
| |
included-files 2@ drop loadfilename# @ 2* cells + ; |
| |
|
| |
: sourcefilename ( -- c-addr u ) \ gforth |
| |
\ the name of the source file which is currently the input |
| |
\ source. The result is valid only while the file is being |
| |
\ loaded. If the current input source is no (stream) file, the |
| |
\ result is undefined. |
| |
loadfilename 2@ ; |
| |
|
| |
: sourceline# ( -- u ) \ gforth sourceline-number |
| |
\ the line number of the line that is currently being interpreted |
| |
\ from a (stream) file. The first line has the number 1. If the |
| |
\ current input source is no (stream) file, the result is |
| |
\ undefined. |
| |
loadline @ ; |
| |
|
| : init-included-files ( -- ) |
: init-included-files ( -- ) |
| image-included-files 2@ 2* cells save-string drop ( addr ) |
image-included-files 2@ 2* cells save-string drop ( addr ) |
| image-included-files 2@ nip included-files 2! ; |
image-included-files 2@ nip included-files 2! ; |
|
Line 1471 create image-included-files 0 , 0 , ( po
|
Line 1525 create image-included-files 0 , 0 , ( po
|
| |
|
| : included1 ( i*x file-id c-addr u -- j*x ) \ gforth |
: included1 ( i*x file-id c-addr u -- j*x ) \ gforth |
| \ include the file file-id with the name given by c-addr u |
\ include the file file-id with the name given by c-addr u |
| loadfilename 2@ >r >r |
loadfilename# @ >r |
| save-string 2dup loadfilename 2! add-included-file ( file-id ) |
save-string add-included-file ( file-id ) |
| |
included-files 2@ nip 1- loadfilename# ! |
| ['] include-file catch |
['] include-file catch |
| r> r> loadfilename 2! throw ; |
r> loadfilename# ! |
| |
throw ; |
| |
|
| : included ( i*x addr u -- j*x ) \ file |
: included ( i*x addr u -- j*x ) \ file |
| open-path-file included1 ; |
open-path-file included1 ; |
|
Line 1521 create image-included-files 0 , 0 , ( po
|
Line 1577 create image-included-files 0 , 0 , ( po
|
| |
|
| : recurse ( compilation -- ; run-time ?? -- ?? ) \ core |
: recurse ( compilation -- ; run-time ?? -- ?? ) \ core |
| lastxt compile, ; immediate restrict |
lastxt compile, ; immediate restrict |
| : recursive ( -- ) \ gforth |
' reveal alias recursive ( -- ) \ gforth |
| reveal last off ; immediate |
immediate |
| |
|
| \ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
| |
|
|
Line 1536 create image-included-files 0 , 0 , ( po
|
Line 1592 create image-included-files 0 , 0 , ( po
|
| \ EVALUATE 17may93jaw |
\ EVALUATE 17may93jaw |
| |
|
| : evaluate ( c-addr len -- ) \ core,block |
: evaluate ( c-addr len -- ) \ core,block |
| push-file dup #tib ! >tib @ swap move |
push-file #tib ! >tib ! |
| >in off blk off loadfile off -1 loadline ! |
>in off blk off loadfile off -1 loadline ! |
| \ BEGIN interpret >in @ #tib @ u>= UNTIL |
|
| ['] interpret catch |
['] interpret catch |
| pop-file throw ; |
pop-file throw ; |
| |
|
|
Line 1605 DEFER DOERROR
|
Line 1660 DEFER DOERROR
|
| ; |
; |
| |
|
| : (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
| loadline @ IF |
sourceline# IF |
| source >in @ loadline @ 0 0 .error-frame |
source >in @ sourceline# 0 0 .error-frame |
| THEN |
THEN |
| error-stack @ 0 ?DO |
error-stack @ 0 ?DO |
| -1 error-stack +! |
-1 error-stack +! |
|
Line 1636 DEFER DOERROR
|
Line 1691 DEFER DOERROR
|
| postpone [ |
postpone [ |
| ['] 'quit CATCH dup |
['] 'quit CATCH dup |
| WHILE |
WHILE |
| DoError r@ >tib ! |
DoError r@ >tib ! r@ tibstack ! |
| REPEAT |
REPEAT |
| drop r> >tib ! ; |
drop r> >tib ! ; |
| |
|
| \ Cold 13feb93py |
\ Cold 13feb93py |
| |
|
| \ : .name ( name -- ) cell+ count $1F and type space ; |
\ : .name ( name -- ) name>string type space ; |
| \ : words listwords @ |
\ : words listwords @ |
| \ BEGIN @ dup WHILE dup .name REPEAT drop ; |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
| |
|
|
Line 1709 Variable argc
|
Line 1764 Variable argc
|
| Defer 'cold ' noop IS 'cold |
Defer 'cold ' noop IS 'cold |
| |
|
| : cold ( -- ) \ gforth |
: cold ( -- ) \ gforth |
| |
stdout TO outfile-id |
| pathstring 2@ process-path pathdirs 2! |
pathstring 2@ process-path pathdirs 2! |
| init-included-files |
init-included-files |
| 'cold |
'cold |
|
Line 1722 Defer 'cold ' noop IS 'cold
|
Line 1778 Defer 'cold ' noop IS 'cold
|
| cr |
cr |
| THEN |
THEN |
| false to script? |
false to script? |
| ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr |
." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr |
| ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
| ." Type `bye' to exit" |
." Type `bye' to exit" |
| loadline off quit ; |
loadline off quit ; |
|
Line 1745 Defer 'cold ' noop IS 'cold
|
Line 1801 Defer 'cold ' noop IS 'cold
|
| |
|
| : boot ( path **argv argc -- ) |
: boot ( path **argv argc -- ) |
| argc ! argv ! cstring>sstring pathstring 2! main-task up! |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
| sp@ dup s0 ! $10 + >tib ! #tib off >in off |
sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off |
| rp@ r0 ! fp@ f0 ! cold ; |
rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; |
| |
|
| : bye ( -- ) \ tools-ext |
: bye ( -- ) \ tools-ext |
| script? 0= IF cr THEN 0 (bye) ; |
script? 0= IF cr THEN 0 (bye) ; |
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to kernal.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth