'nbr is a microsoft (r) basic program that adds line numbers to a file
'labels of the form "[label]" are converted to the appropriate line number

'NOTE!!
'    lines that end with a colon must be terminated with a linefeed
'    (^P^J in WordStar) to continue on the next physical line--
'    this also applies to 'if' statements continued on multiple
'    lines, ie, end physical lines that continue on the next line
'    with a LINEFEED, not a RETURN...
'    Lines continued in this manner are still limited to a total 
'    of 255 chars (including LFs, TABs, etc), this program does 
'    not check for this error, it crashes!!

vers$ = 
	"vers 1.3, 23 Jun 85 " + 
	"copyright (c) 1985 by Brian Dugle"

'This program may be used by any individual for non-commercial purposes
'it may not be sold alone or as part of a group of "public domain"
'programs
'	1.3	Changed progline$ to array for quicker disk processing
'		and defined all variables to default to integer
'		23 Jun 85 BCD

'	1.2	Added pass & line number heartbeat
'		20 Jun 85 BCD

goto [start]

'~~~~~~~~~~~~~~~~~~~~~~~~~~~ subroutines ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[eval label]

'extract a label from a line when lblptr = 1, ie, line starts with a label
'if it is not already in the list, add it to the list

gosub [get label]
if lblerr then
	errmsg$ = "Incorrect label format":
	gosub [print errmsg]:
	goto [end eval label]
gosub [match label]
if inlist then
	gosub [lbl dbl def]
else
	gosub [add to list]
[end eval label]
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[reformat line]

'progline$ (n) from infile is not a remark, so add the line number
' and tabs following linefeeds to maintain indenting
'if progline$ (n) is a label, make it a remark to remain in file...

if left$ (progline$ (n), 1) = lblstcode$ then
	progline$ (n) = "' " + progline$ (n)
progline$ (n) = str$ (linenum) + tab$ + progline$ (n)
lfpos = instr (progline$ (n), lf$)
while lfpos <> 0

' what is the char following the lf?

	c$ = mid$ (progline$ (n), lfpos+1, 1)

' did MBasic add a cr after the lf?  if so, must bump ptr...

	if c$ = cr$ then
 		lfpos = lfpos + 1

' a lf in the line means logical line continues on another physical 
'  line, so add a tab to make indenting line up correctly

	progline$ (n) =
 		left$ (progline$ (n), lfpos) +
		tab$ +
 		mid$ (progline$ (n), lfpos+1)

' now look for any more linefeed chars

	lfpos = instr (lfpos+1, progline$ (n), lf$)
wend
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[set quote positions]

'searches progline$ (n) for quotes (chr$(34)), saves position of 
' each quote char in quotepos$
'positions are one byte values saved in a string variable

qpos = instr (progline$ (n), quote$):
quotepos$ = ""
while qpos <> 0
	quotepos$ = quotepos$ + chr$ (qpos):
	qpos = instr (qpos+1, progline$ (n), quote$)
wend
quotepos$ = quotepos$ + chr$ (255)
numquotechars = len (quotepos$) - 1:
oddoreven = numquotechars:
gosub [check odd]:
if isodd then
	errmsg$ = "Quotes not paired":
	gosub [print errmsg]
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[set rem ptr]

'routine finds the first rmk$ in progline$ (n) that is not in a quoted string
' returns its position in remptr

remptr = instr (progline$ (n), rmk$)

'repeat...

[next rem ptr]
	ptr = remptr:
	gosub [check ptr in quotes]
	if ptrinquotes then
		remptr = instr (remptr+1, progline$ (n), rmk$):
		goto [next rem ptr]

'...until remptr not in quotes

if remptr = 0 then
 	remptr = 255
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[check ptr in quotes]

'remark and label identifiers are not significant when in quoted strings
'this routine checks ptr to see if it is within a quoted string
' uses quotepos$
' returns boolean ptrinquotes

