' Program SORTSUBS
' Designed for use with the Absoft AC/BASIC compiler.
'
' Many BASIC interpreters can handle subprograms embedded in the main
' program, but the compiler requires that all subprograms follow the main
' program.  This program accepts as input a program file name and produces
' a file of the same name with the following changes (only):
'
'     1. All subprogram blocks are moved to the end of the file, and
'     2. All lines containing DIM SHARED or DECLARE FUNCTION statements
'        are moved to the beginning of the file.
'
' The input file to be sorted must be a text file, and must not be in the
' compressed format used by the interpreter.
'

' No use for reals here
DEFINT A-Z

Version! = 2.0  ' Sortsubs version number
Mac   = 0
IIGS  = 1
Amiga = 2
Computer = Amiga ' Select the computer on which Sortsubs is being executed

' Boolean constants.
TRUE  = -1
FALSE = NOT TRUE

' Some useful string constants.
alphabet$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
digit$    = "0123456789"
idchars$  = alphabet$ + "." + digit$
clrline$  = SPACE$(40)

' Set up error trapping.
'ON ERROR GOTO ErrorTrap
WINDOW 1,"SortSubs v"+MID$(STR$(Version!),2)

' Get the file name from the user.
   INPUT "Type file to sort";filename$

RequestUseRAM:
   LOCATE 2,1
   PRINT clrline$; clrline$;
   IF Computer<>Mac THEN
      LOCATE ,1
      IF Computer=Amiga THEN
        INPUT "Use RAM disk for temporary files <YES>"; response$
      ELSE
        INPUT "Use /RAM5/ for temporary disk files <YES>"; response$
      END IF
      IF response$="" THEN response$="Y"
      IF INSTR("YyNn",LEFT$(response$,1))=0 THEN
         PRINT "Please repond with Y[ES] or N[O]."
         GOTO RequestUseRAM
      END IF
      IF INSTR("Yy",LEFT$(response$,1)) AND Computer=Amiga THEN tempdir$="RAM:"
      IF INSTR("Yy",LEFT$(response$,1)) AND Computer=IIGS THEN tempdir$="/RAM5/"
   END IF

PRINT clrline$

' Screen line on which stats begin
statline = 4

' Note starting time
Starttime! = TIMER

' Ensure file is not in compressed interpreter format.
DUMMY=9
OPEN "r",#DUMMY,filename$,1
FIELD #9,1 AS testchar$
GET #DUMMY,1
IF ASC(testchar$) > 127 THEN
   PRINT "?Source is not a FLAT ASCII file"
   PRINT "?Refer to BASIC manual for more information ..."
   GOTO EndAll2
END IF
CLOSE #DUMMY

' Open the source file to be sorted.
100 SOURCE=4
OPEN "i",#SOURCE,filename$

' Open temporary files to receive the sorted program.
' File "TEMP1" is for DIM SHARED statements;
' File "TEMP2" is for main-program lines;
' File "TEMP3" is for subprogram lines.
200 DIMS=1 : MAIN=2 : SUBS=3
OPEN "o",#DIMS,"TEMP...1" ',1000           ' This file must not be in RAM.
OPEN "o",#MAIN,tempdir$+"TEMP...2" ',1000
OPEN "o",#SUBS,tempdir$+"TEMP...3" ',1000

' Sort the program in one pass:
'    Write all DIM SHARED statements to TEMP...1;
'    Write the main program source lines to TEMP...2;
'    Write out all subprograms to TEMP...3.

' Initialize position flag.
insub = FALSE   ' Not in a subprogram, initially.

LOCATE statline+1,1
PRINT "Sorting MAIN";

300
'
' **** MAIN SORTING LOOP ****
'
WHILE NOT EOF(SOURCE)
   LINE INPUT #SOURCE,inline$  ' Get a line of source code.
   work$ = UCASE$(inline$)+"*" ' Make working copy, convert to upper case.
                               '   Add special char (for INSTR searches).
   CALL bypass(work$)          ' Trim leading spaces.
   CALL stripnum(work$)        ' Remove numeric label (if any).
   CALL bypass(work$)          ' Trim leading spaces.
   CALL striplab(work$)        ' Remove alphanumeric label (if any).
   CALL bypass(work$)          ' Trim leading spaces.
   CALL getid(work$,id1$)      ' Get the first idntifier.
   CALL bypass(work$)          ' Trim leading spaces.
   CALL getid(work$,id2$)      ' Get the second identifier.

   lineno = lineno + 1
   LOCATE statline,1
   PRINT "LINE: ";
   PRINT USING "#####"; lineno;

   400
   ' Examine the retrieved identifier(s).
   IF id1$ = "SUB" THEN        ' Subprogram beginning found.
      insub = TRUE             ' Set flag
      LOCATE statline+1,1
      PRINT "Sorting sub "; id2$; clrline$;
      PRINT #SUBS, inline$     ' Send the line to the subprogram temp file.

   ELSEIF id1$ = "DIM" AND id2$ = "SHARED" THEN   ' A DIM SHARED line.
      PRINT #DIMS, inline$                        ' Send to the temp file.

   ELSEIF id1$ = "DECLARE" AND id2$ = "FUNCTION" THEN   ' DECLARE FUNCTION
      PRINT #DIMS, inline$

   ELSE
      ' Not a DIM SHARED or SUB statement;
      ' Print line to appropriate file, depending on INSUB flag.
      IF insub THEN PRINT #SUBS, inline$ ELSE PRINT #MAIN, inline$
      IF id1$ = "END" AND id2$ = "SUB" THEN  ' Are we at the end of a SUB?
         insub = FALSE                       ' Yes.
         LOCATE statline+1,1
         PRINT "Sorting MAIN"; clrline$;
         PRINT #SUBS, ""                     ' Add white space between SUBs.
      END IF

   END IF   ' End of statement examination block.

