To: sunne!kris@aeneid (Kris Younger)
Subject: Re: forth tape
In-reply-to: message of Tue, 20 Aug 85 13:26:56 pdt.
             <8508202026.AA03130@aeneid.sunne.uucp>

> Is this a descendent of an 8080 forth of
> any kind? Why did you write it? and How old is it?

History:
  Before I came to Sun I had ported a very old copy of Mike Perry's
68000 Forth 79 system to run on a random 68000 system.  I used it for
diagnostic purposes.  At Sun, I designed the original Multibus SCSI
board and I needed something to test it with, so I ported the system
to run on the Sun (I originally cross-compiled it on a Heath H-89 I had
at home).  This happened in the spring of 1983.  About this time
Mike Perry and Henry Laxen published their public-domain F83 model for
CP/M-80, CP/M-68K, and MS-DOS.  I converted the system to F83 in the
fall of 1983.  Gradually I added support for 32-bit data types, and
eventually made the system use full 32-bit everything.  Look in the
diagnostics directory; it contains Forth diagnostics for just about
every peripheral Sun has.  Diagnostics was my primary motivation,
along with a general love of Forth.

The files.dir/cpm directory is a CP/M-80 backend for my portable file
system interface.  Read the paper in doc/files/ (which was published
in the 1983 FORML Conference proceedings) for a description of the
file system interface.  I have been pushing this interface as a
standard, since it is easily portable to run on nearly every operating
system.  Unfortunately, many people in the Forth community still cling
fondly to blocks, which I dislike intensely.

> Is there any push to add forth as one of sun's languages or is it still
> considered to be some sort second-class language?

I have suggested it; the software establishment at Sun in general
dislikes Forth, so there is some resistance along those lines.
However it is well known in the company that I am a Forth enthusiast,
so customers who want it get directed to me, and I send them a tape.

> One of the things I'd like to do with this forth is make fractals with
> it. I (like so many other people) have implemented a mandelbrot program
> (mine is for the 160) and would like to re-write it in forth (it is
> currently in C).

I saw Vaughn Pratt's Mandelbrot program running yesterday.  The pictures
it draw look really neat on a 160.  I think this stuff is really
fascinating.

> Do you have any ideas about how to use the window system from forth?

Due to my primary focus on diagnostics, I haven't done much
window-system graphics in Forth.  However, your question
goaded me to try it out, so here's some code that I came up
with.  Play with it or use it as an example, as you wish.
It's sort of kludgey right now, as I just wrote it today,
and this is the first time I've ever tried to write any
sort of SunWindows program.

Make a subdirectory forth/sunwindows, copy the rest of this
message into a file therein, and run /bin/sh on the file.
Then read the README.