if ptr > 255 then
	errmsg$ = "Pointer value too high, " + str$ (ptr):
	gosub [print errmsg]:
	stop

qnum = 1:
qpos = asc (quotepos$)

while ptr > qpos
	qnum = qnum + 1:
	qpos = asc (mid$ (quotepos$, qnum, 1))
wend

oddoreven = qnum:
gosub [check odd]
ptrinquotes = iseven
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[check odd]

'integer passed in oddoreven is evaluated
'boolean results returned in isodd and iseven

isodd = (oddoreven and 1) = 1:
iseven = not isodd:
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[insert label num]

'pass two--change a label to its value
'arrive here with lblptr pointing to start of a label in progline$ (n)
' find label in list and replace with value or 
' print error:  undefined label

gosub [get label]
if lblerr then
	errmsg$ = "Incorrect label format at pos" + str$ (lblptr):
	gosub [print errmsg]:
	goto [end insert label num]

gosub [match label]
if not inlist then
	errmsg$ = "Undefined label '[" + lbl$ + "]'":
	gosub [print errmsg]:
	goto [end insert label num]

'endlblptr set by [get label] above...

progline$ (n) = 
	left$ (progline$ (n), lblptr - 1) + 
	str$ (lblval (nlbl)) + 
	mid$ (progline$ (n), endlblptr + 1)

[end insert label num]
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[get label]

'call with lblptr pointing to lblstcode$ in progline$ (n)
'return with label name in lbl$, error in lblerr, lblptr not changed
' and endlblptr at position of lblendcode$...

endlblptr = instr (lblptr, progline$ (n), lblendcode$)
lblerr = (endlblptr = 0)
if not lblerr then
	lbl$ = mid$ (progline$ (n), (lblptr + 1), (endlblptr - lblptr -1))
else
	lbl$ = ""
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[match label]

'find label in label list, return result in boolean "inlist"
' if in list, return subscript in "nlbl"

inlist = false:
nlbl = -1

while (nlbl < maxlblnum) and not inlist
	nlbl = nlbl + 1
	inlist = (lbl$ = lblname$ (nlbl))
wend
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[make upper]

'pass a string to this routine in upr$
'routine checks each char and, if lower case, converts it to upper case
'result returned in upr$

for c = 1 to len (upr$)
	cupr$ = mid$ (upr$, c, 1)
	if (cupr$ < "a") or (cupr$ > "z") then
		goto [next char]

'	...cupr$ is lower case, convert it and insert into upr$...

	cupr$ = chr$ ( asc (cupr$) - 32 )
	upr$ = left$ (upr$, c-1) + cupr$ + mid$ (upr$, c+1)

[next char]
next c
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[open error]

'error on attempt to open input file

if err = 53 then 
	print "Error, file: " infile$ " not found, check spelling":
	resume [get filename]
else
	on error goto 0

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[lbl dbl def]
'error, found label already in list during pass one

errmsg$ = "Label '[" + lbl$ + "]' is redefined in line" + 
	str$ (linenum) + ", value is" + str$ (lblval (n))
gosub [print errmsg]
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[add to list]

'pass one--add a new label to the list

lblname$ (maxlblnum) = lbl$
lblval (maxlblnum) = linenum
maxlblnum = maxlblnum + 1
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[print errmsg]

'message passed in "errmsg$"
'prints to screen and outfile

print "Error in source line" + sourceln:
print errmsg$
if pass = 2 then
	print # outfile, errmsg$
return

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


[start]

defint a-z
tblsz = 50:
nmax = 99
dim lblname$ (tblsz), lblval (tblsz), progline$ (nmax)

'logical values and ascii constants

false = 0: 
true = not false:
tab$ = chr$ (9):
lf$ = chr$ (10):
cr$ = chr$ (13):
quote$ = chr$ (34)

'terminal constant - clear screen

cl$ = chr$ (26)

'program parameters and initialized variables

startnum = 100: 
incr = 10:
infile = 1: 
outfile = 2

