REM >!RunImage
 REM (C) Martyn Fox
 REM shape drawing program
 REM based on Wimp shell program v0.01
 version$="0.01 (date)"
 ON ERROR SYS "Wimp_CloseDown",task%,&4B534154:REPORT:PRINT" at line ";ERL:END
 SYS "Wimp_Initialise",200,&4B534154,"Shapes" TO ,task%
 PROCinit
 PROCcreateicon
 ON ERROR IF FNerror THEN PROCclose:END
 REPEAT
   PROCpoll
 UNTIL quit%
 PROCclose
 END
 :
 DEFPROCcreateicon
 REM creates the application's icon and puts it on the icon bar
 !b%=-1:b%!4=0:b%!8=0:b%!12=68:b%!16=68:b%!20=&3002
 $(b%+24)="!shapes":SYS"Wimp_CreateIcon",,b% TO i%
 ENDPROC
 :
 DEFPROCclose
 REM tells the Wimp to quit the application
 ON ERROR OFF
 PROClose_fonts
 SYS "Wimp_CloseDown",task%,&4B534154
 ENDPROC
 :
 DEFPROCpoll
 REM main program Wimp polling loop
 SYS "Wimp_Poll",&3831,b% TO r%
 CASE r% OF
   WHEN 1:PROCredraw(b%)
   WHEN 2:SYS "Wimp_OpenWindow",,b%
   WHEN 3:SYS "Wimp_CloseWindow",,b%
   WHEN 6:PROCmouseclick
   WHEN 7:PROCdragend
   WHEN 8:PROCkeypress
   WHEN 9:PROCmenuclick
   WHEN 17,18:PROCreceive
 ENDCASE
 ENDPROC
 :
 DEFPROCmouseclick
 REM handles mouse clicks in response to Wimp_Poll reason code 6
 REM b%!0=mousex,b%!4=mousey:b%!8=buttons:b%!12=window handle (-2 for icon bar):b%!16=icon handle
 CASE b%!12 OF
   WHEN -2:CASE b%!8 OF
     WHEN 2:PROCshowmenu(mainmenu%,!b%-64,96+2*44):REM replace '2' with number of main menu items
     WHEN 4:!b%=main%:SYS "Wimp_GetWindowState",,b%:b%!28=-1:SYS "Wimp_OpenWindow",,b%
   ENDCASE
   WHEN main%:PROCwindow_click
   WHEN options%:PROCopt_box(b%!8,b%!16)
   WHEN saveas%:PROCsavebox
 ENDCASE
 ENDPROC
 :
 DEFPROCget_origin(handle%,RETURN xorig%,RETURN yorig%)
 REM returns coordinates of window work area origin
 LOCAL c%
 c%=FNstack(36)
 !c%=handle%
 SYS "Wimp_GetWindowState",,c%
 xorig%=c%!4-c%!20:yorig%=c%!16-c%!24
 PROCunstack(c%)
 ENDPROC
 :
 DEFFNstack(size%)
 REM allocates temporary memory from stack block
 REM stack must be cleared after use with PROCunstack
 IF stackptr%+size%>stackend%  ERROR 1,"No room in stack"
 stackptr%+=size%
 =stackptr%-size%
 :
 DEFPROCunstack(old_ptr%)
 REM removes temporary memory from stack
 stackptr%=old_ptr%
 IF stackptr%<stack% stackptr%=stack%
 ENDPROC
 :
 DEFFNmake_menu
 REM creates menu block from DATA statements
 LOCAL start%,title$,item$,ul%,tail$,writable%,buffer%,buflen%
 start%=menspc%
 READ title$
 $(start%)=title$
 start%?12=7:REM title foreground colour
 start%?13=2:REM title background colour
 start%?14=7:REM work area foreground colour
 start%?15=0:REM work area background colour
 start%!20=44:REM height of menu items
 start%!24=0:REM gap between items
 width%=LEN(title$)-3
 menspc%+=28
 REPEAT
   READ item$
   IF item$<>"*" THEN
     !menspc%=0
     writable%=FALSE
     ul%=INSTR(item$,"_")
     IF ul% THEN
       tail$=RIGHT$(item$,LEN(item$)-ul%)
       IF INSTR(tail$,"T") !menspc%=!menspc% OR 1:REM tick
       IF INSTR(tail$,"D") !menspc%=!menspc% OR 2:REM dotted line
       IF INSTR(tail$,"W") !menspc%=!menspc% OR 4:writable%=TRUE:READ buffer%:READ buflen%:REM writable icon
       IF INSTR(tail$,"M") !menspc%=!menspc% OR 8:REM generate message
       item$=LEFT$(item$,ul%-1)
     ENDIF
     IF LENitem$>width% width%=LENitem$
     menspc%!4=-1:REM submenu ptr
     IF writable% THEN
       menspc%!8=&0700F121:menspc%!12=buffer%:menspc%!16=-1:menspc%!20=buflen%:$buffer%=item$
       ELSE
       IF LENitem$<12 THEN
         menspc%!8=&07000021:$(menspc%+12)=item$
         ELSE
         menspc%!8=&07000121:menspc%!12=ws%:menspc%!16=-1:menspc%!20=LENitem$+1
         $ws%=item$:ws%+=LENitem$+1
       ENDIF
     ENDIF
     menspc%+=24
   ENDIF
 UNTIL item$="*"
 start%!16=width%*16+32
 !(menspc%-24)=!(menspc%-24) OR &80
 mptr%=menspc%
 =start%
 :
 DEFPROCload_templates
 REM opens window template file, loads and creates window
 SYS "Wimp_OpenTemplate",,"<Shapes$Dir>.Templates"
 REM ****** load and create Info box ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"progInfo",0 TO ,,ws%
 $stack%!(88+32*0+20)=version$
 SYS "Wimp_CreateWindow",,stack% TO info%
 REM ****** load and create main window ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"Main",0 TO ,,ws%
 SYS "Wimp_CreateWindow",,stack% TO main%
 REM ****** load and create Options dialogue box ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"Options",0 TO ,,ws%
 textbuf%=!(stack%+88+32*7+20)
 SYS "Wimp_CreateWindow",,stack% TO options%
 REM ****** load and create Save box ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"xfer_send",0 TO ,,ws%
 savestr%=!(stack%+88+32*2+20)
 SYS "Wimp_CreateWindow",,stack% TO saveas%
 REM ****** end of window creation ******
 SYS "Wimp_CloseTemplate"
 ENDPROC
 :
 DEFPROCattach(menu%,item%,sub%)
 REM attach submenu or dialogue box to main menu
 !(menu%+28+item%*24+4)=sub%
 ENDPROC
 :
 DEFPROCinit
 REM initialisation before polling loop starts
 DIM b% 255,ws% 2047,menspc% 2047,stack% 1023,list% 2047,ptsize% 12,fontname% 50
 $ptsize%=""
 $fontname%="Trinity.Medium"
 wsend%=ws%+2048:stackend%=stack%+1024:stackptr%=stack%:menend%=menspc%+2048:fontlist%=list%+1024
 quit%=FALSE
 !list%=-1:!fontlist%=-1
 colsel%=7
 PROCload_templates
 PROCmenus
 !b%=main%:SYS "Wimp_GetWindowState",,b%:SYS "Wimp_OpenWindow",,b%
 ENDPROC
 :
 DEFPROCreceive
 REM handles messages received from the Wimp with reason codes 17 or 18
 CASE b%!16 OF
   WHEN 0:quit%=TRUE
   WHEN 2:PROCsave
   WHEN 3:PROCload
   WHEN &400C0:PROCmenu_message
 ENDCASE
 ENDPROC
 :
 DEFPROCwindow_click
 REM handles mouse clicks on window
 REM b%!0=mousex,b%!4=mousey:b%!8=buttons:b%!12=window handle (-2 for icon bar):b%!16=icon handle
 CASE b%!8 OF
   WHEN 2:PROCshowmenu(wmenu%,!b%,b%!4)
   WHEN 1:PROCdelete_item
   WHEN 4:PROCadd_item
 ENDCASE
 ENDPROC
 :
 DEFPROCmenus
 REM create menus and attach submenus and dialogue boxes
 PROCmain_menu
 PROCattach(mainmenu%,0,info%)
 PROCwindow_menu
 PROCfont_size_menu
 PROCattach(wmenu%,0,options%)
 PROCattach(wmenu%,2,saveas%)
 PROCattach(wmenu%,3,1)
 PROCattach(wmenu%,4,fmenu%)
 $savestr%="ShapeFile"
 ENDPROC
 :
 DEFPROCshowmenu(menu%,x%,y%)
 REM opens menu at given coordinates
 topmenu%=menu%:topx%=x%:topy%=y%
 SYS "Wimp_CreateMenu",,menu%,x%,y%
 ENDPROC
 :
 DEFPROCmenuclick
 REM handles mouse clicks on menu in response to Wimp_Poll reason code 9
 LOCAL c%,adj%
 c%=FNstack(20)
 SYS "Wimp_GetPointerInfo",,c%
 adj%=(c%!8 AND 1)
 SYS "Wimp_DecodeMenu",,topmenu%,b%,c%
 CASE $c% OF
   WHEN "Quit":quit%=TRUE
   WHEN "Clear":PROCclear
   WHEN "Save":PROCchecksave
   OTHERWISE
     IF LEFT$($c%,5)="Font.":PROCpick_font
 ENDCASE
 IF adj% PROCshowmenu(topmenu%,topx%,topy%)
 PROCunstack(c%)
 ENDPROC
 :
 DEFPROCmain_menu
 REM creates main menu, calling FNmake_menu
 RESTORE +1
 DATA Shapes,Info,Quit,*
 mainmenu%=FNmake_menu
 ENDPROC
 :
 DEFPROCredraw(b%)
 REM redraws window contents
 LOCAL xorig%,yorig%,more%
 PROCget_origin(!b%,xorig%,yorig%)
 SYS "Wimp_RedrawWindow",,b% TO more%
 WHILE more%
   PROCdraw(b%,xorig%,yorig%)
   SYS "Wimp_GetRectangle",,b% TO more%
 ENDWHILE
 ENDPROC
 :
 DEFPROCdraw(b%,xorig%,yorig%)
 REM called when all or part of window needs redrawing
 REM xorig% and yorig% are coordinates of work area origin (top left-hand corner of window work area)
 REM b% points to block:
 REM b%!0  : window handle
 REM b%!4  : visible area minimum x coordinate
 REM b%!8  : visible area minimum y coordinate
 REM b%!12 : visible area maximum x coordinate
 REM b%!16 : visible area maximum y coordinate
 REM b%!20 : scroll x offset relative to work area origin
 REM b%!24 : scroll y offset relative to work area origin
 REM b%!28 : current graphics window minimum x coordinate
 REM b%!32 : current graphics window minimum y coordinate
 REM b%!36 : current graphics window maximum x coordinate
 REM b%!40 : current graphics window maximum y coordinate
 LOCAL coords%,colour%,plot%
 MOVE xorig%,yorig%
 coords%=list%
 WHILE !coords%<>-1
   PROCplot_shape(!coords%,x%,y%,colour%,plot%)
   IF plot%=0 THEN
     PROCtext(xorig%+x%,yorig%-y%,colour%,coords%)
   ELSE
     SYS "Wimp_SetColour",colour%
     PLOT plot%,xorig%+x%,yorig%-y%
     coords%+=4
   ENDIF
 ENDWHILE
 ENDPROC
 :
 DEFPROCplot_shape(word%,RETURN x%,RETURN y%,RETURN colour%,RETURN plot%)
 REM returns parameters of object to be plotted, decoded from word%
 x%=(word% AND &3FF)*4:y%=(word%>>12) AND &FFC
 colour%=(word%>>10) AND &F
 plot%=(word%>>24) AND &FF
 ENDPROC
 :
 DEFPROCwindow_menu
 RESTORE +1
 DATA Shapes,Options,Clear,Save,Font_M,Font size,*
 wmenu%=FNmake_menu
 ENDPROC
 :
 DEFFNicon_state(window%,icon%)
 LOCAL c%
 c%=FNstack(40)
 !c%=window%
 c%!4=icon%
 SYS "Wimp_GetIconState",,c%
 PROCunstack(c%)
 =((c%!24) AND (1<<21))<>0
 :
 DEFPROCadd_item
 x%=!b%:y%=b%!4
 PROCget_origin(main%,xorig%,yorig%)
 coords%=FNend
 IF coords%<list%+1020 THEN
 CASE TRUE OF
   WHEN FNicon_state(options%,0):plot%=4:REM MOVE
   WHEN FNicon_state(options%,1):plot%=5:REM DRAW
   WHEN FNicon_state(options%,2):plot%=157:REM CIRCLE FILL
   WHEN FNicon_state(options%,3):plot%=101:REM RECTANGLE FILL
   WHEN FNicon_state(options%,6):plot%=0:REM TEXT
   OTHERWISE:plot%=4:REM MOVE - all icons deselected
 ENDCASE
 !coords%=(((x%-xorig%) AND &FFC) DIV 4)+((yorig%-y%) AND &FFC)*(1<<12)+(colsel% AND &F)*(1<<10)
 coords%?3=plot%
 IF plot%=0 PROCadd_text(coords%)
 coords%!4=-1
 PROCforce_redraw(main%)
 ENDIF
 ENDPROC
 :
 DEFFNend
 LOCAL n%
 n%=list%
 WHILE !n%<>-1
   n%+=4
 ENDWHILE
 =n%
 :
 DEFPROCforce_redraw(window%)
 LOCAL c%
 c%=FNstack(36)
 !c%=window%
 SYS "Wimp_GetWindowState",,c%
 SYS "Wimp_ForceRedraw",-1,c%!4,c%!8,c%!12,c%!16
 PROCunstack(c%)
 ENDPROC
 :
 DEFPROCdelete_item
 coords%=FNend
 IF coords%>list% THEN
   coords%-=4
   IF (!coords% AND &FF000000)=0 coords%-=!coords%:SYS "Font_LoseFont",coords%!4
   !coords%=-1
 ELSE
   VDU 7
 ENDIF
 PROCforce_redraw(main%)
 ENDPROC
 :
 DEFPROCopt_box(button%,icon%)
 CASE icon% OF
   WHEN 0,1,2,3,6:
   WHEN 5:
     !b%=options%:b%!4=4
     SYS "Wimp_GetIconState",,b%
     colsel%=(b%!24)>>28
     IF button%=4 SYS "Wimp_CreateMenu",,-1
   OTHERWISE
     !b%=options%:b%!4=icon%
     SYS "Wimp_GetIconState",,b%
     b%!4=4:b%!8=(b%!24) AND &F<<28:b%!12=&F<<28
     SYS "Wimp_SetIconState",,b%
 ENDCASE
 ENDPROC
 :
 DEFPROCclear
 PROClose_fonts
 !list%=-1
 PROCforce_redraw(main%)
 ENDPROC
 :
 DEFFNerror
 !b%=ERR
 CASE !b% OF
 WHEN 1<<30:err_str$="":box%=3
 OTHERWISE:err_str$=" at line "+STR$ERL:box%=2
 ENDCASE
 $(b%+4)=REPORT$+err_str$+CHR$0
 SYS "Wimp_ReportError",b%,box%,"Shapes" TO ,response%
 =(response%=2)
 :
 DEFPROCload
 IF b%!40<>&012 ERROR 1<<30,"Filetype not recognised"
 PROCterm(b%+44)
 PROClose_fonts
 SYS "XOS_CLI","LOAD "+$(b%+44)+" "+STR$~list% TO err%;flags%
 IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
 b%!12=b%!8
 b%!16=4:REM Message_DataLoadAck
 SYS "Wimp_SendMessage",17,b%,b%!4
 $savestr%=$(b%+44)
 PROCupdate_fonts
 !b%=main%
 SYS "Wimp_GetWindowState",,b%
 IF ((b%!32) AND 1<<16)=0 THEN
   SYS "Wimp_OpenWindow",,b%
 ELSE
   PROCforce_redraw(main%)
 ENDIF
 ENDPROC
 :
 DEFPROCterm(a%)
 LOCAL n%
 WHILE a%?n%>31
   n%+=1
 ENDWHILE
 a%?n%=13
 ENDPROC
 :
 DEFPROCsavebox
 CASE b%!16 OF
   WHEN 0:IF b%!8=1 OR b%!8=4 THEN PROCchecksave
   WHEN 1:IF b%!8=16 OR b%!8=64 THEN PROCdrag(b%!12,1)
 ENDCASE
 ENDPROC
 :
 DEFPROCdrag(window%,icon%)
 LOCAL c%
 c%=FNstack(56)
 PROCget_origin(window%,xorig%,yorig%)
 !c%=window%:c%!4=icon%
 SYS "Wimp_GetIconState",,c%
 xmin%=xorig%+c%!8:ymin%=yorig%+c%!12:xmax%=xorig%+c%!16:ymax%=yorig%+c%!20
 c%!4=5:REM drag type
 c%!8=xmin%:REM coordinates of drag box
 c%!12=ymin%
 c%!16=xmax%
 c%!20=ymax%
 c%!24=0:REM screen min x
 c%!28=0:REM screen min y
 c%!32=4096:REM screen max x
 c%!36=3072:REM screen max y
 SYS "Wimp_DragBox",,c%
 PROCunstack(c%)
 ENDPROC
 :
 DEFPROCdragend
 SYS "Wimp_GetPointerInfo",,b%
 b%!20=b%!12:REM destination window handle
 b%!24=b%!16:REM destination icon handle
 b%!28=b%!0:REM destination x coordinate
 b%!32=b%!4:REM destination y coordinate
 b%!36=FNend+4-list%:REM length of data
 a$=$savestr%:REM get leafname
 WHILE INSTR(a$,".")<>0
   n%=INSTR(a$,".")
   a$=MID$(a$,n%+1)
 ENDWHILE
 $(b%+44)=a$:REM leafname of file
 !b%=44+((LENa$+1) DIV 4)*4:REM length of block
 IF ((LENa$+1) MOD 4)<>0 !b%+=4
 b%!12=0:REM your_ref for original message
 b%!16=1:REM Message_DataSave
 SYS "Wimp_SendMessage",18,b%,b%!20
 ENDPROC
 :
 DEFPROCsave
 PROCterm(b%+44)
 $savestr%=$(b%+44)
 PROCsave2
 b%!12=b%!8
 b%!16=3:REM Message_DataLoad
 SYS "Wimp_SendMessage",18,b%,b%!20
 ENDPROC
 :
 DEFPROCsave2
 n%=FNend2+4
 SYS "XOS_CLI","SAVE "+$savestr%+" "+STR$~list%+" "+STR$~n% TO err%;flags%
 IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
 SYS "XOS_CLI","SETTYPE "+$savestr%+" 012" TO err%;flags%
 IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
 SYS "Wimp_CreateMenu",,-1
 ENDPROC
 :
 DEFPROCchecksave
 IF INSTR($savestr%,"::")<>0 AND INSTR($savestr%,"$.")<>0 THEN
   PROCsave2
 ELSE
   SYS "Wimp_CreateMenu",,-1
   ERROR 1<<30,"To save, drag the icon to a directory display"
 ENDIF
 ENDPROC
 :
 DEFPROCkeypress
 REM processes keypresses in response to Wimp_Poll reason code 8
 IF b%!24=13 THEN
   !b%=saveas%
   SYS "Wimp_GetWindowState",,b%
   IF (b%!32 AND 1<<16)<>0 THEN PROCchecksave
 ELSE
   SYS "Wimp_ProcessKey",b%!24
 ENDIF
 ENDPROC
 :
 DEFPROCtext(x%,y%,col%,RETURN coords%)
 fh%=coords%!4:coords%+=8
 SYS "Wimp_SetFontColours",,1,col%
 SYS "Font_SetFont",fh%
 SYS "Font_Paint",,coords%,%10000,x%,y%
 WHILE ?coords%>=32:coords%+=1:ENDWHILE
 coords%+=1:WHILE (coords% MOD 4)<>0:coords%+=1:ENDWHILE
 coords%+=4
 ENDPROC
 :
 DEFPROCadd_text(RETURN coords%)
 LOCAL n%,pt%,fonth%
 PROCterm(textbuf%)
 IF coords%+LEN$textbuf%>list%+984:VDU 7:coords%-=4:ENDPROC
 pt%=VAL$ptsize%*16:IF pt%=0 pt%=14*16
 SYS "Font_FindFont",,fontname%,pt%,pt% TO fonth%
 PROCadd_font(fonth%,pt%)
 coords%!4=fonth%
 $(coords%+8)=$textbuf%
 n%=LEN$textbuf%+8
 coords%?n%=0
 n%+=1
 WHILE n% MOD 4<>0:n%+=1:ENDWHILE
 coords%!n%=n%
 coords%+=n%
 ENDPROC
 :
 DEFPROCfont_size_menu
 RESTORE+1
 DATA Font size,_W,ptsize%,12,*
 fmenu%=FNmake_menu
 ENDPROC
 :
 DEFPROCmenu_message
 CASE TRUE OF
   WHEN topmenu%=wmenu% AND b%!32=3 AND b%!36=-1:PROCfont_list(b%!24,b%!28)
 ENDCASE
 ENDPROC
 :
 DEFPROCfont_list(menx%,meny%)
 buf%=menspc%
 SYS "Font_ListFonts",,0,%101<<19,,0,,0 TO ,,,bsize1%,,bsize2%
 IF bsize1%>menend%-buf% ERROR 1<<30,"Not enough space to list all the fonts"
 IF bsize2%>wsend%-ws% ERROR 1<<30,"Insufficient indirected workspace to list all fonts"
 SYS "Font_ListFonts",,buf%,%101<<19,menend%-buf%,ws%,wsend%-ws%,fontname%
 PROCattach(wmenu%,3,buf%)
 SYS "Wimp_CreateSubMenu",,buf%,menx%,meny%
 ENDPROC
 :
 DEFPROCpick_font
 SYS "Wimp_DecodeMenu",,buf%,b%+4,fontname%
 SYS "Font_ListFonts",,buf%,%101<<19,menend%-buf%,ws%,wsend%-ws%,fontname%
 ENDPROC
 :
 DEFPROCadd_font(h%,p%)
 LOCAL n%,found%
 found%=FALSE
 n%=fontlist%
 WHILE !n%<>-1
   IF !n%=h% found%=TRUE
   n%+=8
   WHILE ?n%>=32:n%+=1:ENDWHILE
   n%+=1
   WHILE n% MOD 4<>0 n%+=1:ENDWHILE
 ENDWHILE
 IF NOT found% THEN
   !n%=h%:n%!4=p%:$(n%+8)=$fontname%
   n%+=8
   WHILE ?n%>=32:n%+=1:ENDWHILE
   n%+=1
   WHILE n% MOD 4<>0 n%+=1:ENDWHILE
   !n%=-1
 ENDIF
 ENDPROC
 :
 DEFFNend2
 LOCAL n%
 n%=fontlist%
 WHILE !n%<>-1
   n%+=4
 ENDWHILE
 =n%
 :
 DEFPROCupdate_fonts
 LOCAL n%
 n%=fontlist%
 WHILE !n%<>-1 AND n%<fontlist%+1024
   oldh%=!n%
   SYS "XFont_FindFont",,n%+8,n%!4,n%!4 TO newh%;flags%
   IF (flags% AND 1)<>0:err%=newh%:!err%=1<<30:PROCclear:SYS "OS_GenerateError",err%
   PROCupdate_plot_list(oldh%,newh%)
   !n%=newh%
   n%+=8
   WHILE ?n%>=32:n%+=1:ENDWHILE
   n%+=1
   WHILE n% MOD 4<>0:n%+=1:ENDWHILE
 ENDWHILE
 ENDPROC
 :
 DEFPROCupdate_plot_list(old%,new%)
 LOCAL n%
 n%=FNend
 WHILE n%>list%
   IF (!n% AND &FF000000)<>0 THEN
     n%-=4
   ELSE
     n%-=!n%
     IF n%!4=old% n%!4=new%
     IF n%>list% n%-=4
   ENDIF
 ENDWHILE
 ENDPROC
 :
 DEFPROClose_fonts
 LOCAL n%
 n%=FNend
 WHILE n%>list%
   IF (!n% AND &FF000000)<>0 THEN
     n%-=4
   ELSE
     n%-=!n%
     SYS "Font_LoseFont",n%!4
   IF n%>list% n%-=4
   ENDIF
 ENDWHILE
 !fontlist%=-1
 ENDPROC
 :