home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / HISOFT.LZH / HISOFT_B.MSA / EXAMPLES / FASTCONV.BAS < prev    next >
BASIC Source File  |  1985-11-20  |  11KB  |  611 lines
  1. ' The Fast to HiSoft compiler ╜ HiSoft 1987
  2. '
  3. ' SCS
  4. '
  5. ' 26 july    1.0
  6. '
  7.  
  8. rem $option u,v,z                'underlines ok, variable checks, Zzzz mode
  9. rem $option n-,a-,o-,p-            'max speed
  10.  
  11. library "gemaes","gemdos"        'these libraries are used
  12.  
  13. defint a-z
  14.  
  15. ' the table of the simple replacement keywords Fast BASIC,HiSoft BASIC
  16. '
  17.  
  18. data "ENDPROC","END SUB"
  19. data "ENDIF","END IF"
  20. data "REPEAT","DO"
  21. data "UNTIL","LOOP UNTIL"
  22. data "SWITCH","SELECT CASE"
  23. data "ENDSWITCH","END SELECT"
  24. data "HIDEMOUSE","MOUSE -1"
  25. data "SHOWMOUSE","MOUSE 0"
  26. data "DEFAULT","CASE ELSE"
  27.  
  28. data "BEGINUPDATE","Dummy%=FNwind_update%(1)"
  29. data "ENDUPDATE","Dummy%=FNwind_update%(0)"
  30. data "CREATEWIND","FNwind_create%"
  31. data "FINDOBJECT","FNobjc_find%"
  32. data "FINDWIND","FNwind_find%"
  33. data "FSELECT","fsel_input"
  34. data "GROWBOX","graf_growbox"
  35. data "MOVEBOX","graf_movebox"
  36. data "SHRINKBOX","graf_shrinkbox"
  37. data "SLIDEBOX","FNgraf_slidebox%"
  38. data "TRACKBOX","FNgraf_watchbox%"
  39. data "WAITMSG","evnt_mesag"
  40. data "WAITTIMER","evnt_timer"
  41.  
  42. data "DELDIR","RMDIR"
  43. data "DELFILE","KILL"
  44. data "DIR","FILES"
  45. data "FREE",FRE("")
  46. data "GETREC","GET"
  47. data "HOME","LOCATE 1,1"
  48. data "MAKEDIR","MKDIR"
  49. data "PUTREC","PUT"
  50. data "SETMOUSE","MOUSE"
  51. data "INKEY","ASC(INKEY$)"
  52. data "TIME24$(SYSTIME)","TIME$"
  53. data "DATEUS$(SYSDATE)","DATE$"
  54. data ""
  55.  
  56. if peekw(systab)=4 then
  57.     dummy=FNform_alert(1,"[3][This doesn't run in|low res][ Quit ]")
  58.     system
  59. end if
  60.  
  61. crlf$=chr$(13)+chr$(10)                'various values
  62. copyright$=chr$(189)
  63.  
  64.  
  65. dim srcsym$(100)                    'dimension the symbol tables
  66. dim trgsym$(100)
  67.  
  68. do                                    'build the symbol tables
  69.     read temp$
  70.     if temp$="" then exit loop
  71.     incr ctr
  72.     srcsym$(ctr)=temp$
  73.     read temp$
  74.     trgsym$(ctr)=temp$
  75. loop
  76.  
  77.  
  78. nkey=ctr                            'return what's not used
  79. redim append srcsym$(nkey)
  80. redim append trgsym$(nkey)
  81.  
  82. fil$=command$
  83.  
  84. m=peek(systab)                        'get resolution
  85. window open 2,"Fast BASIC to HiSoft BASIC converter "+copyright$+" HiSoft 1987",110,20\m,418,362\m,1
  86.  
  87. if len(fil$)=0 then                    'no filename was specified on the cmdlin
  88.     fil$=FNselect_file$
  89. end if
  90.  
  91. do until fexists(fil$)                'if file not found
  92.     but=FNform_alert(1,"[1][|  "+fil$+"  |  not found  ][  OK  ]")
  93.     fil$=FNselect_file$
  94. loop
  95.  
  96. mouse 2                                'busybee
  97.  
  98. open fil$ for input as #1 len=5120    'open source with some buffer space
  99.  
  100. filel&=lof(1)
  101.  
  102. filst$=input$(filel&,#1)            'read entire file
  103.  
  104. close #1
  105.  
  106. dott=instr(fil$,".")
  107. mid$(fil$,dott,4)=".BAS"            'create target's extension
  108.  
  109. open fil$ for output as #2 len=5120    'open target with some buffer space
  110.  
  111.  
  112. mouse 0                                'arrow
  113.  
  114. but=FNform_alert(1,"[2][| Do you want 16-bit or | 32-bit integers? ][  16  |  32  ]")
  115.  
  116. mouse -1                            'no rodent (takes up too much time)
  117.  
  118. if but=1 then
  119.     intflg=0
  120. else
  121.     intflg=1
  122. end if
  123.  
  124. check_corrupt                        'make sure all lines end with cr-lf
  125.  
  126. print #2,"' ";fil$;" converted from Fast BASIC to HiSoft BASIC"
  127. print #2,"LIBRARY ""GEMAES"""
  128.  
  129. locate 9,21
  130. print "line";
  131.  
  132. done=-1
  133.  
  134. fp&=1
  135.  
  136. nix&=fre("")
  137.  
  138. main:
  139.  
  140. do                                            'this is the main prog
  141.  
  142.     tokoffs=FNgetnxtok
  143.  
  144.     if done then
  145.  
  146.         if tokoffs=0 then
  147.             print #2,notaword$;
  148.         elseif tokoffs>0 then
  149.             print #2,trgsym$(tokoffs);
  150.         end if
  151.  
  152.         if hcfl then print #2,holdchr$;
  153.  
  154.     end if
  155.  
  156.     done=-1
  157.     hcfl=0
  158.  
  159. loop
  160.  
  161.  
  162. terminator:
  163. close #2
  164. mouse 0                                        'mouse is back
  165. john=FNform_alert(1,"[1][|     All done!| |"+str$(lino)+" lines processed  ][  OK  ]")
  166. stop -1                                        'exit
  167.  
  168.  
  169. sub getnxlin                                'get a line of Fast BASIC
  170. shared parslin$,ll,lp,fp&,crlf$,filel&,filst$,lino
  171. static cr&
  172.  
  173.     if fp& >= filel& then goto terminator    '(slap on wrist)
  174.     cr&=instr(fp&,filst$,crlf$)
  175.     parslin$=mid$(filst$,fp&,cr&-fp&)
  176.     fp&=cr&+2
  177.     incr lino
  178.     if (lino and 7)=0 then                    'don't always print (eats time)
  179.         locate 9,25
  180.         print lino;
  181.     end if
  182.     ll=len(parslin$)
  183.  
  184.     lp=0
  185.  
  186. end sub
  187.  
  188.  
  189. DEF FNgetnxchr$                                'get a character from the line
  190. shared parslin$,word$,ll,lp,funcflag,nxchr$,wf,intflg,wl,hcfl,holdchr$
  191. static quotct,nxchr,temp,chrfl,achr$
  192.  
  193. getachr:
  194.  
  195.     incr lp
  196.  
  197.     if lp > ll then exit def                'NOT EQUAL!
  198.  
  199.     chrfl=1
  200.     hcfl=0
  201.  
  202.     nxchr=asc(mid$(parslin$,lp,1))        'get the next character as integer
  203.  
  204.     if nxchr=""""% then incr quotct            'smart quoted strings
  205.  
  206.     select case nxchr                        'integer comparisons are quicker
  207.  
  208.         case " "%
  209.             if wl<>0 then wf=1                'new word
  210.             hcfl=-1
  211.             holdchr$=chr$(nxchr)
  212.  
  213.         case 9                                'tab
  214.             print #2,chr$(9);
  215.             chrfl=0
  216.  
  217.     end select
  218.  
  219.     if (quotct and 1)=1 then goto after_select
  220.  
  221.     select case nxchr
  222.  
  223.         case "%"%
  224.             if intflg=1 then
  225.                 nxchr="&"%
  226.             else
  227.                 nxchr="%"%
  228.             end if
  229.  
  230.         case "\"%
  231.             nxchr="'"%
  232.  
  233.         case "("%
  234.             wf=1
  235.             hcfl=-1
  236.             holdchr$=chr$(nxchr)
  237.  
  238.         case "="%
  239.             if funcflag=0 then
  240.                 if wl<>0 then
  241.                     wf=1
  242.                     hcfl=-1
  243.                     holdchr$=chr$(nxchr)
  244.                     exit select
  245.                 end if
  246.             end if
  247.  
  248.             if funcflag=1 then                    'it's the end of a DEF FN
  249.                 if wl=0 then
  250.                     exit select
  251.                     call spcase_endef
  252.                     chrfl=0
  253.                     exit def                    'the routine did everything
  254.                 end if
  255.             end if
  256.  
  257.         case "@"%
  258.             call spcase_at
  259.             exit def
  260.  
  261.         case "$"%
  262.             if wl=0 then
  263.                 print #2,"&H";
  264.                 chrfl=0
  265.             end if
  266.  
  267.         case "&"%
  268.             nxchr="%"%
  269.  
  270.         case ":"%
  271.             if wl<>0 then
  272.                 wf=1
  273.                 hcfl=-1
  274.                 holdchr$=chr$(nxchr)
  275.             end if
  276.  
  277.         case "|"%
  278.             nxchr="%"%
  279.         
  280.     end select
  281.  
  282. after_select:
  283.  
  284. if chrfl=0 then goto getachr
  285.  
  286. Fngetnxchr$=chr$(nxchr)
  287.  
  288. end def
  289.  
  290.  
  291. DEF FNgetnxwrd$                                    'get a word
  292. shared parslin$,lp,ll,wl,wf,xwf,xword$
  293. static word$,nxchr$,temp$
  294.  
  295.     word$=""
  296.     wl=0
  297.     wf=0
  298.  
  299.     do
  300.         nxchr$=FNgetnxchr$
  301.  
  302.         if xwf then
  303.             word$=word$+xword$
  304.             xwf=0
  305.         end if
  306.  
  307.         if wf<>1 then
  308.  
  309.             word$=word$+nxchr$
  310.  
  311.             incr wl
  312.  
  313.             if wl=1 then                        
  314.             temp$=mid$(parslin$,lp,4)
  315.                 if temp$="PROC" then
  316.                     call spcase_proc
  317.                     exit def
  318.                 end if
  319.             end if
  320.             if lp >= ll then exit loop
  321.  
  322.         end if
  323.  
  324.     loop until wf=1
  325.  
  326.     if word$="DEF" then
  327.         call spcase_defs
  328.         exit def
  329.     end if
  330.  
  331.     FNgetnxwrd$=word$
  332.  
  333. end def
  334.  
  335.  
  336. DEF FNgetnxtok%                                    'see if it's a token
  337. shared crlf$,lp,ll,srcsym$(),notaword$,done,nkey
  338. static srch,word$,offs
  339.  
  340.     if lp >= ll then
  341.         print #2,crlf$;
  342.         call getnxlin
  343.     end if
  344.  
  345.     word$=FNgetnxwrd$
  346.  
  347.     if not done then exit sub
  348.     
  349.     for srch=1 to nkey                            'hunt through symbol table
  350.         if word$=srcsym$(srch) then            'the most used line in the prog
  351.             FNgetnxtok=srch
  352.             exit def
  353.         end if
  354.     next srch
  355.  
  356.     FNgetnxtok=0
  357.  
  358.     notaword$=word$
  359.     
  360. end def
  361.  
  362. ' all the special cases follow
  363.  
  364. sub spcase_defs
  365. shared parslin$,ll,lp,wl,funcflag,done,funcname$
  366. static temp$,nxchr$,rest$,name$,paren$,achr$
  367.  
  368.     temp$=mid$(parslin$,lp+1,2)
  369.  
  370.     if temp$="FN" then
  371.         print #2,"DEF ";
  372.  
  373.         funcflag=1
  374.         funcname$=""
  375.         rest$=""
  376.         
  377.         do
  378.             nxchr$=FNgetnxchr$
  379.  
  380.             if nxchr$="(" then                    'the VAR business
  381.                 paren$="("
  382.  
  383.                 do
  384.                     nxchr$=FNgetnxchr$
  385.  
  386.                     achr$=mid$(parslin$,lp-1,1)
  387.                     if achr$="," or achr$="(" then
  388.                         if mid$(parslin$,lp,3)="VAR" then
  389.                             nxchr$=""
  390.                             lp=lp+3
  391.                         else
  392.                             paren$=paren$+"VAL "
  393.                         end if
  394.                     end if
  395.                     paren$=paren$+nxchr$
  396.  
  397.                 loop until nxchr$=")"
  398.                 goto 42
  399.  
  400.             end if
  401.  
  402.             funcname$=funcname$+nxchr$
  403.             if lp > ll then exit loop
  404.         loop
  405.  
  406. 42        print #2,funcname$+paren$;
  407.         done=0
  408.  
  409.     else
  410.  
  411.         name$=""
  412.         lp=lp+4                                    'skip over DEF
  413.  
  414.         do
  415.             nxchr$=FNgetnxchr$
  416.  
  417.             if nxchr$="(" then                    'the VAR business
  418.                 paren$="("
  419.  
  420.                 do
  421.                     nxchr$=FNgetnxchr$
  422.  
  423.                     achr$=mid$(parslin$,lp-1,1)
  424.                     if achr$="," or achr$="(" then
  425.                         if mid$(parslin$,lp,3)="VAR" then
  426.                             nxchr$=""
  427.                             lp=lp+3
  428.                         else
  429.                             paren$=paren$+"VAL "
  430.                         end if
  431.                     end if
  432.                     paren$=paren$+nxchr$
  433.  
  434.                 loop until nxchr$=")"
  435.                 goto 43
  436.  
  437.             end if
  438.  
  439.             name$=name$+nxchr$
  440.             if name$="PROC" then name$=""
  441.             if lp > ll then exit loop
  442.         loop
  443.  
  444. 43        print #2,"SUB "+name$+paren$;
  445.         done=0
  446.     end if
  447.  
  448. end sub
  449.  
  450.  
  451. sub spcase_endef
  452. shared funcname$,ll,lp,parslin$,done,funcflag
  453. static name$,nxchr$
  454.  
  455.     print #2,funcname$;
  456.     name$=""
  457.     do
  458.         nxchr$=FNgetnxchr$
  459.         if nxchr$=" " then
  460.             exit loop
  461.         elseif lp > ll then
  462.             exit loop
  463.         end if
  464.         name$=name$+nxchr$
  465.     loop
  466.     print #2,"="+name$
  467.     print #2,"END DEF";
  468.     funcflag=0
  469.     done=0
  470.  
  471. end sub
  472.  
  473.  
  474. sub spcase_at
  475. shared done,lp,ll,xwf,xword$
  476. static nxchr$,name$
  477.  
  478.     xwf=0
  479.     name$=""
  480.  
  481.     do
  482.         nxchr$=FNgetnxchr$
  483.     
  484.         select case nxchr$
  485.  
  486.             case "$"
  487.                 name$=name$+"$"
  488. dolloop:        nxchr$=FNgetnxchr$
  489.                 if nxchr$=")" or nxchr$=" " or nxchr$="," or lp > ll
  490.                     name$="SADD("+name$+")"+nxchr$
  491.                     xword$=name$
  492.                     xwf=-1
  493.                     exit sub
  494.                 else
  495.                     name$=name$+nxchr$
  496.                     goto dolloop
  497.                 end if
  498.  
  499.             case " "
  500.                 name$="VARPTR("+name$+") "
  501.                 xword$=name$
  502.                 xwf=-1
  503.                 exit sub
  504.             
  505.             case ")"
  506.                 name$="VARPTR("+name$+"))"
  507.                 xword$=name$
  508.                 xwf=-1
  509.                 exit sub
  510.  
  511.             case ","
  512.                 name$="VARPTR("+name$+"),"
  513.                 xword$=name$
  514.                 xwf=-1
  515.                 exit sub
  516.  
  517.         end select
  518.         name$=name$+nxchr$
  519.  
  520.         if lp > ll
  521.             name$="VARPTR("+name$+")"
  522.             xword$=name$
  523.             xwf=-1
  524.             exit sub
  525.         end if
  526.  
  527.     loop
  528.  
  529. end sub
  530.  
  531.  
  532. sub spcase_proc
  533. shared parslin$,lp,ll,done
  534. static name$,word$,nxchr$
  535.  
  536.     name$=""
  537.  
  538.     lp=lp+3                            'not 4 because getnxchr pre-increments
  539.  
  540.     do
  541.         nxchr$=FNgetnxchr$
  542.         if nxchr$=" " then
  543.             exit loop
  544.         elseif lp > ll then                        'NOT EQUAL!
  545.             exit loop
  546.         end if
  547.         name$=name$+nxchr$
  548.     loop
  549.  
  550.     print #2,"CALL "+name$;
  551.  
  552.     if nxchr$=" " then print #2," ";
  553.  
  554.     done=0
  555.  
  556. end sub
  557.  
  558.  
  559. sub check_corrupt                        'occasionally Fast BASIC produces
  560. shared filst$,filel&,holdst$,crlf$        'bad ASCII files
  561. static nix&,hold&,where&
  562.  
  563.     locate 9,19
  564.     print "having a think..."
  565.  
  566.     hold&=1
  567.  
  568.     do
  569.         where&=instr(hold&,filst$,chr$(10))                    'check for lf
  570.         if where&=0 then exit loop
  571.         hold&=where&+1
  572.  
  573.         if mid$(filst$,where&-1,1)<>chr$(13) then            'without cr
  574.             holdst$=left$(filst$,where&-1)
  575.             holdst$=holdst$+crlf$
  576.             filst$=holdst$+right$(filst$,filel&-where&)
  577.             holdst$=""
  578.             filel&=len(filst$)
  579.             nix&=fre("")
  580.         end if
  581.  
  582.     loop
  583.  
  584.     cls                                            'lazy
  585.  
  586. end sub
  587.  
  588.  
  589. DEF FNselect_file$
  590. static path$,name$,but,drv$,where
  591.  
  592.     path$=space$(64)                            'set up buffer
  593.     drv$=chr$(FNdgetdrv+"A"%)                    'get current drive
  594.     dgetpath sadd(path$),0                        'get current path
  595.     if left$(path$,1)=chr$(0) then                'add *.ASC
  596.         path$=drv$+":\*.ASC"
  597.     else
  598.         path$=drv$+":"+path$
  599.         where=instr(path$,chr$(0))
  600.         path$=left$(path$,where-1)
  601.         path$=path$+"\*.ASC"
  602.     end if
  603.     fsel_input path$,name$,but                    'the file selector appears!
  604.     cls                                            'naughty naughty
  605.     if but=0 then stop -1                        'cancel button
  606.     where=instr(path$,"*")                        'build the file name
  607.     path$=left$(path$,where-1)
  608.     FNselect_file$=path$+name$
  609.  
  610. end def
  611.