home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / utils < prev    next >
Text File  |  1996-03-21  |  38KB  |  991 lines
  1. \ UTILS.F               A file to holw some utilities   by Tom Zimmer
  2.  
  3. cr .( Loading various Utility words...)
  4.  
  5. comment }
  6.     screen-size                   \ x y in pixels
  7.     OSVar@ OSVar!                 \ RISC OS Variables handling
  8.     .defered                      \ lists all deferred words
  9.     .cur-file                     \ prints out the current file
  10.     cd                            \ changes the current directory
  11.     .fpath , fpath+               \ path for file opening operations
  12.     fsave f1                      \ saves the current system as executable
  13.     turnkey                       \ installs a boot action and saves absolute
  14.     .loaded                       \ lists all loaded files
  15.     needs  filename               \ loads filename if not loaded
  16.     $exec                         \ executes OS command line given
  17.     locate +                      \ prints source file lines for +
  18.     .free                         \ displays amount of free memory
  19.     anew prog                     \ forgets old version if loaded anew
  20.     .date , .time , .cversion     \ time display words
  21.     comment:     This can be a multiline comment       comment;
  22. }
  23.  
  24. only forth also definitions
  25.  
  26. code OS_ReadModeVariable ( varnr mode -- res )
  27.   mov r0, tos
  28.   ldmfd sp !, { r1 }
  29.   swi " OS_ReadModeVariable"
  30.   mov tos, r2
  31. next c;
  32.  
  33. : screen-size ( -- width height )
  34.     11 -1 OS_ReadModeVariable  12 -1 OS_ReadModeVariable ;
  35.  
  36. code OS_ReadVarVal ( -- )
  37.   mov r0, tos
  38.   ldmfd sp !, { r1, r2, r3, r4 }
  39.   swi x " OS_ReadVarVal"
  40.   mov tos, r2
  41.   stmfd sp !, { r3, r4 }
  42. next c;
  43.  
  44. code OS_SetVarVal ( -- )
  45.   mov r0, tos
  46.   ldmfd sp !, { r1, r2, r3, r4 }
  47.   swi x " OS_SetVarVal"
  48.   mov tos, r3
  49.   stmfd sp !, { r4 }
  50. next c;
  51.  
  52.  0 constant VarType_String
  53.  1 constant VarType_Number
  54.  2 constant VarType_Macro
  55.  3 constant VarType_Expanded
  56.  4 constant VarType_LiteralString
  57. 16 constant VarType_Code
  58.  
  59. : OSVar@ ( buf len ^name -- len' )
  60.     >r swap 0 0 2swap r> OS_ReadVarVal nip nip ;
  61.  
  62. : OSVar! ( type buf len ^name -- )
  63.     >r swap 0 -rot r> OS_SetVarVal 2drop ;
  64.  
  65. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  66. \       User specifiable string delimiter utility
  67. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  68.  
  69. : ,$            ( -< #text#>- )
  70.                 >in @ bl word swap >in ! 1+ c@
  71.                 word count here place here c@ 1+ allot 0 c, align ;
  72.  
  73. : .$            ( -< #text#>- )
  74.                 compile (.") ,$ ; immediate
  75.  
  76. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  77. \       words to set the default function for a defered word
  78. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  79.  
  80. : _is-default   ( cfa -- )
  81.                 @(ip) >body 2 cells+ ! ;
  82.  
  83. : is-default    ( cfa -<name>- ) \ set the default field of a defered word
  84.                 state @
  85.                 if      compile _is-default
  86.                 else    ' >body 2 cells+ !
  87.                 then    ; immediate
  88.  
  89. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  90. \       fill in some defered words default functions
  91. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  92.  
  93. ' _gotoxy    is-default gotoxy
  94. ' _getxy     is-default getxy
  95. ' _getcolrow is-default getcolrow
  96. ' _beep      is-default beep
  97. \ ' _do-mabort is-default do-mabort
  98.  
  99. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  100. \       sound extention
  101. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  102.  
  103. synonym note tone               \ freq duration --
  104.  
  105. : beep-init     ( -- )          \ initialize beep to new parameters
  106.                 700 50 beep! ;
  107.  
  108. initialization-chain chain-add beep-init
  109.  
  110. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  111. \       define a word to restore a defered word to its default function
  112. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  113.  
  114. : _restore_default ( -- )
  115.                 @(ip) >body dup 2 cells+ @ swap ! ;
  116.  
  117. : restore-default ( -<name>- )    \ reset name to its default function
  118.                 state @
  119.                 if      compile _restore_default
  120.                 else    ' >body dup 2 cells+ @ swap !
  121.                 then    ; immediate
  122.  
  123. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  124. \ Display the defered words in the system, and their *current function
  125. \ along with the default function.
  126. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  127.  
  128. : .defered      ( -- )
  129.                 defer-list @
  130.                 begin   ?dup
  131.                 while   cr ." Defered: "
  132.                         dup cell - dup body> >name .id
  133.                         23 col ."  does: " @ >name .id
  134.                         45 col ."  defaults to: " dup cell+ @ >name .id
  135.                         @
  136.                         start/stop
  137.                 repeat  ;
  138.  
  139. : .cur-file     ( -- )
  140.                 ." The current file is: " cur-file count type ;
  141.  
  142. synonym .curfile .cur-file
  143. synonym .file    .cur-file
  144.  
  145. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  146. \ old original version of $EXEC, superceeded by the following series of words
  147. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  148.  
  149. code OS_CLI ( ad -- f )
  150.   mov r0, tos
  151.   swi x " OS_CLI"
  152.   mov vs tos, # 0
  153.   mvn vc tos, # 0
  154. next c;
  155.   
  156. : zEXEC         ( a1 -- f1 )
  157.                 dup count + 0 swap c!         \ null terminate string
  158.                 1+ OS_CLI ;
  159.  
  160. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  161. \       Multiple directory path search capability for file open
  162. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  163. : named-new$
  164.     create max-path allot ;
  165.  
  166. named-new$ &execbuf
  167. named-new$ &filebuf        
  168.     create &fpath   max-path allot      \ a static forth path buffer
  169.            &fpath   off
  170.   variable &linenum &linenum off
  171.  
  172. 2variable path-source
  173.  
  174. &fpath value path-ptr                   \ initialize the path buffer pointer
  175.  
  176. : next-path"    ( -- a1 n1 )            \ get the next path from dir list
  177.                 path-source 2@ 2dup ',' scan  2dup 1 /string path-source 2!
  178.                 nip - ;
  179.  
  180. : first-path"   ( -- a1 n1 )            \ get the first forth directory path
  181.                 path-ptr count path-source 2!
  182.                 next-path" ;
  183.  
  184. : "fpath+       ( a1 n1 -- )            \ append a directory to forth path
  185.                 2dup upper
  186.                 2dup + 1- c@ '.' =              \ end in '\'?
  187.                 if      1- 0max                 \ if so, delete it
  188.                 then    first-path"                     \ get first path
  189.                 begin   dup>r 2over compare dup r> and  \ check it
  190.                 while   drop
  191.                         next-path"                      \ and remaining paths
  192.                 repeat  0=              \ -- f1=true if already in list
  193.                 if      2drop
  194.                 else    path-ptr ?+, path-ptr +place
  195.                 then    ;
  196.  
  197. create cdir-buf 260 allot
  198.  
  199. code OS_GBPB567 ( args nr -- f )
  200.   mov r0, tos
  201.   ldmfd sp !, { r2 }
  202.   swi x " OS_GBPB"
  203.   mov vs tos, # 0
  204.   mvn vc tos, # 0
  205. next c;
  206.  
  207. : current-dir$  ( -- a1 )       \ get the full path to the current directory
  208.                 cdir-buf 1+ max-path z" FileSwitch$ADFS$CSD" OSVar@
  209.                 dup cdir-buf c!
  210.                 0= abort" Can't get the Current Directory!"
  211.                 cdir-buf 0 over count + c! ;
  212.  
  213. code OS_FSControl01 ( buf -- f )
  214.   mov r0, tos
  215.   ldmfd sp !, { r1 }
  216.   swi x " OS_FSControl"
  217.   mov vs tos, # 0
  218.   mvn vc tos, # 0
  219. next c;
  220.  
  221. : $current-dir! ( a1 -- f1 )    \ a1 is a null terminated directory string
  222.                 0 OS_FSControl01 ;
  223.  
  224. : chdir         ( -<optional_new_directory>- )
  225.                 bl word dup c@
  226.                 if      dup 1+ $current-dir! drop
  227.                 then    drop
  228.                 cr ." Current directory: " current-dir$ count type ;
  229.  
  230. synonym cd chdir
  231.  
  232. : program-name-init ( -- )
  233.                 path-ptr off
  234.                 &prognam 1+ 255 z" FileSwitch$ADFS$CSD" OSVar@ &prognam c!
  235.                 " .F" &prognam +place
  236.                 current-dir$ count 2dup upper path-ptr place
  237.                 path-ptr ?-.
  238.                 &prognam count "path-only" "fpath+
  239.                 path-ptr ?-. ;
  240.  
  241. program-name-init       \ initialize the program name buffer
  242.  
  243. initialization-chain chain-add program-name-init
  244.  
  245. : .program      ( -- )
  246.                 &prognam count type ;
  247.  
  248. : .fpath        ( -- )          \ display the forth directory search path list
  249.                 path-ptr count
  250.                 begin   ?dup
  251.                 while   2dup ',' scan 2dup 2>r nip - dup 1+ ?cr type
  252.                         2r> 1 /string dup
  253.                         if      ." ,"
  254.                         then
  255.                 repeat  drop ;
  256.  
  257. : fpath+        ( -<directory>- )       \ append a directory to forth path
  258.                 bl word count "fpath+ ;
  259.  
  260. create open-save$ 260 allot     \ buffer to save the file being opened
  261. create open-path$ 260 allot
  262.                                         \ f1=FALSE=success, TRUE=failed
  263. : n"open        ( a1 n1 -- handle f1 )          \ open file a1,n1 with path search
  264.                 open-save$ place                \ save filename for later
  265.                 open-save$ count _"open dup     \ if we couldn't open the file
  266.                 if      open-save$ count 0 min + c@ ':' <>      \ not if first is ':'
  267.                         open-save$ count 0 min + c@ '$' <> and  \ not if first is '$'
  268.                         if      2drop                           \ discard _"open results
  269.                                 first-path"
  270.                                 begin   dup>r
  271.                                         open-path$ place        \ first path
  272.                                         open-path$ ?+.          \ plus '\'
  273.                                         open-save$ count
  274.                                         open-path$ +place       \ append name
  275.                                         open-path$ count _"open dup   \ open it
  276.                                         r> and
  277.                                 while   2drop
  278.                                         next-path"
  279.                                 repeat
  280.                         then
  281.                 else    open-save$ count 0 min + c@ ':' <>      \ not if first is ':'
  282.                         open-save$ count 0 min + c@ '$' <> and  \ not if first is '$'
  283.                         if      current-dir$ count open-path$   place
  284.                                                    open-path$ ?+.
  285.                                 open-save$   count open-path$  +place
  286.                         else    open-save$   count open-path$   place
  287.                         then
  288.                 then    ;               \ return n2=handle, f1=false if found
  289.  
  290. ' n"open is "open       \ link multi-path open word into system
  291.  
  292. : "path-file    ( a1 n1 -- a2 n2 f1 )   \ find file a1,n1 return full path
  293.                                         \ a2,n2 and f1=false, succeeded
  294.                                         \ else return a1,n1 and f1=true, failed
  295.                 2dup "open 0=
  296.                 if      close-file drop
  297.                         2drop open-path$ count false
  298.                 else    drop true
  299.                 then    ;
  300.  
  301. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  302. \       Fsave stuff
  303. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  304.  
  305. create fsave-buf max-path allot
  306.  
  307. : "fsave        ( a1 n1 -- )    \ save a Forth executable
  308.                 fsave-buf place
  309.                 fsave-buf count
  310.                 over >r + 0 swap c!
  311.                 32768 here over - r> 1-
  312.                 save-file ;
  313.  
  314. : fsave         ( -<name>- )
  315.                 bl word count "fsave ;
  316. : turnkey       ( cfa -<name>- )     \ create application "name" with
  317.                                         \ n1 bytes of dictionary space available
  318.                                         \ while running 'cfa' as the program to BOOT
  319.                 is boot                 \ a1 is the CFA of the new version of BOOT
  320. \                memory-free!
  321.                 fsave  ;
  322.  
  323. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  324. \       display the files loaded into the system
  325. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  326.  
  327. : .loaded       ( -- )
  328.                 cr
  329.                 loadfile @
  330.                 begin   ?dup
  331.                 while   14 ?cr
  332.                         dup cell+ count "to-pathend"
  333.                         10 over - spaces
  334.                         2dup upper type
  335.                         dup @
  336.                         if      \ if no code compiled, then discard filename
  337.                                 dup>r @ dup cell+ count + 1+ aligned r> =
  338.                                 if      @
  339.                                 then
  340.                         else    @
  341.                         then
  342.                         start/stop
  343.                 repeat  ;
  344.  
  345.                                 \ a1,n1 name to test for being loaded
  346. : "loaded?      ( a1 n1 -- f1 ) \ f1 = true if file has been loaded
  347.                 2dup upper 2>r
  348.                 loadfile @      \ top of the file loaded chain
  349.                 begin   ?dup    \ for as long as we aren't at the end
  350.                 while   dup cell+ count "to-pathend" 2r@ compare 0=
  351.                         if      2r> 2drop       \ if they match,
  352.                                 drop true
  353.                                 exit            \ exit with true on stack
  354.                         then
  355.                         dup @
  356.                         if      \ if no code compiled, then discard filename
  357.                                 dup>r @ dup cell+ count + 1+ aligned r> =
  358.                                 if      @
  359.                                 then
  360.                         else    @
  361.                         then
  362.                 repeat  2r> 2drop false ;
  363.  
  364. : needs         ( -<name>- ) \ conditionally load file "name" if not loaded
  365.                 >in @ >r
  366.                 bl word count "loaded? 0=       \ if we dont have it
  367.                 if      r@ >in !
  368.                         fload                   \ then loadit
  369.                 then    r>drop ;
  370.  
  371. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  372. \       SHELL support with interpreted string replacement for selected words
  373. \       %FILENAME  %DIR  %LINE
  374. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  375.  
  376. : execbuf+      ( a1 n1 a2 -- ) \ append to the exec buffer
  377.                 &execbuf 2dup c@ + 255 > abort" Too long for EXEC buffer"
  378.                 +place ;
  379.  
  380. true value new-prompt?
  381.  
  382.                                 \ Invoke a DOS command string with
  383. : $EXEC         ( a1 -- f1 )    \ preprocess for file and line parameters
  384.                                 \ f1 = TRUE on error
  385.                 base @ >r decimal
  386.                 &execbuf off                    \ pre-zero the buffer
  387.                 count
  388.                 begin   2dup ascii % scan dup
  389.                 while   2dup 2>r nip - execbuf+ 2r>
  390.                                 over s" %FILENAME" tuck compare 0= >r
  391.                                 over s" %filename" tuck compare 0= r> or
  392.                         if      new-prompt?
  393.                            if   &filebuf count "path-file
  394.                                 if      cr ." File doesn't exist, create it? [Y/N] (N):"
  395.                                         key upc 'Y' <> abort" Aborting"
  396.                                 then    execbuf+
  397.                            else &filebuf count execbuf+
  398.                            then
  399.                                 9 /string               \ remove %FILENAME
  400.                         else
  401.                                 over s" %DIR"      tuck compare 0= >r
  402.                                 over s" %dir"      tuck compare 0= r> or
  403.                         if      &prognam count 2dup "to-pathend" nip -
  404.                                 execbuf+
  405.                                 4 /string       \ remove %LINE
  406.                         else
  407.                                 over s" %LINE"     tuck compare 0= >r
  408.                                 over s" %line"     tuck compare 0= r> or
  409.                         if      &linenum @ 0 <# #s #> execbuf+
  410.                                 5 /string       \ remove %LINE
  411.                         else
  412.                                 over 1 execbuf+
  413.                                 1 /string       \ remove one % char
  414.                         then
  415.                         then
  416.                         then
  417.                 repeat  nip - execbuf+
  418. \                cr &execbuf count type
  419.                 &execbuf +NULL
  420.                 &execbuf 1+ zEXEC
  421.                 r> base ! ;
  422.  
  423. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  424. \   primitive utilities to support view, browse and edit of words and files
  425. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  426.  
  427. variable cur-line
  428.          cur-line off
  429.  
  430. -1 value loc-file
  431.  
  432. create loc-buf 260 allot
  433.  
  434. : read-1line    ( a1 -- len f1 )
  435.                 255 loc-file read-line abort" Read Error" ;
  436.  
  437. : locate-height ( -- n1 )
  438.                 getcolrow nip 8 - 20 min ;
  439.  
  440. : locate-header ( -- n1 )
  441.                 locate-height 4 / ;
  442.  
  443. -1 value orig-loc
  444.  0 value loc-line
  445.  
  446. : $locate       ( line filename | dummy -1 -- )
  447.                 dup 0<
  448.                 if      2drop
  449.                 else    $open abort" Couldn't open source file!"
  450.                         to loc-file
  451.                         0 to loc-line
  452.                         base @ >r decimal
  453.                         cls ." From file: " cur-file count type
  454.                         ."  At line: " dup . dup cur-line !
  455.                         cr horizontal-line
  456.                         locate-header - 0 max 0
  457.                         ?do     loc-buf read-1line nip 0= ?leave
  458.                                 1 +to loc-line
  459.                         loop
  460.                         locate-height 0
  461.                         do      loc-buf dup read-1line
  462.                                 if      cols 1- min
  463.                                         1 +to loc-line
  464.                                         loc-line orig-loc =
  465.                                         if      horizontal-line
  466.                                                 type cr
  467.                                                 horizontal-line
  468.                                         else          type cr
  469.                                         then
  470.                                         getxy nip getcolrow nip 4 - >
  471.                                         ?leave
  472.                                 else    2drop leave
  473.                                 then
  474.                         loop    horizontal-line
  475.                         loc-file close-file drop
  476.                         r> base !
  477.                 then    ;
  478.  
  479. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  480. \       handle error returned by window functions
  481. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  482.  
  483. true value ?win-error-enabled           \ initially errors are enabled
  484.  
  485. defer win-abort ' abort is win-abort
  486. comment }
  487. : ?win-error    ( f1 -- )
  488.                 0=
  489.                 ?win-error-enabled and
  490.                 if      false to ?win-error-enabled
  491.                         debug-io
  492.                         cr ." On Function: "
  493.                         r@ abs>rel 2 cells - @ .name
  494.                         ."  Windows Returned Error:"
  495.                         call GetLastError .
  496.                         win-abort
  497.                         restore-io
  498.                 then    ;
  499. }
  500. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  501. \       A utility to allow invoking a DOS shell on a following commandline
  502. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  503.  
  504. : os            ( -<string>- )
  505.                 0 word $exec ;
  506. comment }
  507. create temp2$ 260 allot
  508.  
  509. : copyfile      ( -<from to>- ) \ copy a file to a directory
  510.                 temp$  max-handle erase
  511.                 temp2$ max-handle erase
  512.                 bl word count temp$  place
  513.                 bl word count temp2$ place
  514.                 temp2$ ?+\
  515.                 temp$ count "to-pathend" temp2$ +place
  516.                 cr ." Copying: " temp$  count type
  517.                 cr ."      To: " temp2$ count type
  518.                 false
  519.                 temp2$ 1+ rel>abs
  520.                 temp$  1+ rel>abs
  521.                 Call CopyFile 0=
  522.                 abort" The COPY Failed!" ;
  523. }
  524. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  525. \       more primitive utilities to support view, browse and edit
  526. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  527.  
  528.                 \ a1=cfa, a2=loadfile string
  529. : $viewinfo     ( a1 -- a1 a2 true | false ) \ find source for a word
  530.                 loadfile @
  531.                 begin   2dup >
  532.                         if      cell+ true
  533.                                 exit            \ leave loop here
  534.                         else    @
  535.                         then    dup 0=
  536.                 until   2drop false ;
  537.  
  538. : _.viewinfo    ( a1 -- line filename )
  539.                 $viewinfo 0= abort" Undefined word!"
  540.                 ."  loaded from: " over >view @ 0<
  541.                 if      ." CONSOLE" 2drop 0 -1
  542.                 else    base @ >r decimal
  543.                         dup ?uppercase count type 15 ?cr
  544.                         ."  at line: "
  545.                         swap >view @ dup . swap
  546.                         r> base !
  547.                         dup count cur-file place
  548.                 then    ;
  549.  
  550. : .viewinfo     ( -<name>- line filename )
  551.                 bl word anyfind
  552.                 if       _.viewinfo
  553.                 else    c@ abort" Undefined word!"
  554.                         cur-line @ cur-file
  555.                 then    over to orig-loc ;
  556.  
  557. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  558. \       highlevel words used to view, browse and edit words and file
  559. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  560.  
  561. : locate        ( -<name>- )    \ show some source lines of word
  562.                 .viewinfo $locate ;
  563.  
  564. : n             ( -- )          \ show the next bunch of lines
  565.                 cur-line @ locate-height 4 - + cur-file $locate ;
  566.  
  567. : b             ( -- )          \ show the previous bunch of lines
  568.                 cur-line @ locate-height 4 - - 0 max cur-file $locate ;
  569.  
  570. : linelist      ( n1 -- )
  571.                 cur-file $locate ;
  572. comment }
  573. : view          ( -<name>- )    \ VIEW the source for a word
  574.                 .viewinfo $browse ;
  575.  
  576. synonym v view                  \ V is an synonym for VIEW
  577.  
  578. : e             ( -<name>- )    \ EDIT the source for a word
  579.                 .viewinfo $edit ;
  580.  
  581. synonym ed e                    \ E is a synonym for EDIT
  582.  
  583. : edit          ( -<filename>- ) \ EDIT a particular file
  584.                 0 word c@
  585.                 if      cur-line off
  586.                         0 pocket
  587.                 else    cur-line @ cur-file
  588.                 then    $edit ;
  589.  
  590. synonym z edit                  \ Z is a synonym for EDIT
  591. }
  592. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  593. \       Utility to allow loading a file starting at a specified line number
  594. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  595.  
  596. : #fload        ( n1 -<name>- )         \ load file "name" from line n1, 1 based
  597.                 start-line !                    \ set start line
  598.                 bl word $fload ;                \ do the load
  599.  
  600. : lineload      ( n1 -- )               \ load the current file from line n1
  601.                 start-line !
  602.                 cur-file $fload ;
  603. comment }
  604. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  605. \       Linkage to automatically invoke the editor on a compile error
  606. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  607.  
  608. : _edit-error   ( -- )
  609.                 loadline @ loadfile @ cell+ $edit ;
  610.  
  611. : autoediton    ( -- )  \ link into defered auto edit on error word
  612.                 ['] _edit-error is edit-error ;
  613.  
  614. autoediton
  615. }
  616. : autoeditoff   ( -- )  \ disable automatic edit on error
  617.                 ['] noop is edit-error ;
  618. autoeditoff
  619. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  620. \       Display the amount of used and available program memory
  621. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  622.  
  623. : .free         ( -- )
  624.                 base @ decimal
  625.                 cr ." Image address:   "     32768           h.8  ." h"
  626.                 cr ."   bytes Total: " memory-total      10 u,.r
  627.                 cr ."          Used: " here  32768 -     10 u,.r
  628. \                cr ."          Free: " memory-free       10 u,.r
  629.                 cr ."        Malloc: " tot-malloc        10 u,.r
  630.                 base ! ;
  631.  
  632. synonym .mem .free
  633.  
  634. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  635. \       Compiler utilities
  636. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  637.  
  638. : anew          ( -<name>- )    \ define a new marker
  639.                 >in @ defined nip swap >in !
  640.                 if      ' execute
  641.                 else    mark
  642.                 then    ;
  643.  
  644. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  645. \       A simple error number extention to error handling
  646. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  647.  
  648. : ?error        ( f1 n1 -- )    \ abort with error code n1 if f1=true
  649.                 swap
  650.                 if      throw
  651.                 else    drop
  652.                 then    ;
  653.  
  654. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  655. \       ANSI Save and Restore Input Functions
  656. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  657.  
  658. : save-input    ( -- xxx 7 )
  659.                 loadfile @ cell+
  660.                 ?loading @
  661.                 loadline @
  662.                 >in @
  663.                 source-id
  664.                 (source) 2@
  665.                 7 ;
  666.  
  667. : restore-input ( xxx 7 -- )
  668.                 drop
  669.                 (source) 2!
  670.                 to source-id
  671.                 >in !
  672.                 loadline !
  673.                 ?loading !
  674.                 align linkfile ;
  675.  
  676. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  677. \       Compile time stack depth checking
  678. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  679.  
  680. synonym checkstack nostack1
  681.  
  682. : nostack       ( -- )
  683.                 -1 to olddepth ;
  684.  
  685. : stack-empty?  ( -- )
  686.                 depth abort" The stack should have been empty here!" ;
  687.  
  688. : _stack-check  ( -- )
  689.                 ?loading @ 0=           \ if we are not loading
  690.                 state @ or              \ or we are in compile state,
  691.                                         \ then don't check stack depth change
  692.                 olddepth 0< or ?exit    \ or is olddepth is below zero
  693.                 context @ [ ' assembler vcfa>voc ] literal = ?exit
  694.                 depth olddepth >
  695.                 if      cr ." Stack depth increased in file: "
  696.                         loadfile @ cell+ count type
  697.                         ."  at line: " base @ decimal loadline @ . base !
  698.                         ." Stack: " .s cr
  699.                 then    depth to olddepth ;
  700.  
  701. nostack ' _stack-check is stack-check
  702.  
  703. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  704. \       A word to allow accessing a word from the Forth vocabulary
  705. \       without changing the vocabulary search order
  706. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  707.  
  708. : f:            ( -<name>- )    \ define a word in the FORTH vocabulary
  709.                 current @ >r                    \ save CURRENT
  710.                 ['] forth vcfa>voc current !       \ set to FORTH
  711.                 header                          \ make a header
  712.                 r> current !                    \ restore current
  713.                 !csp compile docol ] ;          \ switch to compiling
  714.  
  715. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  716. \       Time control words
  717. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  718.  
  719. create TIME-BUF 5 allot  5 constant time-len
  720. \ here            nostack1
  721. \         0 c,    \ +0  year
  722. \         0 c,    \ +1  month
  723. \         0 c,    \ +2  day of month
  724. \         0 c,    \ +3  day of week
  725. \         0 c,    \ +4  hour
  726. \         0 c,    \ +5  minute
  727. \         0 c,    \ +6  second
  728. \ here swap - constant TIME-LEN
  729.  
  730. create date$        32 allot
  731. create time$        32 allot
  732. create date-format$ 24 allot   s" %w3, %mn/%dy/%ce%yr%0" date-format$ place
  733.   0 date-format$ count + c!
  734. create time-format$ 20 allot   s" %24:%mi:%se%0"         time-format$ place
  735.   0 time-format$ count + c!
  736.  
  737. code OS_Word ( block nr -- block )
  738.   mov r0, tos
  739.   ldmfd sp !, { r1 }
  740.   swi " OS_Word"
  741.   mov tos, r1
  742. next c;
  743.  
  744. code OS_ConvertDateAndTime ( format size buf timestruc -- free end begin )
  745.   mov r0, tos
  746.   ldmfd sp !, { r1, r2, r3 }
  747.   swi " OS_ConvertDateAndTime"
  748.   mov tos, r0
  749.   stmfd sp !, { r1, r2 }
  750. next c;
  751.  
  752. : get-local-time ( -- )         \ get the local computer date and time
  753.         time-buf 3 over c! 14 OS_Word drop ;
  754.  
  755. create compile-version time-len allot   \ a place to save the compile time
  756. get-local-time                          \ save as part of compiled image
  757. time-buf compile-version time-len move  \ move time into buffer
  758.  
  759. create d/m 31 c, 28 c, 31 c, 30 c, 31 c, 30 c,
  760.            31 c, 31 c, 30 c, 31 c, 30 c, 31 c,
  761.  
  762. : time&date     ( -- sec min hour day month year )
  763.     get-local-time
  764.     time-buf @ time-buf cell+ c@
  765.     360000 um/mod swap 100 / 60 /mod rot
  766.     24 /mod dup 58 > -
  767.     [ 365 4 * 1+ ] literal /mod 4 * 1900 + >r
  768.     dup 59 =
  769.     if drop 29 2 0 else
  770.       dup 59 > + 365 /mod >r
  771.       d/m 12 bounds
  772.       do i c@ - dup 0< if i c@ + 1+ i [ d/m 1- ] literal - leave then loop
  773.     r> then
  774.     r> + ;
  775.  
  776. : .#"           ( n1 n2 -- a1 n3 )
  777.                 >r 0 <# r> 0 ?do # loop #> ;
  778.  
  779. : >date"        ( time_structure -- ad n )
  780.                 >r date-format$ 1+
  781.                 31 date$ 1+
  782.                 r> OS_ConvertDateAndTime
  783.                 - 1- date$ c! drop
  784.                 date$ count ;
  785.  
  786. : >time"        ( time_structure -- ad n )
  787.                 >r time-format$ 1+
  788.                 31 time$ 1+
  789.                 r> OS_ConvertDateAndTime
  790.                 - 1- time$ c! drop
  791.                 time$ count ;
  792.  
  793. : .date         ( -- )
  794.                 get-local-time time-buf >date" type ;
  795.  
  796. : .time         ( -- )
  797.                 get-local-time time-buf >time" type ;
  798.  
  799. : .cversion     ( -- )
  800.                 cr ." Compiled: "
  801.                 compile-version dup >date" type space >time" type ;
  802.  
  803. : ms@           ( -- ms )
  804.                 get-local-time
  805.                 time-buf @ 10 * ;
  806.  
  807. 0 value start-time
  808.  
  809. : TIME-RESET
  810.     time-buf 5 erase
  811.     time-buf 2 OS_Word drop ;  \ RESET TIMER
  812.  
  813. : TIME-ELAPSED  ( -- d )
  814.     time-buf 1 OS_Word dup @ swap cell+ c@ ;
  815.  
  816. : .ELAPSED
  817.     CR ." Elapsed time   =  "
  818.     TIME-ELAPSED 100 um/mod
  819.     60 /mod 60 /mod ( 100s s m h )
  820.     ?dup  if 2 .#" type ." :" then
  821.     2 .#" type ." :"
  822.     2 .#" type ." ."
  823.     3 .#" type ;
  824.  
  825. comment }
  826. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  827. \      Delay Time Words
  828. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  829.  
  830. : MS            ( n1 -- )       \ delay n1 milli-seconds
  831.                 Win32s?         \ if Win32s then don't use "Sleep", it doesn't work
  832.                 if      ms@ + 15000 0                   \ max delay ~15 seconds
  833.                         do      dup ms@ u< ?leave       \ check for all done
  834.                                 50 0                    \ just a small pause
  835.                                 do      ekey? drop      \ to let OS have time
  836.                                 loop
  837.                         loop    drop
  838.                 else    Call Sleep drop
  839.                 then    ;
  840.  
  841. : SECONDS       ( n1 -- )
  842.                 0max 0
  843.                 ?do     1000 ms
  844.                         start/stop
  845.                 loop    ;
  846.  
  847. : pause-seconds ( n1 -- )
  848.                 cr ." Delaying: " dup . ." seconds, press a key to HOLD "
  849.                 30 min 1 max 10 * 0
  850.                 ?do     100 ms
  851.                         key?
  852.                         if
  853.         cr ." HOLDING,  Space=continue delaying, Enter=cancel pause, ESC=abort"
  854.                                 key  dup 27 =
  855.                                 if      cr ." Aborted" abort
  856.                                 then 13 = ?leave
  857.                                 key  dup 27 =
  858.                                 if      cr ." Aborted" abort
  859.                                 then 13 = ?leave
  860.                                 cr ." Press a key to pause "
  861.                         then
  862.                 loop    ;
  863.  
  864. synonym ?keypause  start/stop           \ from F-PC, pauses if a key is pressed
  865. }
  866. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  867. \       Utility to type a file to the console
  868. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  869.  
  870. : ftype         ( -<name>- )            \ type file "name" to the console
  871.                 bl word $open abort" Couldn't open file!"
  872.                 to loc-file
  873.                 0 to loc-line
  874.                 cur-line off
  875.                 >bold cr ." Typing file: " open-path$ count type cr
  876.                 begin   loc-buf dup read-1line
  877.                 while   type cr
  878. \                        10 ms
  879.                         start/stop
  880.                 repeat  2drop
  881.                 loc-file close-file drop ;
  882.  
  883. \ synonym flist ftype
  884.  
  885. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  886. \       An addition to CASE OF ENDOF ENDCASE, to allow testing ranges
  887. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  888.  
  889. : _of-range     ( n1 n2 n3 -- n1 f1 )
  890.                 2 pick -rot between ;
  891.  
  892. : of-range      ( n1 n2 n3 -- n1 )      \ extention to CASE for a range
  893.                 ?comp compile _of-range compile ?branch >mark 4 ; immediate
  894. comment }
  895. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  896. \       mouse typing
  897. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  898.  
  899. : mxy>cxy       ( x y -- cx cy ) \ convert from mouse xy to character xy
  900.                 charwh rot 2>r / 2r> swap / ;
  901.  
  902. : char@screen   ( x y -- c1 )
  903.                 getmaxcolrow drop * + &the-screen + c@ ;
  904.  
  905. : word@mouse"   ( -- a1 n1 )
  906.                 &the-screen
  907.                 mousex mousey mxy>cxy getrowoff + getmaxcolrow drop * +
  908.                 2dup + c@ bl <>
  909.         if      0 over
  910.                 ?do     over i + c@ bl =
  911.                         if      drop i leave    \ found blank, leave loop
  912.                         then
  913.              -1 +loop                           \ a1=screen, n1=offset to blank
  914.                 getmaxcolrow * swap /string     \ -- a1,n1 of remaining screen
  915.                 bl skip                         \ remove leading blanks
  916.                 2dup bl scan nip -              \ return addr and length
  917.         else    + 0
  918.         then    ;
  919.  
  920.  
  921. : word@mouse>keyboard ( -- )            \ send word at mouse to keyboard
  922.                 mouseflags double_mask and 0= ?exit \ double clicked mouse
  923.                 word@mouse" ?dup
  924.                 if      "pushkeys
  925.                         bl pushkey    \ push a space
  926.                 else    drop
  927.                 then    ;
  928.  
  929. mouse-chain chain-add word@mouse>keyboard
  930.  
  931. : line@mouse"   ( -- a1 n1 )
  932.                 &the-screen
  933.                 mousex mousey mxy>cxy getrowoff + swap >r   \ save x for later
  934.                 getmaxcolrow drop swap * + r>   \ -- a1,n1 the line upto mouse
  935.                 -trailing ;                     \ remove trailing blanks
  936.  
  937.  
  938. : line@mouse>keyboard ( -- )            \ send the line at mouse to keyboard
  939.                 mouseflags 0x09 <> ?exit \ ctrl-left mouse button down
  940.                                                 \ along with the control key
  941.                 line@mouse" ?dup
  942.                 if      "pushkeys
  943.                         0x0D pushkey    \ automatically press Enter
  944.                 else    drop
  945.                 then    ;
  946.  
  947. mouse-chain chain-add line@mouse>keyboard
  948.  
  949. (( MOUSEFLAGS info:
  950.  
  951.         3               both  buttons, currently assigned to abort
  952.  
  953.         1               left  button
  954.         9 control       left  button
  955.        13 control shift left  mouse button
  956.         5         shift left  mouse button
  957.  
  958.         2               right button
  959.        14 control shift right mouse button
  960.        10 control       right mouse button
  961.         6         shift right mouse button
  962.  
  963. ))
  964. }
  965. : exit_stuff    ( -- )                  \ windows callback for cleanup
  966.                 bye-chain do-chain ;
  967.  
  968. \ ' exit_stuff forthproc 3 cells+ !       \ install into windows callback
  969.  
  970.  
  971. : comment:      ( -<comment;>- )        \ all that follows is a comment
  972.                                         \ till COMMENT; is encountered
  973.                 begin   bl word ?uppercase
  974.                         dup count s" COMMENT;" compare
  975.                 while   c@ 0=
  976.                         if      refill 0=
  977.                                 abort" missing COMMENT;"
  978.                         then
  979.                 repeat  drop ; immediate
  980.  
  981. : 2literal      ( d1 -- )
  982.                 swap compile lit , compile lit , ; immediate
  983.  
  984. : sliteral      ( a1 n1 -- )
  985.                 compile (s")
  986.                 here >r dup c, dup allot r@ 1+ swap move
  987.                 0 c, align r> count \n->crlf ; immediate
  988.  
  989. only forth also definitions
  990.  
  991.