OpenVMS Source Code Demos
SOURCE_CODE_FORMATTER
1000 %title "source_code_formatter_xxx.bas"
option type=explicit
%ident "version_107.3"
declare string constant k_version = "107.3"
declare string constant k_program = "OpenVMS-BASIC-Source-Code-Formatter" ! don't remove punctuation
!========================================================================================================================
! Title : source_code_formatter_xxx.bas
! Author : Neil Rieck (https://neilrieck.net/)
! Notes : this program was a really quick hack and is in need of a major rewrite (do it ASAP)
! : this program has no commercial value and has been put into public domain for educational use only
! history:
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 100 NSR 021223 1. original program (written during Christmas slow down to help fix VDSL program logic)
! NSR 030129 2. now allow partial directories
! 3. now properly indent DECLARE and MAP statements
! 4. now detect line numbers
! NSR 030130 5. added support for module declarations (SUB + FUNCTION)
! 6. now properly indents data following CASE
! 7. added a comment adjust feature
! NSR 030812 8. added support for keywords FLOAT, WORD, QUAD, and ANY
! 101 NSR 030813 1. added code to dump the statement stack upon error
! 2. now optionally allow padding with only spaces
! NSR 030918 3. now only display help when required
! 4. now default to debug=Y
! 5. now dump stack on program exit (if debug=Y)
! 102 NSR 040210 1. now allow code indentation by values other than 4
! 2. fixed a bug where "FOR OUTPUT" on an OPEN continuation line appeared to be the
! start of a FOR/NEXT statement
! 3. added support for line continuation in an OPEN statement
! 4. added support for line continuation in a CALL statement
! 103 NSR 040715 1. started adding support for mode_amper% (better handling of amper blocks)
! 2. placed a special hook for amper lines after an "IF" (compound argument list) bf_103.2
! NSR 040809 3. changed the indentation notes intro and prompt
! 104 NSR 040809 1. started adding code to collapse fdv$getdl statements bf_104.1
! NSR 040810 2. fixed a bug (introduced during bf_103.2) which was preventing proper indentation of
! functions found within IF blocks
! 105 NSR 041119 1. cosmetic changes
! 2. added a destination line counter
! NSR 050113 3. added support for the DATA statement
! NSR 050129 4. fixed a bug so this program may be run from any directory bf_105.4
! NSR 050414 5. no can also collapse fdv$get statements
! NSR 051114 6. added support for the RECORD statement
! 106 NSR 101109 1. bug fixes bf_106.1
! 107 NSR 130207 1. added support for VARIANT and END VARIANT
! 2. added support for RECORD and END RECORD
! 3. added support for GROUP and END GROUP
!========================================================================================================================
set no prompt ! no kid stuff
!
%include "lib$routines" %from %library "sys$library:basic$starlet" ! for lib$spawn
!
declare string constant htab = '9'C ! horizontal TAB
declare string fs1$ , ! file spec1 &
fs2$ , ! file spec2 &
nlws$ , ! no leading white space &
basic_line$ , ! BASIC line number &
nlws_uc_tmp$ , ! no leading white space UPPER CASE &
comment_option$ , ! Y/N &
debug_option$ , ! Y/N &
padding_option$ , ! T/S &
stmt_collapse_option$ , ! Y/N &
junk$ , ! &
junk1$ , ! &
junk2$ , ! &
junk3$ , ! &
save_ip$ , ! &
cmd$ , ! DCL command &
choice$ , !&
ip$ , !&
op$ , !&
indent$ , !&
long i% , !&
j% , !&
junk% , !&
temp% , !&
move_pos% , !&
hdlr% , !&
declaration_mode% , !&
print_mode% , !&
open_mode% , !&
quoted_mode% , !&
rc% , !&
count% , !&
source_line% , !&
dest_line% , !&
choice% , !&
code_pos% , !&
ptr_s% , !&
curr_amper% , !&
prev_amper% , !&
mode_amper% , !&
indent% !
!
!====================================================================================================
! <<< main >>>
!====================================================================================================
junk$ = k_program + " ver: " + k_version
print string$( len(junk$), ascii("=") ) ! print a line
print junk$ ! print program title
print string$( len(junk$), ascii("=") ) ! print a line
!
input "show help now? (default=N) "; junk$
junk$ = edit$(junk$,32+4+2) ! upcase, no controls, no white space
if left$(junk$,1)="Y" then
! 12345678901234567890123456789012345678901234567890123456789012345678901234567890
print "tips:"
print " 1. the BASIC source file must be complete and compilable"
print " 2. FOR/NEXT statements can't be on the same line"
print " 3. WHILE/NEXT statements can't be on the same line"
print " 4. compiler directives (like %if %then) are ignored formatting-wise so BASIC"
print " blocks between compiler directives must be complete"
print " 5. all END IF statements must be present:"
print " 5a. the compiler allows a line number to terminate an IF"
print " 5b. the compiler will assume an END IF between two ELSE statements"
print " 6. all programs should have an END or END PROGRAM (doesn't need to be on"
print " the last line; external trailing functions are allowed etc.)"
print
end if
print "file directory build:"
input "enter first letter(s) of BASIC source file? (default=all) ";junk$
print
junk$ = edit$(junk$,32+4+2) ! upcase, no controls, no white space
if junk$ = "" then
junk$ = "*"
else
if pos(junk$,"*",1)=0 then ! if no asterisk was provided...
junk$ = junk$ +"*" ! ...then add one
end if
end if
%let %dirmode=1% !
%if %dirmode=0% %then ! mode 0: only find files with .BAS extensions
cmd$ = "$dir/nohead/notrail "+ junk$ +".BAS;/out="+k_program+".scratch" ! get a directory of BASIC files
%else ! mode 1: find many types of files
!
! Note: It seems that many programmers use other file extensions (like .STB, .STUB, .FUN, .SUB, .INC, etc.) and want
! to see more file types than just .BAS so this fragment will do just that
!
cmd$ = "$dir/nohead/notrail "+ junk$ +".*;" + ! get a directory of most files &
"/out="+k_program+".scratch" + ! &
"/exc=(*.exe,*.obj,*.formatted)" ! we don't want to see these
%end %if
rc% = lib$spawn(cmd$) ! let DCL execute this command
if ((rc% and 7%) <> 1%) then
print "-e- lib$spawn error: "+ str$(rc%)
goto sortie ! ***--->>>
end if
!
! now read the directory listing file
!
print "======================================================================"
print " Question 1/6"
print "======================================================================"
when error in
open k_program+".scratch" for input as #1
count% = 0
print "Directory:"
print "#### File name______________________________"
while 1 !
linput #1, junk$ ! display the listed file names
count% = count% + 1 !
print format$(count%,"#### ")+junk$ !
next !
use !
end when !
if count% = 0 then !
!~~~ print "-e- this directory didn't contain any files with a .BAS extension"
print "-e- no files were detected using your search criteria"
goto sortie ! ***--->>>
end if
!
! now let the user choose a file number
!
choice_loop:
print "Format which BASIC file? (1-"+ str$(count%) +", 0=none) ";
input choice$ ! get his choice (number)
when error in
choice% = integer(choice$)
use
choice% = -1
end when
select choice%
case 0
goto sortie ! ***--->>>
case -1, > count%
print "-e- bad input"
goto choice_loop
end select
!
! now discover the filename of the number entered
!
when error in ! get his choice (file name)
reset #1
count% = 0
while 1 !
linput #1, fs1$ !
count% = count% + 1 !
goto found_it if count% = choice% !
next !
use !
print "-e- error: "+ str$(err)+ " finding file" !
end when !
goto sortie ! ***--->>>
!
! now get a few options before processing this file
!
found_it:
print
print "======================================================================"
print " Question 2/6"
print "======================================================================"
print "move comments out to column 81? (Y/N, default=N) "; !
input comment_option$
comment_option$ = edit$(comment_option$, 32+2)
select comment_option$
case "Y","N"
case else
comment_option$ = "N"
end select
if comment_option$ = "Y" then
print "-w- comments will be moved (this is not always perfect so test with $DIF)"
else
print "-i- comments will NOT be moved"
end if
!
print
print "======================================================================"
print " Question 3/6"
print "======================================================================"
print "Indentation Notes:"
print " a. Line numbers stay in column 1"
print " b. Remarked lines are not changed"
print " c. All other lines will start in column 9"
print " d. The next prompt will affect indentation after column 9"
print " e. Large inline programs may require smaller values (like 1 or 2)"
print "code line indentation value? (1-8, default=4) ";
input junk$
junk$ = edit$(junk$, 32+4+2)
when error in !
indent% = integer(junk$) !
use !
indent% = 4 ! default to 4
end when !
!
select indent% !
case 1 to 8 !
case else !
indent% = 4 !
end select !
print "-i- Indent value: "+ str$(indent%) !
!
print
print "======================================================================"
print " Question 4/6"
print "======================================================================"
print "Special Collapse Option:"
print " a. convert code like this:"
print " call fdv$getdl( junk$, &"
print " junk%, &"
print " 23%, &"
print ' "whatever?" )'
print " into code like this:"
print ' call fdv$getdl( junk$,junk$,23%,"whatever?" )'
print ' b. this will only work with "fdv$getdl" and "fdv$get" statements'
print ' c. this will only work when curent indent position <= 80'
print ' d. you will get a warning saying the input lines <> output lines'
print "Choice? (Y/N, default=N) ";
input stmt_collapse_option$
stmt_collapse_option$ = edit$(stmt_collapse_option$, 32+2)
select stmt_collapse_option$
case "Y","N"
case else
stmt_collapse_option$ = "N"
end select
!
print
print "======================================================================"
print " Question 5/6"
print "======================================================================"
print "Debug statements help to identify unusual conditions in your code"
print "send possible debug statements to screen? (Y/N, default=Y) ";
input debug_option$
debug_option$ = edit$(debug_option$, 32+2)
select debug_option$
case "Y","N"
case else
debug_option$ = "Y" ! take care of default
end select
if debug_option$ = "Y" then
print "-i- debug lines MAY be written to screen"
else
print "-i- debug lines will NOT be written"
end if
!
print
print "======================================================================"
print " Question 6/6"
print "======================================================================"
print "indent with 'Tabs and spaces' or only 'Spaces'? (T/S, default=T) ";
input padding_option$
padding_option$ = edit$(padding_option$, 32+2)
select padding_option$
case "T","S"
case else
padding_option$ = "T"
end select
if padding_option$ = "T" then
print "-i- padding will be with Tabs and spaces"
else
print "-i- padding will be done with spaces only"
end if
print ! end of prompts
!========================================================================================================================
! now process the selected file
!========================================================================================================================
main:
ptr_s% = 1024 ! prep for run-time allocation
dim string statem$(ptr_s%) ! init statement stack
dim long linenum(ptr_s%) ! init source line number stack
ptr_s% = 0 ! now init to starting value
close #1 !
%if %dirmode=0% %then !
junk% = pos(fs1$,".BAS",1) !
fs2$ = left$(fs1$, junk%-1) +".formatted" !
%else !
junk% = pos(fs1$,".",1) ! find a dot (if any)
if junk% > 0 then ! if a dot was found...
!
! make sure we can support fs of the form:
!
! CSMIS$USER3:[ADMCSM.NEIL]program_100.bas
!
find_next_dot: ! bf_105.4
temp% = pos(fs1$,".",junk%+1) ! any more dots?
if temp% > 0 then ! if yes...
junk% = temp% !
goto find_next_dot !
end if !
fs2$ = left$(fs1$, junk%-1) +".formatted" !
else !
fs2$ = fs1$ +".formatted" !
end if !
%end %if !
print "======================================================================"
print " starting job"
print "======================================================================"
when error in !
print "-i- open input : ";fs1$ !
open fs1$ for input as #1 ! open the source file &
,recordsize 1024 !
!
print "-i- open output: ";fs2$ !
open fs2$ for output as #2 ! &
,recordsize 1024 !
!
source_line% = 0 ! init
dest_line% = 0 ! init
code_pos% = 8 ! init
gosub build_indent_from_code_pos ! init
while 1 !
linput #1, ip$ ! read input
source_line% = source_line% + 1 !
gosub process_a_line ! ***--->>>
print #2, op$ ! write output
dest_line% = dest_line% + 1 !
next !
use !
select err !
case 11 !
print "-i- status: "+ str$(err) ! bf_106.1
print "-i- Last line detected" !
case else !
print "-e- status: "+ str$(err) ! bf_106.1
print "-i- ptr_s% "+ str$(ptr_s%) !
print "-i- Error exit" !
end select !
end when !
print "----------------------------------------------------------------------"
print str$(source_line%)+" lines were read" !
print str$(dest_line%)+" lines were written" !
if source_line% <> dest_line% then !
print "*** Danger: lines read <> lines written ***"+ bel !
end if !
gosub dump_stack ! just incase there wasn't an END
print "warning: make sure you compile BOTH files then use $DIF to compare their"
print " respective object files to ensure there were no conversion errors"
print " or dropped information. Always protect your source code."
if comment_option$ = "Y" then
print "note: You elected to move some comments out to column 81."
print " This is not always perfect so compare sources with $DIF"
print " and be sure to use switches /ignore=(space,trail,case)"
end if
print
goto sortie ! ***--->>>
!
!=======================================================================
! process a line
!=======================================================================
declare long first_spc% ,&
first_tab%
!
process_a_line: !
ip$ = edit$(ip$, 128) ! no trailing white space
save_ip$ = ip$ ! copy data for possible fall thru (see CASE ELSE)
gosub build_indent_from_code_pos !
op$ = "9>"+ ip$ ! set a default (output equals input)
!
! don't let the presence of a BASIC line number corrupt the formatting of indents
!
select left$(ip$,1) ! test 1st char of input line
case "0" to "9" ! line number?
junk% = 0 !
first_spc% = pos(ip$," ",1) ! look for 1st space (if any)
first_tab% = pos(ip$,htab,1) ! look for 1st tab (if any)
junk% = first_spc% if first_spc%>0 and first_tab%=0
junk% = first_tab% if first_spc%=0 and first_tab%>0
junk% = min(first_spc%,first_tab%) if first_spc%>0 and first_tab%>0
if junk% > 0 then ! if a delimiter was found...
basic_line$ = left$( ip$ ,junk%-1) ! then capture line number
ip$ = right$(ip$ ,junk% ) ! remove line number for data line
else !
basic_line$ = "" !
end if !
case else !
basic_line$ = "" !
end select !
!
!
!
select left$(ip$,1) ! test 1st char of input line
case sp, chr$(9) ! if first character is a <space> or <tab>
goto do_frst_char_is_white !
case else ! non-whitespace character in column #1
junk$ = edit$(ip$, 2) ! no white space
if right$( junk$, len(junk$ )-1) = "&" and ! if a continuation line &
left$(junk$,1) <> "!" ! but not a remark line &
then !
curr_amper% = 1 !
if prev_amper% = 0 then !
mode_amper% = 1 ! starting a block
else !
mode_amper% = 2 ! in a block
end if !
else !
curr_amper% = 0 !
if prev_amper% = 0 then !
mode_amper% = 0 ! starting a block
else !
mode_amper% = 3 ! ending a block
end if !
end if !
op$ = save_ip$ ! no changes so "input line" -> "output line"
declaration_mode% = 0 !
open_mode% = 0 !
goto do_output !
end select !
!========================================================================================================================
! first character is white (definately not a line number)
!========================================================================================================================
do_frst_char_is_white:
nlws$ = edit$(ip$, 8) ! no leading white space
nlws_uc_tmp$ = edit$(ip$, 32+16+128+8) ! UC, compress, no trail, no lead (for tests only)
nlws_uc_tmp$ = nlws_uc_tmp$ +" " ! append a space so we can test for 'SELECT '
!
if right$( nlws_uc_tmp$, len(nlws_uc_tmp$)-1) = "& " and ! if this line ends in an ampersand &
left$( nlws_uc_tmp$,1) <> "!" ! and isn't a remark
then
curr_amper% = 1 !
if prev_amper% = 0 then !
mode_amper% = 1 ! starting a block
else !
mode_amper% = 2 ! in a block
end if !
else !
curr_amper% = 0 !
if prev_amper% = 0 then !
mode_amper% = 0 ! starting a block
else !
mode_amper% = 3 ! ending a block
end if !
end if !
!
select left$(nlws$,1) !
case "%" ! if a compiler lexical...
hdlr% = 0 ! init
hdlr% = 1 if pos(nlws_uc_tmp$,"%IF " ,1)=1 !
hdlr% = 1 if pos(nlws_uc_tmp$,"%LET " ,1)=1 !
hdlr% = 1 if pos(nlws_uc_tmp$,"%THEN " ,1)=1 !
hdlr% = 1 if pos(nlws_uc_tmp$,"%ELSE " ,1)=1 !
hdlr% = 1 if pos(nlws_uc_tmp$,"%END " ,1)=1 !
if hdlr% = 1% then ! if this is a compiler directive...
op$ = " "+ nlws$ ! lead with 4 spaces
else ! else %INCLUDE, %TITLE, %SBTTL, etc.
op$ = indent$ + nlws$ ! so use current value of indent
end if !
case else ! else must be basic code...
hdlr% = 0 ! init
!
hdlr% = 2 if pos(nlws_uc_tmp$,"THEN " ,1)=1 ! indent off-on
hdlr% = 1 if pos(nlws_uc_tmp$,"IF " ,1)=1 ! indent on (beware of IF xxx THEN)
hdlr% = 3 if pos(nlws_uc_tmp$,"ELSE " ,1)=1 ! indent off-on
hdlr% = 4 if pos(nlws_uc_tmp$,"END IF " ,1)=1 ! indent off
hdlr% = 5 if pos(nlws_uc_tmp$,"SELECT " ,1)=1 ! indent on
hdlr% = 6 if pos(nlws_uc_tmp$,"CASE " ,1)=1 ! indent on
hdlr% = 16 if pos(nlws_uc_tmp$,"CASE ELSE " ,1)=1 ! indent on
hdlr% = 7 if pos(nlws_uc_tmp$,"END SELECT " ,1)=1 ! indent off
hdlr% = 8 if pos(nlws_uc_tmp$,"WHEN " ,1)=1 ! indent on
hdlr% = 9 if pos(nlws_uc_tmp$,"USE " ,1)=1 ! indent off-on
hdlr% = 10 if pos(nlws_uc_tmp$,"END WHEN " ,1)=1 ! indent off
hdlr% = 11 if pos(nlws_uc_tmp$,"WHILE " ,1)=1 ! indent on
hdlr% = 12 if pos(nlws_uc_tmp$,"NEXT " ,1)=1 ! indent off
hdlr% = 13 if pos(nlws_uc_tmp$,"FOR " ,1)=1 ! indent on (beware FOR INPUT on continued)
hdlr% = 17 if pos(nlws_uc_tmp$,"VARIANT " ,1)=1 ! indent on (similar to SELECT)
hdlr% = 18 if pos(nlws_uc_tmp$,"END VARIANT " ,1)=1 ! indent off (similar to END SELECT)
hdlr% = 19 if pos(nlws_uc_tmp$,"RECORD " ,1)=1 ! indent on (similar to SELECT)
hdlr% = 20 if pos(nlws_uc_tmp$,"END RECORD " ,1)=1 ! indent off (similar to END SELECT)
hdlr% = 21 if pos(nlws_uc_tmp$,"GROUP " ,1)=1 ! indent on (similar to GROUP)
hdlr% = 22 if pos(nlws_uc_tmp$,"END GROUP " ,1)=1 ! indent off (similar to END GROUP)
!
! the next 2 lines handle the following weird statement(s):
!
! open "big-long-file-spec.ext" &
! for input as #1 & <-- this line fragment probabky triggered my "FOR " logic
! ,access read &
! ,allow modify
!
hdlr% = 900 if pos(nlws_uc_tmp$,"FOR INPUT" ,1)=1 !
hdlr% = 900 if pos(nlws_uc_tmp$,"FOR OUTPUT" ,1)=1 !
!~~~ hdlr% = 14 if pos(nlws_uc_tmp$,"NEXT " ,1)=1 x indent off (this must be after plain NEXT test)
hdlr% = 98 if pos(nlws_uc_tmp$,"OPEN " ,1)=1 ! indent on (conditional)
!
! the next line handles the following weird statement (which looks like some OPEN statemenmts):
!
! call fdv$getdl( junk$, &
! junk%, &
! 23%, &
! "Enter the defective Port number: " )
!
hdlr% = 98 if pos(nlws_uc_tmp$,"CALL " ,1)=1 ! indent on (conditional)
goto statement_handler if hdlr% > 0 !
!
hdlr% = 25 if pos(nlws_uc_tmp$,"DATA " ,1)=1 ! indent on for continuation
hdlr% = 27 if pos(nlws_uc_tmp$,"DECLARE " ,1)=1 ! indent on for continuation
hdlr% = 25 if pos(nlws_uc_tmp$,"MAP(" ,1)=1 ! indent on for continuation (no trailing space)
hdlr% = 25 if pos(nlws_uc_tmp$,"MAP (" ,1)=1 ! indent on for continuation (no trailing space)
hdlr% = 25 if pos(nlws_uc_tmp$,"EXTERNAL " ,1)=1 ! indent on for continuation
goto statement_handler if hdlr% > 0 !
!
hdlr% = 50 if pos(nlws_uc_tmp$,"INTEGER " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"BYTE " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"WORD " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"LONG " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"QUAD " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"ANY " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"SHORT " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"STRING" ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"REAL " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"SINGLE " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"DOUBLE " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"FLOAT " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"FFLOAT " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"GFLOAT " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"HFLOAT " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"DECIMAL " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"DECIMAL( " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"DECIMAL ( " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"RFA " ,1)=1 ! indent on (conditional)
hdlr% = 50 if pos(nlws_uc_tmp$,"BASIC$QUADWORD ",1)=1 ! indent on (conditional)
goto statement_handler if hdlr% > 0 !
!
hdlr% = 26 if pos(nlws_uc_tmp$,"FUNCTION " ,1)=1 ! indent on for continuation only
hdlr% = 26 if pos(nlws_uc_tmp$,"SUB " ,1)=1 ! indent on for continuation
!
!~~~ hdlr% = 999 if pos(nlws_uc_tmp$,"END RECORD " ,1)=1 x back to column 9
hdlr% = 999 if pos(nlws_uc_tmp$,"END FUNCTION " ,1)=1 ! back to column 9
hdlr% = 999 if pos(nlws_uc_tmp$,"END SUB " ,1)=1 ! back to column 9
hdlr% = 999 if pos(nlws_uc_tmp$,"END PROGRAM " ,1)=1 ! back to column 9
hdlr% = 999 if pos(nlws_uc_tmp$,"END " ,1)=1 ! back to column 9
!
hdlr% = 900 if hdlr% = 0 ! take care of unhandled condition
!
! BASIC statement handlers
!
statement_handler:
select hdlr%
case 1 ! detected "IF"
!
! beware of the follwing "reverse if" statement:
!
! goto yada &
! if (whatever% = 99)
!
if prev_amper% = 1 then ! probably a reverse IF
code_pos% = code_pos% + indent% ! move indent to the right
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print with extra indent
code_pos% = code_pos% - indent% !
gosub build_indent_from_code_pos ! restore indent back to left
prev_amper% = 0 !
else !
op$ = indent$ + nlws$ ! print IF line using current indent
code_pos% = code_pos% + indent% ! now adjust for next line of code
gosub build_indent_from_code_pos !
!
ptr_s% = ptr_s% + 1 ! push statement stack
linenum(ptr_s%) = source_line% ! remember line for debug
if pos(nlws_uc_tmp$,"THEN ",1)>0 then ! if a THEN statement is also on this line
statem$(ptr_s%) = "IF THEN" ! store THEN statement data for future test
else
statem$(ptr_s%) = "IF" ! store IF statement data for future test
end if !
end if !
case 2 ! detected "THEN" on its own line
code_pos% = code_pos% - indent% ! turn indent off
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print
code_pos% = code_pos% + indent% !
gosub build_indent_from_code_pos ! turn indent back on
if statem$(ptr_s%) = "IF" then !
statem$(ptr_s%) = "IF THEN" ! overwrite IF statement on top of stack
end if !
case 3 ! detected "ELSE"
code_pos% = code_pos% - indent% ! turn indent off
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print
code_pos% = code_pos% + indent% !
gosub build_indent_from_code_pos ! turn indent back on
case 4 ! found "END IF"
code_pos% = code_pos% - indent% !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
ptr_s% = ptr_s% - 1 ! pop "IF" statement off stack
case 5 ! detected "SELECT"
op$ = indent$ + nlws$ ! print SELECT line using current indent
code_pos% = code_pos% + indent% ! adjust
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "SELECT" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
case 16 ! detected "CASE ELSE"
if statem$(ptr_s%) <> "CASE" then ! if the first CASE statement after SELECT
op$ = indent$ + nlws$ ! print CASE line using current indent
code_pos% = code_pos% + indent% ! adjust
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "CASE" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
else ! else not the first CASE statement after SELECT
code_pos% = code_pos% - indent% ! adjust left
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print CASE line
code_pos% = code_pos% + indent% ! adjust right
gosub build_indent_from_code_pos !
end if
case 6 ! detected "CASE"
!
! we want output to look like this:
! SELECT whatever
! CASE 20%, &
! 40%, &
! 60%
! something
!
if statem$(ptr_s%) <> "CASE" then ! if the first CASE statement after SELECT
junk1$ = left$( nlws$,4) ! remove CASE (preserve upper/lower case)
junk2$ = right$(nlws$,5) ! isolate the rest of the line
junk2$ = edit$(junk2$,8) ! remove leading white space
select left$(junk2$,1) ! test first character of the rest of the line
case "!","&" ! if start of comment or line continuation...
op$ = indent$ + nlws$ ! ...print CASE line using current indent
case else ! else this looks like data...
op$ = indent$ + junk1$ +" "+junk2$ ! ...print CASE line using current indent (but the
! following data is indented by 4)
end select !
code_pos% = code_pos% + indent% ! adjust
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "CASE" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
else ! if "secondary CASE" or "CASE ELSE"
code_pos% = code_pos% - indent% ! adjust left
gosub build_indent_from_code_pos !
junk1$ = left$( nlws$,4) ! remove CASE (preserve upper/lower case)
junk2$ = right$(nlws$,5) ! isolate the rest of the line
junk2$ = edit$(junk2$,8) ! remove leading white space
select left$(junk2$,1) ! test first char of the rest of the line
case "!","&" ! if start of comment or line continuation...
op$ = indent$ + nlws$ ! ...print CASE line using current indent
case else ! else looks like data...
op$ = indent$ + junk1$ +" "+junk2$ ! ...print CASE line using current indent (but the
! following data is indented by 4)
end select !
code_pos% = code_pos% + indent% ! adjust right
gosub build_indent_from_code_pos !
end if !
case 7 ! found "END SELECT"
if statem$(ptr_s%) = "CASE" then ! if "CASE" (or "CASE ELSE")
code_pos% = code_pos% - (indent% * 2) !
ptr_s% = ptr_s% - 2 ! pop CASE and SELECT
else !
code_pos% = code_pos% - indent% !
ptr_s% = ptr_s% - 1 ! pop SELECT
end if !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
case 8 ! detected "WHEN"
op$ = indent$ + nlws$ ! print IF line using current indent
code_pos% = code_pos% + indent% ! now adjust for next line of code
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "WHEN" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
case 9 ! detected "USES"
code_pos% = code_pos% - indent% ! turn indent off
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print
code_pos% = code_pos% + indent% !
gosub build_indent_from_code_pos ! turn indent back on
case 10 ! found "END WHEN"
code_pos% = code_pos% - indent% !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
ptr_s% = ptr_s% - 1 ! pop statement stack
case 11 ! detected "WHILE"
op$ = indent$ + nlws$ ! print IF line using current indent
code_pos% = code_pos% + indent% ! now adjust for next line of code
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "WHILE" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
case 12 ! found "NEXT"
code_pos% = code_pos% - indent% !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
ptr_s% = ptr_s% - 1 ! pop statement stack
case 13 ! detected "FOR"
op$ = indent$ + nlws$ ! print IF line using current indent
code_pos% = code_pos% + indent% ! now adjust for next line of code
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "FOR" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
!~ case 14% x found "NEXT " (NEXT with trailing space)
!~ code_pos% = code_pos% - indent% x
!~ gosub build_indent_from_code_pos x
!~ op$ = indent$ + nlws$ x
!~ ptr_s% = ptr_s% - 1 x pop statement stack
case 17 ! detected "VARIANT" (works like SELECT)
op$ = indent$ + nlws$ ! print SELECT line using current indent
code_pos% = code_pos% + indent% ! adjust
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "VARIANT" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
case 18 ! found "END VARIANT" (works like END SELECT)
if statem$(ptr_s%) = "CASE" then ! if "CASE" (or "CASE ELSE")
code_pos% = code_pos% - (indent% * 2) !
ptr_s% = ptr_s% - 2 ! pop CASE and VARIANT
else !
code_pos% = code_pos% - indent% !
ptr_s% = ptr_s% - 1 ! pop VARIANT
end if !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
case 19 ! detected "RECORD" (works like SELECT)
op$ = indent$ + nlws$ ! print SELECT line using current indent
code_pos% = code_pos% + indent% ! adjust
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "RECORD" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
case 20 ! found "END RECORD" (works like END SELECT)
if statem$(ptr_s%) = "CASE" then ! if "CASE" (or "CASE ELSE")
code_pos% = code_pos% - (indent% * 2) !
ptr_s% = ptr_s% - 2 ! pop CASE and VARIANT
else !
code_pos% = code_pos% - indent% !
ptr_s% = ptr_s% - 1 ! pop VARIANT
end if !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
case 21 ! detected "GROUP" (works like SELECT)
op$ = indent$ + nlws$ ! print SELECT line using current indent
code_pos% = code_pos% + indent% ! adjust
gosub build_indent_from_code_pos !
ptr_s% = ptr_s% + 1 ! push statement stack
statem$(ptr_s%) = "GROUP" ! store data for future test
linenum(ptr_s%) = source_line% ! remember line for debug
case 22 ! found "END GROUP" (works like END SELECT)
if statem$(ptr_s%) = "CASE" then ! if "CASE" (or "CASE ELSE")
code_pos% = code_pos% - (indent% * 2) !
ptr_s% = ptr_s% - 2 ! pop CASE and VARIANT
else !
code_pos% = code_pos% - indent% !
ptr_s% = ptr_s% - 1 ! pop VARIANT
end if !
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ !
case 98 ! found "OPEN or "CALL"
op$ = indent$ + nlws$ ! print BASIC line using current indent
open_mode% = 1 ! show us in file open mode
!
! this horrible patch can collapse calls to FDV$GET or FDV$GETDL into a single line bf_104.1
!
! Note: the older technique of creating more white space was OK with
! small programs but is a real pain when debugging large programs
!
if stmt_collapse_option$ = "Y" and ! if we want to collapse FDV$GETDL statments &
code_pos% <= 80 ! and we're not indented too far to the right
then
declare long st1%, st2%, st3%, st4%, ste% ! declare 'special test' variables for this patch
st1% = pos(nlws_uc_tmp$,"CALL FDV$GET",1) ! locate desired opening tag GET or GETDL
st2% = pos(nlws_uc_tmp$,")",st1%) ! locate possible closing tag
st3% = pos(nlws_uc_tmp$,"!",st1%) ! locate possible remark tag
st4% = pos(nlws_uc_tmp$,"&",st1%) ! locate possible line continuation tag
if st1% > 0 and ! FDV$GETDL tag was found &
st2% = 0 and ! closing tag was not found &
st3% = 0 and ! comment tag was not found &
st4% > 0 ! continuation tag was found
then
!
! I shouldn't be doing file i/o at this point but I'm in a hurry
!
patch_read_more:
when error in
ste% = 0 ! init
linput #1, ip$ ! read input
source_line% = source_line% + 1
use
ste% = err
print "-e- unexpected error "+str$(ste%)+" in FDV$GETDL collapse logic"
print "-w- this program will now abort"
end when
resume sortie if ste% <> 0 ! exit if any kind of error ***--->>>
!
st1% = pos(op$,"&",1) ! locate continuation character of previous line
op$ = left$(op$,st1%-1) ! lop it off
op$ = edit$(op$,128) ! discard trailing white space of previous line
ip$ = edit$(ip$, 8) ! discard leading white space of new line
op$ = op$ + ip$ ! join lines
st2% = pos(op$,")",1%) ! locate possible closing tag
st3% = pos(op$,"!",1%) ! locate possible remark tag
st4% = pos(op$,"&",1%) ! locate possible line continuation tag
if st2% = 0 and ! closing tag was not found &
st3% = 0 and ! comment tag was not found &
st4% > 0 ! continuation tag was found
then !
goto patch_read_more ! go back for more
end if !
if st4% = 0 then ! fixed the current line continuation logic
curr_amper% = 0 !
else !
curr_amper% = 1 !
end if !
end if !
end if !
case 25 , ! "MAP", etc. &
26 ! "MODULE", "FUNCTION", etc.
op$ = indent$ + nlws$ ! print BASIC line using current indent
declaration_mode% = 1 ! more indent
case 27 ! "DECLARE"
op$ = indent$ + nlws$ ! print BASIC line using current indent
declaration_mode% = 2 ! lots more indent
case 49 ! found "FOR INPUT" or "FOR OUTPUT"
op$ = indent$ + nlws$ ! print BASIC line using current indent
case 50 ! lone BASIC 'data type' statement
!
! we want output to look like this:
! declare string yada$ ,&
! junk$ ,&
! long junk% ,& <<<--- this is the lone data type
! temp%
!
if prev_amper% = 1 then
code_pos% = code_pos% + 8 ! move indent to the right
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print with extra indent
code_pos% = code_pos% - 8 !
gosub build_indent_from_code_pos ! restore indent back to left
prev_amper% = 0 !
else
op$ = indent$ + nlws$ ! print line using current indent
end if
case 900 ! default statement handler
select mode_amper% !
case 2, 3 ! starting an amper block
if statem$(ptr_s%) = "IF" then ! if we're in an IF block bf_103.2
move_pos% = 0 ! this is our default
else !
move_pos% = indent% ! this is our default
end if !
select declaration_mode% !
case 0 !
case 1 !
move_pos% = 16 ! need room for types like INTEGER
case 2 !
move_pos% = 24 ! need room for stuff like BASIC$QUADWORD
end select !
move_pos% = indent% if open_mode% = 1 !
code_pos% = code_pos% + move_pos% ! move indent to the right
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print with extra indent
code_pos% = code_pos% - move_pos% ! restore indent back to left
gosub build_indent_from_code_pos !
prev_amper% = 0 !
case else
op$ = indent$ + nlws$ ! print line using current indent
end select
case 999 ! one of many basic END statements
if prev_amper% = 1 then !
select declaration_mode% !
case 0 !
move_pos% = indent% !
case 1 !
move_pos% = (indent% * 4) ! need room for types like INTEGER
case 2 !
move_pos% = (indent% * 6) ! need room for stuff like BASIC$QUADWORD
end select !
code_pos% = code_pos% + move_pos% ! move indent to the right
gosub build_indent_from_code_pos !
op$ = indent$ + nlws$ ! print with extra indent
code_pos% = code_pos% - move_pos% !
gosub build_indent_from_code_pos ! restore indent back to left
prev_amper% = 0 !
else !
op$ = indent$ + nlws$ ! print line using current indent
end if !
!
if (code_pos% <> 8) then ! if not at first indent
print "-i-scf-line: ";str$(source_line%);", code_pos: ";str$(code_pos%);" -> 8" &
if debug_option$ = "Y" !
code_pos% = 8 !
gosub build_indent_from_code_pos !
end if !
!
gosub dump_stack
!
end select ! select hdlr%
end select
!
op$ = basic_line$ + op$ !
!========================================================================================================================
! end of: 'first character is white'
!========================================================================================================================
!
!========================================================================================================================
! do output
!========================================================================================================================
do_output:
if curr_amper% = 0 then
declaration_mode% = 0 !
open_mode% = 0 !
end if
prev_amper% = curr_amper% ! save this state for next pass through
curr_amper% = 0 ! reset
!
goto skip_comment_adjust if comment_option$ <> "Y" ! bypass if not enabled
!
! At this point, op$ contains the data we wish to output. It will also contain a mixture of spaces and/or tabs.
! This code will attempt to locate comments after visual column 60 and move them to visual column 81
!
declare long vs_length% , ! visual string length &
vp_1st_exclam% , ! visual position of first exclamtion &
vp_last_exclam% , ! visual position of last exclamation &
cp_last_exclam% ! char position of last exclamation
!
vp_1st_exclam% = 0
vs_length% = 0
vp_last_exclam% = 0
cp_last_exclam% = 0
!
for i% = 1 to len(op$)
!
! make sure we only catch exclamtions that are not part of a string declartion
!
quoted_mode% = 1 if mid$(op$,i%,1) = '"' and quoted_mode% = 0 ! double quotes (start of comment mode 1)
quoted_mode% = 0 if mid$(op$,i%,1) = '"' and quoted_mode% = 1 ! (end of comment mode 1)
!
quoted_mode% = 2 if mid$(op$,i%,1) = "'" and quoted_mode% = 0 ! single quotes (start of comment mode 2)
quoted_mode% = 0 if mid$(op$,i%,1) = "'" and quoted_mode% = 2 ! (end of comment mode 2)
!
select mid$(op$,i%,1)
case htab ! tab
vs_length% = vs_length% + 8
vs_length% = (vs_length% / 8%) * 8% !
case "!" ! exclamation (may be inside a data statement)
vs_length% = vs_length% + 1
if quoted_mode% = 0 then ! if quoted mode is off...
vp_1st_exclam% = vs_length% if vp_1st_exclam% = 0 ! remember visual position of 1st exclamation
vp_last_exclam% = vs_length% ! remember visual position of any exclamation
cp_last_exclam% = i% ! remember char position of any exclamation
end if
case else
vs_length% = vs_length% + 1
end select
next i%
goto skip_comment_adjust if vp_1st_exclam% <= 40% ! ignore commented blocks of remarks
!
! vs_length% : visual string length
! vp_last_exclam% : visual postion of last exclamation
! cp_last_exclam% : char position of last exclamation
!
select vp_last_exclam% ! visual position of last exclamation
case 50 to 80 ! if < 81
!~~~ op$ = op$ +"~"+str$(vs_length%)+"~"+str$(vp_last_exclam%)+"~"+str$(cp_last_exclam%)
!~~~ print #2, "~~~~~"
!~~~ print #2, op$
!~~~ dest_line% = dest_line% + 1 x
junk2$ = left$(op$, cp_last_exclam%-1) ! first part
junk3$ = right$(op$, cp_last_exclam% ) ! second part (remarks)
junk2$ = edit$(junk2$, 128) ! no trailing white space
junk3$ = edit$(junk3$, 128) ! ditto
!
! now we need to know the visual length of junk2$
!
build_out_loop:
vs_length% = 0
for i% = 1 to len(junk2$)
!
select mid$(junk2$,i%,1)
case htab ! tab
vs_length% = vs_length% + 8
vs_length% = (vs_length% / 8%) * 8% !
case else
vs_length% = vs_length% + 1
end select
next i%
!
if vs_length% < 80% then
junk2$ = junk2$ + htab
goto build_out_loop
end if
!
op$ = junk2$ + junk3$
!
end select !
skip_comment_adjust: !
!
select ptr_s% ! bf_106.1
case < 0 !
print "-i-debug ptr_s% is too low: "+ str$(ptr_s%) !
print "-i-debug line number : "+ str$(source_line%) !
print "-i-debug line data : "+ ip$ !
end select !
return !
!====================================================================================================
! build indent (from code_pos%)
! note: usually we indent code with tabs (and optionally up to 4 spaces)
!
! entry: code_pos% (where we want our code to begin)
! exit: indent$
!====================================================================================================
build_indent_from_code_pos:
if padding_option$ = "T" then !
junk% = code_pos% / 8% ! how many TABs do we need?
indent$ = string$( junk%, 9 ) ! start building with tabs
else !
junk% = 0 ! 0 TABs
indent$ = "" ! init
end if !
!
junk% = code_pos% - (junk% * 8) ! how many spaces do we need?
indent$ = indent$ + string$( junk%, 32 ) ! now append spaces (if any)
!
return !
!====================================================================================================
! dump stack
!====================================================================================================
dump_stack:
if debug_option$ = "Y" then ! if debug was selected
if ptr_s% > 0 then
print "Statement-Line Array Dump:"
print " Entry Src-Line BASIC-Statement Misc"
print " ===== ======== =============== ============================================"
end if
while (ptr_s% > 0) ! if something still on the stack
print " ";format$(ptr_s%,"##### ")+ &
format$(linenum(ptr_s%),"######## ")+ &
format$(statem$(ptr_s%),"'LLLLLLLLLLLLLL " );
select statem$(ptr_s%)
case "IF"
print "msg: missing END-IF for line ";str$(linenum(ptr_s%))
case "THEN"
print "msg: missing END-IF for line ";str$(linenum(ptr_s%))
case "ELSE"
print "msg: missing END-IF for line ";str$(linenum(ptr_s%))
case else
print
end select
ptr_s% = ptr_s% - 1 !
next !
end if
return
!====================================================================================================
!
! <<< adios >>>
!
sortie:
close #1
when error in
while 1
kill k_program+".scratch"
next
use
end when
!
end