Merge pull request #26 from timmoorhouse/dev

Dev

Author: timmoorhouse

CHANGELOG.md

@@ -1,13 +1,17 @@
 
-v0.2 alpha TBD
+v0.2 alpha 2023-03-20
 - Add `COMPILE-ONLY`.
 - Catch exceptions in `AUTOBOOT`.
 - Embed the bootstrap Forth code in forth-skeletal and parse out of memory instead of reading from a file.  This will allow `INCLUDE` and others to be implemented in Forth.
 - Turn `AUTOBOOT` into a deferred, so what happens automatically at startup can be customized (by default this is a no-op - should it be something like `:NONAME INCLUDE AUTOBOOT.F ;` ?)
+- Add support for double literals (such as 123.) to the interpreter.
 - Improve error reporting.  The source line number, line contents and parse position are displayed along with (if available) a message for the exception number.
-- CORE: add `ENVIRONMENT?`.
+- Added value `UNIT` used by `OPEN-FILE` as the unit number.  Defaults to 8.
+- CORE: add `ENVIRONMENT?` and `MARKER`.  CORE is now feature complete (with the exception of the obsolescent `[COMPILE]`).
+- DOUBLE: add `2CONSTANT`, `2LITERAL`, `D>S`.
 - SEARCH: add `ALSO`, `DEFINITIONS`, `FORTH`, `GET-CURRENT`, `GET-ORDER`, `ONLY`, `ORDER`, `PREVIOUS`, `SET-CURRENT` and `SET-ORDER`.  SEARCH is now feature complete.
 - STRING: add `UNESCAPE`.
+- TOOLS: add `SEE` (incomplete).
 
 v0.1 pre-alpha 2023-03-04
 - Initial version

README.md

@@ -0,0 +1,3 @@
+
+
+

src/assembler.f

@@ -16,6 +16,8 @@ DO_JUMP_W
 ;      W        address of the code field pointer in zero-page.
 W               !word 0
 
+                !byte 0         ; alignment
+
 ; floating point stack?
 
 ; TODO use a word for this? (turn it into S)
@@ -25,8 +27,6 @@ XSAVE           !byte 0 ; temporary to save S when we need to reuse X
 ; TODO separate XSAVE for kernel calls
 KERNEL_XSAVE    !byte 0 ; just for use in kernel calls
 
-NEXT_SBUF       !byte 0 ; TODO move out of base page?
-
 ; TODO move these out of basepage? make them values ...
 INPUT_BUFFER    !word 0 ; Address and length of input buffer
 INPUT_LEN       !word 0

src/basepage.asm

@@ -1,4 +1,6 @@
 
+marker pre-bm
+
 \ see also https://theultimatebenchmark.org/
 
 \

src/benchmark.f

@@ -10,6 +10,7 @@
 
 ; TODO can we move put_string here?
 
+        +NONAME
 W_SIMPLE_DOT
         !word *+2
         lda #'$'
@@ -61,6 +62,39 @@ SIMPLE_DOTS
 +        
         rts
 
+        +NONAME
+W_SIMPLE_FIND_NAME     ; ( c-addr u -- 0 | nt )
+        !word DO_COLON
+
+        !word W_2DUP
+        !word W_INTERNALS_WORDLIST
+        !word W_FIND_NAME_IN
+        !word W_DUP
+        !word W_ZEQUAL
+        +ZBRANCH +
+        !word W_DROP
+
+        ; ( c-addr u )
+
+        !word W_2DUP
+        !word W_FORTH_WORDLIST
+        !word W_FIND_NAME_IN
+        !word W_DUP
+        !word W_ZEQUAL
+        +ZBRANCH +
+        !word W_DROP
+
+        ; ( c-addr u )
+
+        !word W_2DUP
+        !word W_ENVIRONMENT_WORDLIST
+        !word W_FIND_NAME_IN
+
++
+        ; ( c-addr u 0|nt )
+        !word W_NIP
+        !word W_NIP
+        !word W_PSEMI
 
         +NONAME
 W_AUTOBOOT_BOOTSTRAP
@@ -71,9 +105,6 @@ W_AUTOBOOT_BOOTSTRAP
 
         !word W_BOOTSTRAP_MIN
 
-        !word W_CR
-        +DOTQ "Starting bootstrap stage 2..."
-        !word W_CR
         +CSLITERAL "bootstrap2.f"
         !word W_COUNT
         +CSLITERAL "included"
@@ -123,32 +154,19 @@ _bootstrap_min_extend_line
 
 _bootstrap_min_found_linefeed
 