WEND

' Close the source file, the MAIN temp file, and the SUBS temp file.
500 CLOSE SOURCE, MAIN, SUBS

' Clear work stats.
LOCATE statline+1,1
PRINT clrline$
LOCATE statline,1

' Copy the MAIN and SUBS temp files to the DIMS temp file
' to construct the final sorted version in TEMP...1.
PRINT "Copying sorted files ..."; clrline$
CALL FileCopy (tempdir$+"TEMP...2")
CALL FileCopy (tempdir$+"TEMP...3")
PRINT "File copy complete."

' Delete the original source file and rename the temporary.
CLOSE DIMS               ' Close the temporary file.
600 KILL filename$
700 NAME "TEMP...1" AS filename$

EndAll:
   ' Print final messages and wait for a mouse-click to end.
   PRINT "Sorting complete."
   PRINT "Elapsed time:" INT((TIMER-Starttime!)*10)/10 "seconds"

EndAll2:
   PRINT
   PRINT "- CLICK MOUSE TO EXIT -"
   BEEP
   WHILE MOUSE(0)=0 : WEND
   END

ErrorEnd:
   ON ERROR GOTO JustResume
   CLOSE
   KILL tempdir$+"TEMP...2"
   KILL tempdir$+"TEMP...3"
   GOTO EndAll

JustResume:
   RESUME NEXT

ErrorTrap:
   LOCATE statline+2,1
   PRINT clrline$;
   LOCATE ,1

   IF ERR=5 AND tempdir$ <> "" THEN
      PRINT "?Out of memory at line" ERL
      IF Computer<>Mac THEN PRINT "Try again without RAM option."
   ELSEIF ERL=100 THEN
      PRINT "?Source file not found"
      RESUME EndAll2
   ELSEIF ERL=200 THEN
      PRINT "?Error" ERR "in opening temporary files"
   ELSEIF ERL=300 THEN
      PRINT "?Error" ERR "in processing"
   ELSEIF ERL=400 THEN
      PRINT "?Error" ERR "in output to temporaries"
   ELSEIF ERL=500 THEN
      PRINT "?Error" ERR "in closing temporary files"
   ELSEIF ERL=600 THEN
      PRINT "?Cannot delete old source - error" ERR
   ELSEIF ERL=700 THEN
      PRINT "?Error" ERR "while renaming source file"
      PRINT "?Corrected source is in file TEMP...1"
   ELSE
      PRINT "?Error" ERR "at line" ERL
   END IF

   PRINT "Sorting cancelled."
   RESUME ErrorEnd

' Remove leading spaces and tabs from WORK$.
SUB bypass(work$) STATIC
   strip = 0
   WHILE MID$(work$,strip+1,1) = " " OR MID$(work$,strip+1,1) = CHR$(9)
      strip = strip+1
   WEND
   IF strip THEN work$ = MID$(work$,strip+1)
END SUB

' Remove BASIC line number (if any) from WORK$.
SUB stripnum(work$) STATIC
   SHARED digit$
   strip = 0
   WHILE INSTR(digit$,MID$(work$,strip+1,1)) <> 0
      strip = strip+1
   WEND
   IF strip THEN work$ = MID$(work$,strip+1)
END SUB

' Remove alphanumeric label (if any) from WORK$.
SUB striplab(work$) STATIC
   SHARED alphabet$,idchars$
   IF INSTR(alphabet$,LEFT$(work$,1)) = 0 THEN EXIT SUB
   strip = 1
   WHILE INSTR(idchars$,MID$(work$,strip+1,1)) <> 0
      strip = strip + 1
   WEND
   IF MID$(work$,strip+1,1) = ":" THEN work$ = MID$(work$,strip+2)
END SUB

' Remove the first alphanumeric identifier (if any) from the front of
' WORK$ and return it in ID$.
SUB getid(work$,id$) STATIC
   SHARED alphabet$,idchars$
   id$ = ""
   IF INSTR(alphabet$,LEFT$(work$,1)) = 0 THEN EXIT SUB
   strip = 1
   WHILE INSTR(idchars$,MID$(work$,strip+1,1)) <> 0
      strip = strip + 1
   WEND
   id$   = LEFT$(work$,strip)
   work$ = MID$(work$,strip+1)
END SUB

' Append the (temporary) file indicated by FILE$ to the first
' temporary file.  The INPUT$ method used works for files larger
' than 32767 characters.
SUB FileCopy(file$) STATIC
   SHARED DIMS

   ' Set copy buffer length = number of characters to
   ' transfer at a time.
   CopyBufLen = 10000

   OPEN "i",#5,file$       ' Open file to be copied.
   CharsToCopy!=LOF(5)     ' Get length in chars.

   ' Copy until no more chars-to-copy.
   WHILE CharsToCopy! > 0
      IF CharsToCopy! > CopyBufLen THEN
         PRINT #DIMS, INPUT$(CopyBufLen,5);
         CharsToCopy! = CharsToCopy! - CopyBufLen
      ELSE
         PRINT #DIMS, INPUT$(CharsToCopy!,5);
         CharsToCopy! = 0
      END IF
   WEND

   CLOSE 5     ' Close and delete copied file.
   KILL file$
END SUB