rmk$ = "'":
lblstcode$ = "[":
lblendcode$ = "]":
maxlblnum = 0

'_______________________________________________________main program

print cl$
print vers$

[get filename]

'the source code file must have the extension ".ASC"
'the program will write a ".NUM" file and a ".SYM" file
'  the ".NUM" file is a numbered file in ascii format
'  LOAD the "prog.NUM" file and SAVE "prog" to create a "prog.BAS" file
'  the ".SYM" file can be LOADed and LISTed but consists only of
'	a listing of the labels and their line numbers

input "Enter the program name: ", progname$

upr$ = progname$: 
gosub [make upper]: 
progname$ = upr$:
infile$ = progname$ + ".ASC": 
outfile$ = progname$ + ".NUM":
symfile$ = progname$ + ".SYM"

'............................................pass one

pass = 1
on error goto [open error]
open "I", infile, infile$

linenum = startnum:
nbase = 0

[next block]

'get up to nmax+1 lines from infile
'  n is used to count lines in the array progline$ (n)
'  linenum holds the line number used in the numbered file output
'  sourceln holds the line number from the source file

n = 0
while not eof (infile) and n <= nmax
	line input # infile, progline$ (n):
	n = n + 1
wend
lastn = n - 1

'process the lines looking for labels

for n = 0 to lastn

	sourceln = nbase + n + 1
	print "pass"; pass; " line"; sourceln; cr$;
	lineisrem = (left$ (progline$ (n), 1) = rmk$):
	if lineisrem then [next pass1 line]

	if len (progline$ (n)) = 0 then [next pass1 line]

'	...if the line is not a remark and is not blank, check to see 
'		if it starts with a label...

	lblptr = instr (progline$ (n), lblstcode$):
	if lblptr = 1 then gosub [eval label]

	linenum = linenum + incr

[next pass1 line]
next n

if not eof (infile) then
	nbase = nbase + nmax + 1:
	goto [next block]

close infile

'check if entire program is still in memory...

proginmem = (nbase = 0)

'............................................pass two

pass = 2

if not proginmem then 
	open "I", infile, infile$

open "O", outfile, outfile$

linenum = startnum:
nbase = 0

[next block pass 2]

'process each line substituting linenum for labels and write to outfile

n = 0
while not eof (infile) and n <= nmax
	line input # infile, progline$ (n):
	n = n + 1
wend
lastn = n - 1

for n = 0 to lastn

	sourceln = nbase + n + 1:
	print "pass"; pass; " line"; sourceln; "    "; cr$;

'	...skip all work if progline$ (n) is a remark...

	lineisrem = (left$ (progline$ (n), 1) = rmk$):
	if lineisrem then [next pass2 line]

'	...check if blank line...

	if len (progline$ (n)) = 0 then [next pass2 line]

'	...not a remark or a blank line, set up for output...

	gosub [reformat line]
	gosub [set quote positions]
	gosub [set rem ptr]

	lblptr = instr (progline$ (n), lblstcode$):
		if lblptr = 0 then lblptr = 255

	while lblptr < remptr
		ptr = lblptr:
		gosub [check ptr in quotes]

		if not ptrinquotes then gosub [insert label num]

		lblptr = instr (lblptr+1, progline$ (n), lblstcode$):
		if lblptr = 0 then lblptr = 255
	wend

	print # outfile, progline$ (n)
	linenum = linenum + incr

[next pass2 line]
next n
if not proginmem then
	nbase = nbase + nmax + 1:
	if not eof (infile) then [next block pass 2]

if not proginmem then close infile
close outfile
print

'............................................finish up

'put the symbol table in a disk file that can be LISTed from MBasic...

open "O", outfile, symfile$
print # outfile, "1    'Label listing of: " + progname$ + ".BAS"
for i = 0 to maxlblnum-1
	print # outfile, str$ (lblval (i)), "'[" + lblname$ (i) + "]"
next
close
end