📄 bootstrap.fs
字号:
: .( 29 parse handle-text ['] type state @ if , else execute then ; immediate\ \ 7.3.4.8 String manipulation\ : count ( pstr -- str len ) 1+ dup 1- c@ ;: pack ( str len addr -- pstr ) 2dup c! \ store len 1+ swap 0 ?do over i + c@ over i + c! loop nip 1- ;: lcc ( char1 -- char2 ) dup 41 5a between if 20 + then ;: upc ( char1 -- char2 ) dup 61 7a between if 20 - then ;: -trailing ( str len1 -- str len2 ) begin dup 0<> if \ len != 0 ? 2dup 1- + c@ bl = else false then while 1- repeat ;\ \ 7.3.4.5 Output formatting\ : cr linefeed emit ;: (cr carret emit ;: space bl emit ;: spaces 0 ?do space loop ;variable #line 0 #line !variable #out 0 #out !\ \ 7.3.9.2.3 Dictionary search\ \ helper functions: lfa2name ( lfa -- name len ) 1- \ skip flag byte begin \ skip 0 padding 1- dup c@ ?dup until 7f and \ clear high bit in length tuck - swap ( ptr-to-len len - name len ) ;: comp-nocase ( str1 str2 len -- true|false ) 0 do 2dup i + c@ upc ( str1 str2 byteX ) swap i + c@ upc ( str1 str2 byte1 byte2 ) <> if 0 leave then loop if -1 else drop 0 then swap drop ;: comp-word ( b-str len lfa -- true | false ) lfa2name ( str len str len -- ) >r swap r> ( str str len len ) over = if ( str str len ) comp-nocase else drop drop drop false \ if len does not match, string does not match then;\ $find is an fcode word, but we place it here since we use it for find.: find-wordlist ( name-str name-len last -- xt true | name-str name-len false ) @ >r begin 2dup r@ dup if comp-word dup false = then while r> @ >r drop repeat r@ if \ successful? -rot 2drop r> cell+ swap else r> drop drop drop false then ;: $find ( name-str name-len -- xt true | name-str name-len false ) vocabularies? if #order @ 0 ?do i cells context + @ find-wordlist ?dup if unloop exit then loop false else forth-last find-wordlist then ;\ look up a word in the current wordlist: $find1 ( name-str name-len -- xt true | name-str name-len false ) vocabularies? if current @ else forth-last then find-wordlist ; : ' parse-word $find 0= if type 3a emit -13 throw then ;: ['] parse-word $find 0= if type 3a emit -13 throw then state @ if ['] (lit) , , then ; immediate: find ( pstr -- xt n | pstr false ) dup count $find \ pstr xt true | pstr name-str name-len false if nip true over immediate? if negate \ immediate returns 1 then else 2drop false then ;\ \ 7.3.9.2.2 Immediate words (part 2)\ : literal ['] (lit) , , ; immediate: compile, , ; immediate: compile r> cell+ dup @ , >r ;: [compile] ['] ' execute , ; immediate: postpone parse-word $find if dup immediate? not if ['] (lit) , , ['] , then , else s" undefined word " type type cr then ; immediate\ \ 7.3.9.2.4 Miscellaneous dictionary (part 2)\ variable #instance: instance ( -- ) true #instance !;: #instance-base my-self dup if @ then;: #instance-offs my-self dup if na1+ then;\ the following instance words are used internally\ to implement variable instantiation.: instance-cfa? ( cfa -- true | false ) b e within \ b,c and d are instance defining words;: behavior ( xt-defer -- xt ) dup @ instance-cfa? if #instance-base ?dup if swap na1+ @ + @ else 3 /n* + @ then else na1+ @ then;: (ito) ( xt-new xt-defer -- ) #instance-base ?dup if swap na1+ @ + ! else 3 /n* + ! then;: to ['] ' execute dup @ instance-cfa? state @ if swap ['] (lit) , , if ['] (ito) else ['] (to) then , else if (ito) else /n + ! then then ; immediate\ \ 7.3.4.2 Console Input\ defer key?defer key: accept ( addr len -- len2 ) tuck 0 do key dup linefeed = if space drop drop drop i 0 leave then dup emit over c! 1 + loop drop ( cr ) ;: expect ( addr len -- ) accept span ! ;\ \ 7.3.4.3 ASCII constants (part 2)\ : handle-lit state @ if 2 = if ['] (lit) , , then ['] (lit) , , else drop then ;: char parse-word 0<> if c@ else s" Unexpected EOL." type cr then ; ;: ascii char 1 handle-lit ; immediate: [char] char 1 handle-lit ; immediate: control char bl 1- and 1 handle-lit ; immediate\ \ 7.3.8.6 Error handling (part 2)\ : abort -1 throw ;: abort" ['] if execute 22 parse handle-text ['] type , ['] (lit) , -2 , ['] throw , ['] then execute ; compile-only \ \ 7.5.3.1 Dictionary search\ \ this does not belong here, but its nice for testing: words ( -- ) last begin @ ?dup while dup lfa2name type space repeat cr ;\ \ 7.3.5.4 Numeric output primitives\ false value capital-hex?: pad ( -- addr ) here 100 + ;: todigit ( num -- ascii ) dup 9 > if capital-hex? not if 20 + then 7 + then 30 + ;: <# pad dup ! ;: hold pad dup @ 1- tuck swap ! c! ;: sign 0< if 2d hold then ;: # base @ mu/mod rot todigit hold ;: #s begin # 2dup or 0= until ;: #> 2drop pad dup @ tuck - ;: (.) <# dup >r abs 0 #s r> sign #> ;: u# base @ u/mod swap todigit hold ;: u#s begin u# dup 0= until ;: u#> 0 #> ;: (u.) <# u#s u#> ;\ \ 7.3.5.3 Numeric output\ : . (.) type space ;: s. . ;: u. (u.) type space ;: .r swap (.) rot 2dup < if over - spaces else drop then type ;: u.r swap (u.) rot 2dup < if over - spaces else drop then type ;: .d base @ swap decimal . base ! ;: .h base @ swap hex . base ! ;: .s 3c emit depth dup (.) type 3e emit space 0 ?do depth i - 1- pick . loop cr ;\ \ 7.3.5.2 Numeric input\ : digit ( char base -- n true | char false ) swap dup upc dup 41 5a ( A - Z ) between if 7 - else dup 39 > if \ protect from : and ; -rot 2drop false exit then then 30 ( number 0 ) - rot over swap 0 swap within if nip true else drop false then ;: >number begin dup while over c@ base @ digit 0= if drop exit then >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap 1 /string repeat ;: numdelim? dup 2e = swap 2c = or ; : $dnumber? 0 0 2swap dup 0= if 2drop 2drop 0 exit then over c@ 2d = dup >r negate /string begin >number dup 1 > while over c@ numdelim? 0= if 2drop 2drop r> drop 0 exit then 1 /string repeat if c@ 2e = if true else 2drop r> drop 0 exit then else drop false then over or if r> if dnegate then 2 else drop r> if negate then 1 then ; : $number ( ) $dnumber? case 0 of true endof 1 of false endof 2 of drop false endof endcase; : d# parse-word base @ >r decimal $number if s" illegal number" type cr 0 then r> base ! 1 handle-lit ; immediate: h# parse-word base @ >r hex $number if s" illegal number" type cr 0 then r> base ! 1 handle-lit ; immediate: o# parse-word base @ >r octal $number if s" illegal number" type cr 0 then r> base ! 1 handle-lit ; immediate\ \ 7.3.4.7 String Literals (part 2)\ : " pocket dup begin span @ >in @ > if 22 parse >r ( pocket pocket str R: len ) over r@ move \ copy string r> + ( pocket nextdest ) ib >in @ + c@ ( pocket nextdest nexchar ) 1 >in +! 28 = \ is nextchar a parenthesis? span @ >in @ > \ more input? and else false then while 29 parse \ parse everything up to the next ')' bounds ?do i c@ 10 digit if i 1+ c@ 10 digit if swap 4 lshift or else drop then over c! 1+ 2 else drop 1 then +loop repeat over - state @ if ['] (lit) , here 5 cells + , ['] (lit) , dup , ['] dobranch , here -rot /n allot ", null-align resolve-orig then; immediate\ \ 7.3.3.1 Memory Access (part 2)\ : dump ( addr len -- ) over + swap do i . space 10 0 do j i + c@ dup 10 / todigit emit 10 mod todigit emit space i 7 = if space then loop 3 spaces 10 0 do j i + c@ dup 20 < if drop 2e then \ non-printables as dots? emit loop cr 10 +loop;\ \ 7.3.9.1 Defining words\ : header ( name len -- ) dup if \ might be a noname... 2dup $find1 if drop 2dup type s" isn't unique." type cr else 2drop then then null-align dup -rot ", 80 or c, \ write name and len here /n 1- and 0= if 0 c, then \ pad and space for flags null-align 80 here 1- c! \ write flags byte here last @ , latest ! \ write backlink and set latest ;: : parse-word header 1 , ] ;: :noname 0 0 header here 1 , ] ;: ; ['] (semis) , reveal ['] [ execute ; immediate: constant parse-word header 3 , , \ compile DOCON and value reveal ;0 value active-package: instance, ( size -- ) \ first word of the device node holds the instance size dup active-package @ dup rot + active-package ! , , \ offset size;: instance? ( -- flag ) #instance @ dup if false #instance ! then;: value parse-word header instance? if /n b , instance, , \ DOIVAL else 3 , , then reveal ;: variable parse-word header instance? if /n c , instance, 0 , else 4 , 0 , then reveal ;: $buffer: ( size str len -- where ) header instance? if /n over /n 1- and - /n 1- and + \ align buffer size dup c , instance, \ DOIVAR else 4 , then here swap 2dup 0 fill \ zerofill allot reveal;: buffer: ( size -- ) parse-word $buffer: drop;: (undefined-defer) ( -- ) \ XXX: this does not work with behavior ... execute r@ 2 cells - lfa2name s" undefined defer word " type type cr ;: (undefined-idefer) ( -- ) s" undefined idefer word " type cr ;: defer ( new-name< > -- ) parse-word header instance? if 2 /n* d , instance, \ DOIDEFER ['] (undefined-idefer) else 5 , ['] (undefined-defer) then , ['] (semis) , reveal ;: alias ( new-name< >old-name< > -- ) parse-word parse-word $find if -rot \ move xt behind. header 1 , \ fixme we want our own cfa here. , \ compile old name xt ['] (semis) , reveal else s" undefined word " type type space 2drop then ;: $create header 6 , ['] noop , reveal ;: create parse-word $create ;: (does>) r> cell+ \ get address of code to execute latest @ \ backlink of just "create"d word cell+ cell+ ! \ write code to execute after the \ new word's CFA ;: does> ['] (does>) , \ compile does handling 1 , \ compile docol ; immediate0 constant struct: field create over , + does> @ + ;: 2constant create , , does> 2@ reveal ;\ \ initializer for the temporary compile buffer\ : init-tmp-comp 200 alloc-mem tmp-comp-buf !;\ the end⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -