Path: utzoo!utgpu!water!watmath!clyde!rutgers!ames!ucbcad!pasteur!ucbvax!decvax!decwrl!cesare.dec.com!zabot
From: zabot@cesare.dec.com (Adv.Tech.Mgr-ACT Torino)
Newsgroups: comp.sys.amiga
Subject: Re: JFORTH
Message-ID: <8801191555.AA20902@decwrl.dec.com>
Date: 19 Jan 88 23:10:00 GMT
Organization: Digital Equipment Corporation
Lines: 469


Subj: RE: JFORTH

Unfortuanately you're right! Jforth promises a lot but delever a lot less!
Anyway, here is something that may help you ( hopefully)!

>	Then I wrote a program that depended upon strings.  Again not 
> all string functions are there as documented in the manual.  

The following WORDS are NOT implemented in JFORTH 1.2:
	$. $accum $clr $concat $ len $variable
I have create my own STRINGS set with the automatic check of the legth of
the receiving field. Comments are in italian, so you may also practice a 
little your language talent :-)
Pleas enote also: the supllied $APPEND doesn't work . It always append a BLANK
to the end of the receiveing field, destroing sometime important things.
Summary of new WORDS:
	$.		( addr --- ) 	print $string
	$clr		( addr --- ) 	clear $string ( ll=0 )	
	$v		equivalent of $variable
		usage:  20 $v name	create a variable <name> with
					a max length of 20 crt.
	$m		( add-1 add-2 --- ) $move if space available
	$app		( add-1 add-2 --- ) $append    "
	$array		
		usage: 10 20 $array name	create an array <name> of
						10 elem ( max length 20)
		does>    i name --> addr-i element

---- cut here ------------------ file: MY-STRINGS --------

anew task-$string

: $. count type ;

: $clr  ( addr-1 ---  , pone a zero la lungh. della stringa )
	0 swap c! ;

false .if
-------------------------------------------------------------------------
Le variabili STRING vengono create con controllo della lunghezza massima.
Questo si ottiene premettendo sempre la lunghezza massima nel dizionario.
La lunghezza massima assoluta e' 255 ( 8 bits, 1 crt ). 
Nel dizionario si ha:
	<cfa> |....|			Un carattere Lunghezza-massima
	      |....|			Un carattere Lungh. Attuale
	      |xxxxxxxx	     |		Variabile
		
Uso:		l-max  $v  nome		( definizione)
		nome    		( -- addr )

Per avere la Lungh. Max di una variable si usa 

       $l-max   ( <nome> --- l-max )

ATTENZIONE ! se la lunghezza al momento della definizione e' maggiore di 255
viene usato il valore modulo 256.
I seguenti comandi effettuano la verifica sulla lunghezza del campo di 
arrivo. In caso di errore avviene solo la stampa di un messaggio e la
operazione non ha luogo.

-------------------------------------------------------------------------
.then

: $v         ( n --- ) ( <name> --in-- )
	create dup 256 * here w! 2 + allot align 
	does> 1+
;

: $l-max   ( addr-var -- l-max )

\  Estrae la lungh. massima della variabile per controlli vari.

	1- c@
;
\ WARNING !! La $append standard non funziona. Aggiunge un BLANK al fondo.
\