: to unbundle, "sh" this file -- DO NOT use csh
:  SHAR archive format.  Archive created Wed Aug 21 21:50:52 PDT 1985
echo x - Makefile
sed 's/^X//' > Makefile <<'+FUNKY+STUFF+'
Xws.out: ws.o pixwin.o
X	ld -r -o ws.out pixwin.o ws.o -lsuntool -lsunwindow -lpixrect
X
Xpixwin.o: pixwin.c
X	cc -c -w pixwin.c
X
Xws.o: ws.s
X	cc -c ws.s
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb           148 Aug 21 21:38 Makefile    (as sent)'
chmod u=rw,g=rw,o=r Makefile
ls -l Makefile
echo x - README
sed 's/^X//' > README <<'+FUNKY+STUFF+'
X	Kludgey forth-to-SunWIndows interface
X
XFiles:
X
XMakefile	Creates the object files which contain the
X		window libraries.
X
Xpixwin.c	Creates subroutine interfaces to some pixwin
X		 operations. (Normally they're C macros, which
X		 forth can't handle).
Xws.s		Defines some entry point into the window libraries,
X		 forcing those routines to be loaded.  Probably
X		 should be done using command line switches to the
X		 ld command.
X
Xhtof.sed	A little bit of help for converting .h files to
X		 something forth can handle.  Converts comments
X		 and constants mostly.
Xcstruct.f	A little more help, allowing forth to define
X		 structures in a way a bit closer to C.
X
Xpixrect.f	Selected portions of /usr/include/pixrect/pixrect.h
X		 converted to forth.
X
Xtool.f		Selected portions of several /usr/include/suntool/???.h
X		 files converted to forth.
X
Xtoolsubs.f	Interfaces to some of the routines pulled in by ws.s.
X
Xwstest.f	Forth words to create and control a window.
X
X
XTo use:
X
X% make   ( creates ws.out, a big file containing window library routines)
X% forth
Xok requires clink.f    \ Load the forth-C interface routines
Xok "" ws.out clink     \ this takes a while; it has to relocate the libs
Xok load wstest.f
Xok \ Now you can play around; try this:
Xok " My window" maketool
Xok 100 100 " this is some text" wstype
Xok 200 200 100 100 vdraw
Xok 50 50 biton
Xok \ Read the comments in wstest.f for more info
Xok redraw
Xok kill
Xok bye
X% 
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb          1419 Aug 21 21:36 README    (as sent)'
chmod u=rw,g=rw,o=r README
ls -l README
echo x - cstruct.f
sed 's/^X//' > cstruct.f <<'+FUNKY+STUFF+'
Xcreate cstruct.f
X
X0 constant struct
X: field ( offset size -- offset+size )
X  create over , +
X  ;code ( structaddr -- memberaddr )
X     normal w ) d0 move sp ) d0 add  d0 sp ) move
Xc;
X: short /w field ;
X: int /l field ;
X: ptr /l field ;
X: caddr_t /l field ;
X: char* ptr ;
X: int*  ptr ;
X: long* ptr ;
X: struct* ptr ;
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb           315 Aug 21 11:18 cstruct.f    (as sent)'
chmod u=rw,g=rw,o=r cstruct.f
ls -l cstruct.f
echo x - htof.sed
sed 's/^X//' > htof.sed <<'+FUNKY+STUFF+'
X/\/\* \(.*\)\*\/$/s// \\ \1/
X/#define[ 	]*\([^ 	][^ 	]*\)[ 	][ 	]*\([^ 	][^ 	]*\)/s//\2 constant \1/
X/0x/s//th /
X/(/s///g
X/)/s///g
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb           131 Aug 21 10:40 htof.sed    (as sent)'
chmod u=rw,g=rw,o=r htof.sed
ls -l htof.sed
echo x - pixrect.f
sed 's/^X//' > pixrect.f <<'+FUNKY+STUFF+'
Xhex
X18 constant PIX_SRC
X14 constant PIX_DST
X: PIX_NOT ( op -- not-op )
X  not 1e and
X;
XPIX_SRC PIX_NOT PIX_SRC and constant PIX_CLR
XPIX_SRC PIX_NOT PIX_SRC or  constant PIX_SET
X: PIX_COLOR ( color -- op ) 5 << ;
X: PIX_OPCOLOR ( op -- color ) 5 >> ;
X
X: PIXOP_NEEDS_DST ( op -- f )	dup 1 >> xor   PIX_DST PIX_NOT   and  ;
X: PIXOP_NEEDS_SRC ( op -- f )	dup 2 >> xor   PIX_SRC PIX_NOT   and  ;
X
X1 constant PIX_DONTCLIP
X0 constant PIX_CLIP
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb           434 Aug 21 18:43 pixrect.f    (as sent)'
chmod u=rw,g=rw,o=r pixrect.f
ls -l pixrect.f
echo x - pixwin.c
sed 's/^X//' > pixwin.c <<'+FUNKY+STUFF+'
X#include <suntool/tool_hs.h>
Xxpw_rop(dpw, dx, dy, w, h, op, sp, sx, sy)
X{pw_rop(dpw, dx, dy, w, h, op, sp, sx, sy);}
Xxpw_write(dpw, dx, dy, w, h, op, spr, sx, sy)
X{pw_write(dpw, dx, dy, w, h, op, spr, sx, sy);}
Xxpw_writebackground(dpw, dx, dy, w, h, op)
X{pw_writebackground(dpw, dx, dy, w, h, op); }
Xxpw_read(dpr, dx, dy, w, h, op, spw, sx, sy)
X{pw_read(dpr, dx, dy, w, h, op, spw, sx, sy); }
Xxpw_copy(dpw, dx, dy, w, h, op, spw, sx, sy)
X{pw_copy(dpw, dx, dy, w, h, op, spw, sx, sy); }
Xxpw_batchrop(dpw, x, y, op, sbp, n)
X{pw_batchrop(dpw, x, y, op, sbp, n); }
Xxpw_stencil(dpw, x, y, w, h, op, stpr, stx, sty, spr, sy, sx)
X{pw_stencil(dpw, x, y, w, h, op, stpr, stx, sty, spr, sy, sx); }
Xxpw_destroy(pw)
X{pw_destroy(pw); }
Xxpw_get(pw, x, y)
X{pw_get(pw, x, y); }
Xxpw_put(pw, x, y, val)
X{pw_put(pw, x, y, val); }
Xxpw_vector(pw, x0, y0, x1, y1, op, val)
X{pw_vector(pw, x0, y0, x1, y1, op, val); }
Xxpw_region(pw, x, y, w, h)
X{pw_region(pw, x, y, w, h); }
Xxpw_putattributes(pw, planes)
X{pw_putattributes(pw, planes); }
Xxpw_getattributes(pw, planes)
X{pw_getattributes(pw, planes); }
Xxpw_putcolormap(pw, index, count, red, green, blue)
X{pw_putcolormap(pw, index, count, red, green, blue); }
Xxpw_getcolormap(pw, index, count, red, green, blue)
X{pw_getcolormap(pw, index, count, red, green, blue); }
Xxpw_lock(pixwin,rect)
X{pw_lock(pixwin,rect); }
Xxpw_reset(pixwin)
X{pw_reset(pixwin); }
Xxpw_getclipping(pixwin)
X{pw_getclipping(pixwin); }
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb          1428 Aug 21 19:53 pixwin.c    (as sent)'
chmod u=rw,g=rw,o=r pixwin.c
ls -l pixwin.c
echo x - tool.f
sed 's/^X//' > tool.f <<'+FUNKY+STUFF+'
Xrequires cstruct.f
Xcreate tool.f
Xdecimal
X: coord short ;
X
Xstruct ( rect)
X	coord r_left
X	coord r_right
X	short r_width
X	short r_height
Xconstant /rect
X
Xstruct	( toolio)
X	int	tio_inputmask	 \ Additional fd to select on in tool_select 
X	int	tio_outputmask	 \ See select system call documentation 
X	int	tio_exceptmask
X	struct*	tio_timer ( timeval)  \ Timeout used in tool_select 
X	int*	tio_handlesigwinch \ call when win should repair image 
X	int*	tio_selected       \ call from tool_select 
Xconstant /toolio
X
Xth 01 constant TOOL_NAMESTRIPE	 \ include a name stripe 
Xth 02 constant TOOL_BOUNDARYMGR	 \ movable borders between subwindows 
Xth 04 constant TOOL_ICONIC	 \ current state is iconic 
Xth 08 constant TOOL_SIGCHLD	 \ info passed to tool_select 
Xth 10 constant TOOL_SIGWINCHPENDING	 \ need to call tool_handlesigwinch
Xth 20 constant TOOL_DONE	 \ need to return from tool_select 
Xth 0100 constant TOOL_FIRSTPRIV \ start of private flags range 
Xth 8000 constant TOOL_LASTPRIV \ end of private flags range 
X
Xstruct	( tool)
X	short	tl_flags	 \ tool booleans 
X	int	tl_windowfd	 \ file descriptor of tool window 
X	char*   tl_name		 \ string in name stripe & default icon 
X	struct* tl_icon	( icon)  \ icon 
X	/toolio field tl_io	 \ Tool_select and signal handling 
X	struct*	tl_sw ( toolsw)	 \ list of subwindows that tool is managing 
X	struct*	tl_pixwin ( pixwin)  \ display mechanism structure 
X	/rect field tl_rectcache  \ rect of tool tool relative 
Xconstant /tool
X
Xstruct	( toolsw )
X	struct*	ts_next ( toolsw) \ next subwindow 
X	int	ts_windowfd	\ file descriptor of subwindow 
X	char*	ts_name		\ identifies subwindow for future use 
X	short	ts_width	\ width at which sw wants to be maintained 
X	short	ts_height	\ height at which sw wants to be maintained 
X-1 constant TOOL_SWEXTENDTOEDGE \ extend width|height to edge of tool 
X	/toolio field ts_io	\ Tool_select and signal handling 
X	int*	ts_destroy	\ call when removing subwindow 
X	caddr_t	ts_data 	\ uninterpreted data passed to functions 
Xconstant /toolsw
X
X\ Tool attributes:
X
X1 constant WIN_COLUMNS	 \ width in columns of internal area 
X					 \ u_int 
X2 constant WIN_LINES	 \ height in lines of internal area 
X					 \ u_int 
X3 constant WIN_WIDTH	 \ width of normal sized window 
X					 \ u_int 
X4 constant WIN_HEIGHT	 \ height of normal sized window 
X					 \ u_int 
X5 constant WIN_LEFT	 \ x position of normal sized window 
X					 \ int 
X6 constant WIN_TOP	 \ y position of normal sized window 
X					 \ int 
X7 constant WIN_ICONIC	 \ window is iconic 
X					 \ 0 | 1 
X8 constant WIN_DEFAULT_CMS	 \ use window's colormap as default 
X					 \ 0 | 1 
X9 constant WIN_REPAINT_LOCK	 \ supress repainting 
X					 \ 0 | 1 
X10 constant WIN_LAYOUT_LOCK	 \ surpress subwindow layout 
X					 \ 0 | 1 
X11 constant WIN_NAME_STRIPE	 \ display name stripe 
X					 \ 0 | 1 
X12 constant WIN_BOUNDARY_MGR	 \ enable subwindow boundary mover 
X					 \ 0 | 1 
X13 constant WIN_LABEL	 \ label in name stripe 
X					 \ char * 
X14 constant WIN_FOREGROUND	 \ foreground color rgb 
X					 \ struct singlecolor * pixrect.h 
X15 constant WIN_BACKGROUND	 \ background color rgb 
X					 \ struct singlecolor * pixrect.h 
X16 constant WIN_ICON	 \ window's icon 
X					 \ struct icon * icon.h 
X17 constant WIN_ICON_LEFT	 \ icon's x position on desktop 
X					 \ int 
X18 constant WIN_ICON_TOP	 \ icon's y position on desktop 
X					 \ int 
X19 constant WIN_ICON_LABEL	 \ icon's label 
X					 \ char * 
X20 constant WIN_ICON_IMAGE	 \ icon's graphic image 
X					 \ struct pixrect * pixrect.h 
X21 constant WIN_ICON_FONT	 \ icon label's font 
X					 \ struct pixfont * pixfont.h 
X-1 constant WIN_ATTR_LIST	 \ attribute list within another 
X					 \ int attr.h's ATTRIBUTE_LIST 
X
X\ Standard but not enforced constant values
X
X5 constant TOOL_BORDERWIDTH
XTOOL_BORDERWIDTH constant TOOL_SUBWINDOWSPACING
X0 constant TOOL_NAMESTRIPEXTR
X64 constant TOOL_ICONHEIGHT
X64 constant TOOL_ICONWIDTH
X64 constant TOOL_ICONHEIGHT
X0 constant TOOL_ICONMARGIN
X
XTOOL_ICONWIDTH  TOOL_ICONMARGIN 2* - constant TOOL_ICONIMAGEWIDTH
XTOOL_ICONHEIGHT TOOL_ICONMARGIN 2* - constant TOOL_ICONIMAGEHEIGHT
XTOOL_ICONMARGIN constant TOOL_ICONIMAGELEFT
XTOOL_ICONMARGIN constant TOOL_ICONIMAGETOP
X
XTOOL_ICONIMAGEWIDTH 			constant TOOL_ICONTEXTWIDTH
XTOOL_ICONHEIGHT TOOL_ICONHEIGHT 4 / -	constant TOOL_ICONTEXTHEIGHT
XTOOL_ICONIMAGELEFT			constant TOOL_ICONTEXTLEFT
XTOOL_ICONHEIGHT TOOL_ICONTEXTHEIGHT TOOL_ICONMARGIN + -
X					constant TOOL_ICONTEXTTOP
X
X\ #define	tool_install(tool)	win_insert((tool)->tl_windowfd)
X\ #define	tool_getnormalrect(tool, rectp) \
X\ 	    wmgr_getnormalrect((tool)->tl_windowfd, (rectp))
X\ #define	tool_setnormalrect(tool, rectp) \
X\ 	    wmgr_setnormalrect((tool)->tl_windowfd, (rectp))
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb          4663 Aug 21 14:45 tool.f    (as sent)'
chmod u=rw,g=rw,o=r tool.f
ls -l tool.f
echo x - toolsubs.f
sed 's/^X//' > toolsubs.f <<'+FUNKY+STUFF+'
Xrequires tool.f
Xcreate toolsubs.f
X
X: rmavpairs ( 0 val attr .. val attr -- )
X  begin while drop repeat
X;
X: tool_make ( av-pairs -- tool )
X  _tool_make rmavpairs ret
X;
X: tool_select ( wait-for-processes-to-die? tool -- )
X  _tool_select 2drop
X;
X: tool_destroy ( tool -- )
X  _tool_destroy drop
X;
X: win_insert ( windowfd -- )
X  _win_insert drop
X;
X: tool_install ( tool -- )
X  tl_windowfd @  win_insert
X;
X\ : msgsw_createtoolsubwindow ( *font *string height width *name *tool -- msgsw )
X\   _msgsw_createtoolsubwindow 2drop 2drop 2drop ret
X\ ;
X: pw_char ( c font op y x pw -- )
X  _pw_char 2drop 2drop 2drop
X;
X: pw_text ( str font op y x pw -- )
X  _pw_text 2drop 2drop 2drop
X;
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb           671 Aug 21 20:16 toolsubs.f    (as sent)'
chmod u=rw,g=rw,o=r toolsubs.f
ls -l toolsubs.f
echo x - ws.s
sed 's/^X//' > ws.s <<'+FUNKY+STUFF+'
X.globl _tool_make
X.globl _win_insert
X.globl _tool_select
X.globl _tool_destroy
X.globl _tool_sigwinch
X| .globl _msgsw_createtoolsubwindow
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb           136 Aug 21 20:15 ws.s    (as sent)'
chmod u=rw,g=rw,o=r ws.s
ls -l ws.s
echo x - wstest.f
sed 's/^X//' > wstest.f <<'+FUNKY+STUFF+'
X\ A simple forth interface to SunWindows.
X\ Doesn't handle SIGWINCH right, because I didn't
X\ want to deal with serializing input and stuff just yet.
X
X\ This probably should have just used a graphics subwindow,
X\ but I wanted to play around and learn about the window system.
X
Xrequires tool.f
Xrequires toolsubs.f
Xrequires signal.f
Xrequires pixrect.f
X
Xdecimal
X
Xvariable tool
X
Xcreate nullstr 0 ,
X
X\ Makes an entry point where C can call a forth routine
X: c-entry-handler ( #args #returns -- entry-address ) ( Input stream: name )
X  bl word ( #args #returns str )
X  find 0= if interpret-do-undefined then  ( #args #returns cfa )
X  makebody       ( #args ip ) \ defined in lib/fcall.f
X  here -rot  ( entry-point #args ip )
X  swap make-c-entry ( entry-point )
X;
X\ Redraw the window.  Right now this will erase its contents too
X: redraw ( -- )
X  tool @ _tool_handlesigwinchstd drop
X;
X0 0 c-entry-handler redraw  ( addr ) constant sigwinchhandler
X
X\ Create a window with the given name in the name stripe
X: maketool ( name -- )
X  depth 1 < abort" maketool needs a tool name"
X  0 swap cstr WIN_LABEL tool_make tool !
X  tool @ 0=  abort" Can't make tool"
X  sigwinchhandler    SIGWINCH   signal   drop
X  tool @ tool_install
X  redraw
X;
X
X\ Destroy the window
X: kill ( -- ) tool @ tool_destroy ;
X
X: window ( -- window ) tool @ tl_windowfd @ ;
X: pw ( -- pixwin ) tool @ tl_pixwin @ ;
X: wscom ( x y char -- )
X  -rot swap ( str y x )
X  0 ( default font ) -rot  ( str 0 y x )
X  PIX_SRC -rot             ( str 0 SRC y x )
X  pw
X;
X
X\ Display the string in the window at x, y
X: wstype ( x y str -- ) cstr wscom pw_text ;
X
X\ Display the character in the window at x, y
X: wsemit ( x y char -- ) wscom pw_char ;
X
X: vcom  ( xend yend xstart ystart -- )
X
X\ Draw a vector from startxy to endxy
X: vdraw ( xend yend xstart ystart -- )
X  >r >r >r >r 1 ( black ) PIX_SRC r> r> swap r> r> swap
X  pw _xpw_vector 2drop 2drop 2drop drop
X;
X
X\ Erase (draw with white) the vector from startxy to endxy
X: verase ( xend yend xstart ystart -- )
X  >r >r >r >r 0 ( white ) PIX_SRC r> r> swap r> r> swap
X  pw _xpw_vector 2drop 2drop 2drop drop
X;
X
X: putpixel ( x y value -- )
X  -rot swap pw _xpw_put 2drop 2drop
X;
X
X\ Turn on (black) the bit at x y
X: biton ( x y -- )  1 putpixel ;
X
X\ Turn off (white) the bit at x y
X: bitoff ( x y -- )  0 putpixel ;
+FUNKY+STUFF+
echo '-rw-rw-r--  1 wmb          2305 Aug 21 21:51 wstest.f    (as sent)'
chmod u=rw,g=rw,o=r wstest.f
ls -l wstest.f
exit 0