!
!
!    FinalTouch
!
!    Version 1.0 -- Copyright © 1986 by True BASIC, Inc.
!                   All rights reserved.
!
!    Run this program to change a linker output file into an True BASIC
! Amiga native-code library file.  See Appendix E of your
! "True BASIC User's Guide" for more information.
!
!    The program asks for the SUB or DEF statement which defines the
! routine.  This is the SUB or DEF line which would start out the routine
! if it were written in True BASIC.  It doesn't matter what you call the
! arguments for the routine, as long as AsmScan can figure out what type
! you mean (whether string, number, string array or number array).
!
!    The program then asks for the file name; a header will be added to
! the file you specify, indicating that it is a routine of the type you
! described.  These files can simply be concatenated together to form a
! library with more than one native-code routine, but only after AsmMaker
! has added a compiled file header to each one separately.
!

CALL getdef(procname$,typedef$)
CALL getfile(#1)

ASK #1: filesize X
READ #1, bytes x: bin$
ERASE #1

CALL packb(s$,8*0+1,16,54339)     ! compiled file header
CALL packb(s$,8*2+1,32,0)         ! length (filled in below)
CALL packb(s$,8*6+1,16,97)        ! type of routine (executable)
CALL packb(s$,8*8+1,16,len(procname$))      ! length of routine name
LET s$ = s$ & lcase$(procname$)   ! the name
CALL packb(s$,len(s$)*8+1,16,len(typedef$))      ! length of type string
LET s$ = s$ & typedef$            ! the type info
IF mod(len(s$),2) <> 0 then LET s$ = s$ & chr$(0)     ! pad to word boundary
LET s$ = s$ & bin$                ! add load input after
CALL packb(s$,8*2+1,32,len(s$))   ! set total length of the string

WRITE #1: s$
CLOSE #1

END

SUB getfile(#1)
    DO
       LET error = 0
       LINE INPUT prompt "Enter name of file: ": s$
       WHEN exception in
            OPEN #1: name s$, access outin, organization byte, create old
       USE
            PRINT extext$
            LET error = 1
       END WHEN
    LOOP until error = 0
END SUB

SUB getdef(procname$,typedef$)
    DO
       LINE INPUT prompt "Enter SUB or DEF line for the routine: ": s$
       LET s$ = rtrim$(s$)
       LET loc = 1
       LET error = 0
       WHEN exception in
            CALL skipspaces(s$,loc)
            CALL scantype(s$,loc,type$)
            CALL skipspaces(s$,loc)
            CALL scanname(s$,loc,procname$)
            CALL skipspaces(s$,loc)
            CALL scanparm(s$,loc,parm$)
            CALL skipspaces(s$,loc)
            if loc<=len(s$) then cause exception 1,"Doesn't belong here."
       USE
            PRINT repeat$(" ",loc+38); "X"
            PRINT extext$
            LET error = 1
       END WHEN
       PRINT
    LOOP until error = 0
    LET typedef$ = type$ & parm$
END SUB


SUB scantype(s$,loc,type$)
    LET t$ = Ucase$(s$[loc:loc+3])
    SELECT CASE t$
    CASE "DEF "
         LET type$ = "f"
    CASE "SUB "
         LET type$ = "s"
    CASE else
         CAUSE EXCEPTION 1,"This must be a SUB or DEF."
    END SELECT
    LET loc = loc+4
END SUB

SUB scanname(s$,loc,name$)
    DECLARE DEF chartype
    LET type = chartype(s$,loc)
    IF type <> 0 then
       CAUSE EXCEPTION 1,"Identifier must begin with a letter."
    END IF
    LET initloc = loc
    DO
       LET loc = loc+1
       LET type = chartype(s$,loc)
       IF type = 2 then
          LET loc = loc+1
          LET type = -1
       END IF
    LOOP until type = -1
    IF loc > initloc+31 then
       LET loc = initloc
       CAUSE EXCEPTION 1,"Identifier must be less than 32 characters long."
    END IF
    LET name$ = s$[initloc:loc-1]
END SUB

DEF chartype(s$,loc)
    LET c$ = s$[loc:loc]
    SELECT CASE c$
    CASE "a" to "z", "A" to "Z"
         LET chartype = 0
    CASE "0" to "9", "_"
         LET chartype = 1
    CASE "$"
         LET chartype = 2
    CASE else
         LET chartype = -1
    END SELECT
END DEF

SUB scanparm(s$,loc,parm$)
    DECLARE DEF chartype
    LET parm$ = ""
    LET end = len(s$)+1
    IF loc >= end then EXIT SUB
    IF s$[loc:loc] <> "(" then
       CAUSE EXCEPTION 1,"Expected ""(""."
    END IF
    LET loc = loc+1
    CALL skipspaces(s$,loc)
    DO
       CALL scanname(s$,loc,name$)
       IF name$[len(name$):maxnum] = "$" then
          LET parm$ = parm$ & "s"
       ELSE
          LET parm$ = parm$ & "n"
       END IF
       CALL skipspaces(s$,loc)
       if s$[loc:loc] = "(" then
          let dimcount = 1
          do
             let loc = loc+1
             call skipspaces(s$,loc)
             if s$[loc:loc] = "," then
                let dimcount = dimcount+1
                if dimcount>255 then cause exception 1,"Too many dimensions."
             else
                exit do
             end if
          loop
          if s$[loc:loc] <> ")" then
             CAUSE EXCEPTION 1,"Expected "")""." 
          end if
          let parm$ = parm$ & Str$(dimcount)
          let loc = loc+1
          call skipspaces(s$,loc)
       end if
       let parm$ = parm$ & ","
       IF s$[loc:loc] = "," then
          LET loc = loc+1
          CALL skipspaces(s$,loc)
       Else
          exit do
       end if
    LOOP
    IF s$[loc:loc] <> ")" then
       CAUSE EXCEPTION 1,"Expected "")""."
    END IF
    let loc = loc+1
END SUB

SUB skipspaces(s$,loc)
    DO while s$[loc:loc] = " "
       LET loc = loc+1
    LOOP
END SUB