-!if 0 {
-        !word W_DOTS
-        !word W_2DUP
-        !word W_TYPE
-        !word W_CR
-}
-
         !word W_DUP
         !word W_TOR
 
         ; (c-addr u) (R: c-addr u)
         !word W_EVALUATE
 
-!if 0 {
-        +DOTQ "evaluate done"
-        !word W_CR
-}
+        ; TODO check for dictionary colliding with bootstrap
 
         !word W_2RFROM
         !word W_PLUS
         !word W_1PLUS ; eat the linefeed
 
         !word W_TOR
-!if 0 {
-        !word W_DOTS,W_CR
-}
 
         +BRANCH _bootstrap_min_loop
 
@@ -161,11 +179,7 @@ _bootstrap_min_done
         !word W_PSEMI
 
 BOOTSTRAP_MIN_START
-; TODO make a bootstrap.f of just what we need to get off the ground
 !binary "bootstrap1.f"
-; !binary "core.f"
-; !binary "core-ext.f"
-; !binary "file.f"
-!byte $0a
+!byte $0a ; an extra linefeed since we don't handle the last line yet TODO remove
 BOOTSTRAP_MIN_LEN = *-BOOTSTRAP_MIN_START
 BOOTSTRAP_MIN_END

src/bootstrap.asm

@@ -20,9 +20,13 @@
 ( 2 if...                 )
 ( 3 do... [loop|+loop]    )
 
+internals-wordlist current !
+
 ( Resolve backward branch ) 
 : back here - , ; compile-only ( TODO REMOVE? )
 
+forth-wordlist current !
+
 ( Marks the origin of an unconditional forward branch )
 : ahead postpone branch here 0 , ( 2 ) ; immediate compile-only
 
@@ -57,11 +61,15 @@
 
 : c, ( char -- ) here c! 1 allot ;
 
+internals-wordlist current !
+
 ( counted string literal )
 : csliteral ( c-addr u -- ) ( -- c-addr )
   postpone (csliteral) dup c, swap over here swap cmove allot
   ; immediate compile-only
 
+forth-wordlist current !
+
 ( TODO this only works for len <= 255 )
 : sliteral ( c-addr u -- ) ( -- c-addr u ) 
   postpone csliteral postpone count
@@ -75,17 +83,17 @@
     sbuf swap 2dup 2>r cmove 2r> ( TODO klunky )
   then ; immediate
 