Include? { ju:locals

: $append  { add-s ll add-1 }
	add-1 dup c@ ll + swap c!
	add-s add-1 c@ add-1 + ll - 1+ ll cmove
;

FALSE .if
\ Mettere TRUE se si vuole la versione senza variabili locali

: $m	( addr-1 addr-2 --- )

\ Esegue la $move solo se c'e spazio. In caso contrario stampa 
\ un messaggio di errore.

( a1 a2 )           ddup
( a1 a2 a1 a2 )     $l-max
( a1 a2 a1 lm )     swap count swap drop 
( a1 a2 lm c1 )     - 0<
	if ." Errore. Non ci sta' !" ddrop
	else $move
        then
;
: $app	( addr-1 addr-2 --- )

\ Esegue la $append solo se c'e spazio. In caso contrario stampa 
\ un messaggio di errore.

( a1 a2 )           ddup
( a1 a2 a1 a2 )     dup $l-max
( a1 a2 a1 a2 lm )  swap count swap drop
( a1 a2 a1 lm c2 )  - swap count swap drop 
( a1 a2 lm-c2 c1 )  - 0<
	if ." Errore. Non ci sta' !" ddrop
	else 
( a1 a2 )           swap count 
( a2 a1+1 c1 )      rot $append
        then
;


.else
\ Versione con Variabili locali. Un po' piu' di memoria ma occorrono 2.4ms in
\ meno ad ogni call.

: $m	{ addr-1 addr-2 --- }

\ Esegue la $move solo se c'e spazio. In caso contrario stampa 
\ un messaggio di errore.

addr-2 $l-max addr-1 c@ - 0<
	if ." Errore. Non ci sta' !" 
	else addr-1 addr-2 $move
        then
;
: $app	{ addr-1 addr-2 --- }

\ Esegue la $append solo se c'e spazio. In caso contrario stampa 
\ un messaggio di errore.

addr-2 $l-max addr-2 c@ addr-1 c@ + - 0<
	if ." Errore. Non ci sta' !" ddrop
	else 
addr-1 count addr-2 $append
        then
;
.then

False .if
--------------------------------------------------------------------------
Matrici di variabili STRINGS. Ancora con controllo di lunghezza.
Si definisce una matrice con :

	n-el-max l-max  $array    <nome>
	
e si richiama con:

	n-el <nome>

Viene controllato anche che il numero di elemento sia inferiore al massimo
ammesso. Il primo elemento e' lo ZERO. Esempio:

	10 80 $array  riga
	0 riga			e' la prima riga
	9 riga			e' l'ultima riga ( 10 in totale)
Struttura del dizionario:

	<cfa>	|....|			N.max. elem.
		   |....|....|		Lungh.max, lungh elem. zero
  			|xxxxxxx| 	Variabile n. 0
		   |....|....|		Lungh.max, lungh elem  uno
  			|xxxxx|		Variabile n. 1
--------------------------------------------------------------------------
.then
\ Ricordare che $, ( crt --- ) ( <text> --in-- ) mette nel dictionary una
\ stringa con la sua lunghezza.

: cc, ( crt --- )
\ Mette un crt nel dizionario.
	here c! 1 allot
;
: $$,	( crt n --- )
\ Mette nel dizionario una stringa di 'n' caratteri 'crt'
\ ATTENZIONE ! Non fa ALIGN

        dup cc,
        0 do dup cc, loop drop	
;

: $array  ( n-el-max l-max --- ) ( <nome> --in-- )
	  ( n ---  addr )        ( <nome> --in-- )
	create swap dup cc,
		0 do 0 over $$, 0 cc, loop drop align 
	does>   count rot dup 0<
		if  ." Errore indice negativo" ddrop drop
		else	dup rot <
			if swap count 2 + rot * + 
			else ." Errore Indice > max" ddrop
			then
		then
;
-------------------end of MY_STRINGS ----------
    
    Another thing I've done has been to create a SHELL like
    environment for JFORTH. The only thing so far is the HISTORY
    of commands issued to avoid retyping again and again the same
    things when prototyping something. The INTERP is a new version
    of STRING_INTERPRET to handle ( in some way ) at least few
    errors that may happen in your command line. Once again commands
    are in Italian. OK. Next time I'll do it in English.
------------------------ cut here -----------------
anew task-$interp
: $int2 ;

\ excute a string in  addr cnt  form ... Mike Haas, Delta Research

: $INTERPRET  ( string-addr string-cnt -- ???? )
  'TIB @ >r     #TIB @ >r     >IN @ >r   FBLK @ >r   BLK @ >r
  #TIB !  'TIB !  >in off   fblk off   blk off
  BEGIN   bl word   dup c@  \ is there anything in the input stream left?
  WHILE   find              \ YES ... is it in the dictionary?
          IF   compiling?  over >name immediate? 0= and
               IF   cfa,    \ COMPILE it if in comp mode AND its not immediate
               ELSE execute \ otherwise, EXECUTE the thing!
               THEN
          ELSE  \ if its not found in dictionary, is it a number?
                dup number?
                0= if ."    What's that ??-> " $. ." ?"
		   else	drop [compile] literal drop
          	   then
	  THEN
  REPEAT  \ while we did find find something, go back and check again...
  drop    \ nothing left to EXECUTE, get rid of address on stack
  r> blk !   r> fblk !   r> >in !   r> #tib !   r> 'tib !   
;
-----------------------next file SHELL    
anew task-ex

.need csi
	hex
	: csi ( --- ) ( send csi to st-out )
		9b emit ;
	decimal
.then

include? 	$v 		mie-strings
include? 	$int2	 	interp

\ $St-mode indica lo stato  del ciclo: 0 = adggiungo caratteri al fondo,
\ 1 = inserisco caratteri, 2 = overstike.
variable $st-mode 0 $st-mode ! ( set to adding )
variable $st-over 0 $st-over ! ( set to insert )
\ $over indica la scelta tra overstrike ( 1) e insert (0)
: $over? $st-over @ ;
: $ad?	$st-mode @ 0= ;
: $ins? $st-over @ not ;
: $ov?  $st-over @ ;

: $ad-crt ( add-l add-c crt --- add-l add-c )
\  l = l +1    add-c = add-c +1
\  crt is inserted at the end of the string
	over c!
	swap dup dup c@ 1+ swap c! swap 1+
;

: $ins-crt { add-l add-c crt --- add-l add-c }
\  l = l +1    add-c = add-c +1
\ crt is inserted
\ make space first
	add-c dup 1+
	add-l c@ add-l + add-c - 1+ 
        cmove>
\ now insert crt
	crt add-c c!
\ move index
	add-c 1+ -> add-c
\ update length
	add-l c@ 1+ add-l c!
\ reset the stack
	add-l add-c
;

: $ov-crt    { add-l add-c crt --- add-l add-c }
\ overwrite crt at add-c. If last crt switch $st-mode to add.

        crt add-c c!
	add-c add-l dup c@ + =
		if 0 $st-mode !
		then
	add-c 1+ -> add-c
	add-l add-c
;
: $del-crt    { add-l add-c --- add-l add-c }
\ delete crt at add-c abd reduce crt count
	add-c 1- dup 1+ swap 
	add-l c@ add-l + add-c - 1+
        cmove
	add-l c@ 1- add-l c!
\	add-c 1- -> add-c
	add-l add-c
;	

10	constant	$hist-#
255	constant	$line-ll
$hist-# $line-ll 	$array		$sh-area
255	$v		$sh-line
0	variable	$i-sh-store	$i-sh-store !
0	variable	$i-sh-fetch	$i-sh-fetch !
80	$v	$sh-prompt
" F-mz-> " $sh-prompt $m

variable end-loop   
variable end-shell
variable re-fetch?

: $clr-line ( --- )             csi ." M" csi ." F" csi ." E"
                                $sh-prompt $.
				drop dup 0 over c! 1+
;
: $if+1	   ( --- n , add 1 to i-fetch )
	$i-sh-fetch @ 1+ $hist-# mod
;
: $if-1	   ( --- n , sub 1 to i-fetch )
	 $i-sh-fetch @ 1- $hist-# + $hist-# mod 
;
: $is+1	   ( --- n , add 1 to i-fetch )
	$i-sh-store @ 1+ $hist-# mod
;
: $is-1	   ( --- n , sub 1 to i-fetch )
	 $i-sh-store @ 1- $hist-# + $hist-# mod 
;
: $bottom? ( --- flag , verifica se siamo al bottom dello sh-area stack )
	$i-sh-fetch @ $is+1 = 
;
: $top?    ( --- flag , verifica se siamo al top dello sh-area stack )
	$i-sh-fetch @ $i-sh-store @ = 
;

: $re-fetch  	 ( --- add-l add-c ) 
\ tira fuori una riga ll <> 0 e aggiorna i-fetch e mette a punto
\ il resto			
				$clr-line
				$i-sh-fetch @ $sh-area
				dup $. $sh-line $m
				$sh-line dup c@ over + 1+
;	

: $sh-get-line   ( add --- add )
    dup 0 swap c! dup 1+	( l= 0 ;stack= add-l add-c )
    0 $st-mode !		( set add to end )
    0 $st-over !		( set insert mode )
    FALSE end-loop !
	begin			( ciclo interno = read line )
	key 				
	case 155 of
\ sequenza che inizia con CSI 
		key
		case	65 of 		( freccia su' )
			$bottom? not
			if 	$if-1 $i-sh-fetch !
			then
			re-fetch? @ not
			if	drop $i-sh-store @ $sh-area $m 
				true re-fetch? !
			else	ddrop
			then	$re-fetch
  		else	66 of		( freccia giu' )
                        $top? not
                        if 	$if+1 $i-sh-fetch !
			then
                        re-fetch? @ not
                        if      drop $i-sh-store @ $sh-area $m
                                true re-fetch? !
			else	ddrop
                        then    $re-fetch
  		else	67 of		( freccia a destra )
			false  re-fetch? !
			ddup swap - rot dup c@ rot < not >r swap r>
			    if 	csi ." 1C" 1+
			    then 
		else	68 of		( freccia a sinistra )
                        false  re-fetch? !
 			1-		( add-c = add-c -1 )
			8 emit		( move cursor )
			$st-over @ 1 + $st-mode !
		else	." Altro"
		endcase
	else	27 of		( escape = clr-line )
		false re-fetch? !
		$clr-line
		drop dup 0 over c! 1+
	else   1 of
		$st-over @ 1 xor $st-over !	( switch ins/over mode )
	else   8 of
                        false  re-fetch? !
 		swap dup c@ >r swap r>
		if $del-crt csi ." D" csi ." 1P" 
		then 
	else  13 of 
		TRUE  end-loop ! ( set exit )
	else 127 of
                        false  re-fetch? !
 		swap dup c@ >r swap r>
		if
			$ad? not if 1+ $del-crt csi ." P"
				 then
		then	
	else
                        false  re-fetch? !
 	     $ad? if 
			dup >r $ad-crt r> emit 2 
		  else
			$ov? if 
				dup >r $ov-crt r> emit 3
			     then	
			$ins? if 
				dup >r $ins-crt r> csi ." 1@" emit 4
			     then
		  then
	endcase 
	end-loop @ ( check exit )
	until drop
;

: shell
    False end-shell !
    begin			( cliclo esterno = shell )			
	cr $sh-prompt $.
	$sh-line
	begin
	  $sh-get-line 
	  dup c@ 0 = not
	until
    dup " quit" $= 	
   if		true end-shell !
   else
\                                 Abbiamo una riga valida !! Store it !
\                                 ... se diversa dalla precedente	
	dup $is-1 $sh-area $= not
	if 
		dup $i-sh-store @ $sh-area $m
\                                 Ora aggiorniamo l'indice
		$is+1 dup
		$i-sh-fetch ! 
		$i-sh-store !
	then
\ esegue la stringa 
	count $interpret
   then
     end-shell @
until drop
;

: view-hist  cr 10 0 do i i . $sh-area $. cr loop ;
--------------------cut here----------------end of all

> Take for example C,.  A primitive important to have
> in all FORTH standards.  It does not exist!  I had to go searching through 
> several include files to find out where it was defined.
    
    Where is it ?
    
>	Also is there anyway of redirecting all JFORTH screen output to an
> AmigaDos device?

    LOGTO ( <filename> -- input ---, send copy to file )
    seams to be what you want. I've never tried it. See man. pag.
    295. Include JU:LOGTO
    
    Hope this help.
    marco