-: ' parse-name find-name dup 0= -13 and throw name>interpret ;
+: ' parse-name find-name name>interpret dup 0= -14 and throw ;
 
 ( : postpone )
 (   parse-name find-name dup 0= -13 and throw )
 (   name>compile swap postpone literal compile, ; immediate )
 
 : ['] ' postpone literal ; immediate compile-only
 
-: >body 2+ ;
+: >body ( xt -- a-addr ) 2+ ;
 
-: to state @ if
+: to ( i*x "<spaces>name" -- ) state @ if
     postpone ['] postpone >body postpone !
   else
     ' >body !
@@ -96,7 +104,18 @@
 
 1 constant r/o
 
-: included r/o open-file if -38 throw then 
+: close-file ( fileid -- ior ) k-close k-readss ;
+
+: open-file ( c-addr u fam -- fileid ior )
+  drop ( TODO use fam ) 
+  0 0 k-setbank k-setnam unused-logical dup unit unused-secondary k-setlfs k-open k-readss ;
+
+: include-file ( i*x fileid -- j*x ) save-input n>r to source-id 0 source-line !
+  0 begin drop
+    refill if ['] (evaluate) catch dup else 0 true then ( exception exit-flag )
+  until nr> restore-input drop throw ; ( TODO check status from restore-input )
+
+: included r/o open-file 0<> -38 and throw
   >r r@ include-file r> close-file drop ;
 
 .( ... BOOTSTRAP STAGE 1 COMPLETE ) cr

src/bootstrap1.f

@@ -1,9 +1,12 @@
 
+cr .( Starting bootstrap stage 2... ) cr
+
   s" d-core.f"          included
   s" d-core-ext.f"      included
   s" d-file.f"          included
+  s" d-search.f"        included
 
-:noname ; is autoboot \ TODO could use decimal to save a few bytes
+' decimal is autoboot
 
 : savesystem ( "<spaces>name" -- ) parse-name w/o open-file drop \ TODO check status from open-file
   >r ( R: fid )
@@ -21,11 +24,20 @@
     then 
   again ; is (quit)
 
+:noname ( -- ) 
+  '<' emit depth 0 u.r '>' emit space depth 
+  if 0 depth 2- do i pick . -1 +loop then ; is .s
+
 \ Before saving a system, the following deferred words MUST be defined:
-\ . .S AUTOBOOT (QUIT)
+\ . .S AUTOBOOT (QUIT) FIND-NAME
+
+forth-wordlist 1 set-order
 
-.( ... saving forth-minimal ) cr
+.( ... saving forth-minimal )
 savesystem forth-minimal,p,w
+unused . s" bytes free" type cr \ 28194
+
+environment-wordlist forth-wordlist internals-wordlist 3 set-order
 
   s" d-block.f"         included
   s" d-block-ext.f"     included
@@ -42,7 +54,6 @@
   s" d-locals-ext.f"    included
   s" d-memory.f"        included
 \ s" d-memory-ext.f"    included    \ TODO no need for one yet
-  s" d-search.f"        included
   s" d-search-ext.f"    included
   s" d-string.f"        included
   s" d-string-ext.f"    included
@@ -51,25 +62,81 @@
   s" d-xchar.f"         included
   s" d-xchar-ext.f"     included
 
+\ TODO should prompt text be separate from prompt colour?
 :noname
   case
-  3 of  4 foreground           endof \ error  - purple
-  2 of 14 foreground ." ok" cr endof \ prompt - lt blue
-  1 of  7 foreground           endof \ input  - yellow
+  3 of  4 foreground                 endof \ error  - purple
+  2 of 14 foreground space ." ok" cr endof \ prompt - lt blue
+  1 of  7 foreground                 endof \ input  - yellow
   ( 0 ) 1 foreground                 \ output - white
   endcase ; is theme
 
-.( ... saving forth-complete ) cr
+: marker ( "<spaces>name" -- ) ( -- ) 
+  here 
+  create 
+    ,                               \ save here
+    get-current ,                   \ save current
+    get-order dup , 0 ?do , loop    \ save order
+    \ save fixup to account for head of current wordlist changing when
+    \ we did the create
+    get-current @ @ get-current forth-wordlist - here +
+    forth-wordlist here 20 dup allot cmove \ save wordlist table
+    ! \ do the fixup
+  does> 
+    dup @ to here cell+             \ restore here
+    dup @ set-current cell+         \ restore current
+    dup dup @ 0 ?do dup dup @ i - cells + @ swap loop @ set-order dup @ 1+ cells + \ restore order
+    forth-wordlist 20 cmove \ restore wordlist table
+  ;
+
+: type-file ( fileid -- )
+  cr >r r@ fileid>buffer 
+  begin 
+    ( c-addr u ) ( R: fileid )
+    2dup r@ read-line throw ( c-addr u u2 flag ior ) ( R: fileid )
+  while
+    ( c-addr u u2 )
+    2 pick swap type cr
+  repeat 2drop r> drop ;
+
+: cat ( "<spaces>name" ) parse-name r/o open-file 0<> -38 and throw
+  dup type-file close-file drop ;
+
+only forth definitions
+
+.( ... saving forth-complete )
 savesystem forth-complete,p,w
+unused . s" bytes free" type cr \ 24754
 
 .( ... bootstrap stage 2 complete ) cr cr
 
-unused . s" bytes free" type cr \ 26693
-
 : test s" test.f" included ;
 
 : bm s" benchmark.f" included ;
 
-1 2 3   asdjfklj   4 5 6
+\ see marker
+
+\ 1 2 3   asdjfklj   4 5 6
+
+\ .( pre marker ) cr
+\ .( here= ) here . cr
+\ 
+\ marker foo
+\ 
+\ 100 allot
+\ 
+\ cr
+\ .( after creating marker ) cr
+\ .s cr
+\ .( here= ) here . cr
+\ .( foo= ) s" foo" find-name . cr
+\ 
+\ foo
+\ 
+\ cr
+\ .( after running marker ) cr
+\ .s cr
+\ .( here= ) here . cr
+\ .( foo= ) s" foo" find-name . cr
 
 .( end of bootstrap2.f ) cr

src/bootstrap2.f

@@ -16,7 +16,7 @@
 ;               This is also an initialisation procedure before first use 
 ;               of the disc.
 
-        +WORD "empty-buffers"
+        +CREATE "empty-buffers"
 W_EMPTY_BUFFERS
         !word DO_COLON
 ;          !word FIRST
@@ -37,7 +37,7 @@ W_EMPTY_BUFFERS
 ;               device.  SCR contains the screen number during and after 
 ;               this process.
 
-        +WORD "list"
+        +CREATE "list"
 W_LIST
         !word DO_COLON
 ;          !word DECIM
@@ -81,7 +81,7 @@ W_LIST
 ;;                                       SCR
 ;;                                       SCREEN 36 LINE 13
 ;;
-        +WORD "scr"
+        +CREATE "scr"
 W_SCR
 ;        !word DOUSE
 ;          !byte $1C