jona/unix-v6
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add original unix v6

Browse Source
This commit is contained in:
memnoth
2018-01-27 22:35:41 +09:00
commit 2c7099ee50
664 changed files with 106254 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
source/fort/f1/f11.s
+150
View File
@@ -0,0 +1,150 @@
/
/
/ f11 -- fortran command
/
.globl pass1
.globl fptrap
.globl getline
.globl flush
.globl perror
.globl lookup
.globl getype
.globl ssubr
.globl sfunc
.globl sbloc
.globl sextr
.globl sdime
.globl scomm
.globl sequi
.globl sdata
.globl sform
.globl simpl
.globl stype
.globl isagn
.globl ptemp
.globl funok
.globl signoff
.globl fopen
.globl fcreat
.globl lookid
.globl tfil1, tfil2
.globl tfildiag
pass1:
sys signal; 4; fptrap
cmp (sp)+,$2
bge 1f
2:
mov $1,r0
sys write; mes2; emes2-mes2
clr r0
sys seek; 0; 2
mov $-1,r0 / bad status
sys exit
1:
tst (sp)+
mov (sp)+,r0
jsr r5,fopen; ibuf
bcs 2b
mov $tfil1,r0
jsr r5,fcreat; obuf
bcs 2f
mov $tfil2,r0
jsr r5,fcreat; tbuf
bcc 1f
2:
jmp tfildiag
1:
/ data segment initialization
mov $2,nxtaloc
mov $errb,errp
mov $esymtab,esymp
mov $namebuf,namep
movb $'_,symbuf-1
jsr r5,lookid; blankc
bis $40,symtab(r3)
mov $imptab,r3
1:
mov $realcon,r0 / real*4
cmp r3,$imptab+[2*['i-'a]]
blo 2f
cmp r3,$imptab+[2*['n-'a]]
bhi 2f
mov $intcon,r0 / integer*4
2:
mov r0,[2*26.](r3) / lower case
mov r0,(r3)+ / upper case
cmp r3,$imptab+[2*26.]
blo 1b
/ call pass1
/ main scan loop for pass1
/ picks up non executable statements
/
scan1:
jsr r5,getline
mov $line,r1
jsr r5,isagn
br 2f
mov r1,r2
jsr r5,lookup; stmtab
br 1f
mov r2,r1
jsr r5,*sublst(r0)
mov pc,funok
jsr r5,perror
br scan1
1:
jsr r5,getype
br 2f
mov r2,r1
jsr r5,stype
jsr r5,perror
mov pc,funok
br scan1
2:
jsr r5,ptemp; 'l; efno; line
jsr r5,flush; tbuf
jsr r5,signoff; 1
sublst:
ssubr
sfunc
sbloc
sextr
sdime
scomm
sequi
sdata
sform
simpl
stmtab:
<subroutine\0>
<function\0>
<blockdata\0>
<external\0>
<dimension\0>
<common\0>
<equivalence\0>
<data\0>
<format\0>
<implicit\0>
<\0>
.even
mes2:
<Input file?\n>
emes2:
blankc:
<_\n\0>
.even
source/fort/f1/f12.s
+94
View File
@@ -0,0 +1,94 @@
/
/
/ f12 -- type statements and type getter subroutine
/
/
.globl stype
.globl getype
.globl typtab
.globl sfunc1
.globl lookup
.globl getsym
.globl error
.globl sdime1
stype:
mov r0,-(sp)
mov r1,r2
jsr r5,lookup; funtab
br 1f
mov r2,r1
mov (sp)+,r0
jmp sfunc1
1:
jsr r5,getsym
tst r0
bne 3f / junk error if not identifier
mov symtab(r3),r0
bic $![377\<8+7],r0 / size,type
beq 2f
cmp r0,(sp) / redefined, but same
beq 2f
jsr r5,error; 3.
2:
bic $377\<8+7,symtab(r3)
bis (sp),symtab(r3) / set in type and size
mov r3,-(sp)
jsr r5,getsym
cmp r0,$32. / ( for dimension
bne 2f
mov (sp),r3
jsr r5,sdime1
jsr r5,getsym
2:
tst (sp)+
cmp r0,$36. / , for another list element
beq 1b
cmp r0,$40. / eos
beq 1f
3:
jsr r5,error; 2. / junk
1:
tst (sp)+
rts r5
funtab:
<function\0>
<\0>
getype:
mov r1,r2
jsr r5,lookup; typtab
br 1f
mov tvaltab(r0),r0
tst (r5)+
1:
rts r5
tvaltab:
log1con
logcon
int1con
int2con
intcon
dcplxcon
dblcon
cplxcon
dblcon
realcon
typtab:
<logical*1\0>
<logical\0>
<integer*1\0>
<integer*2\0>
<integer\0>
<doublecomplex\0>
<doubleprecision\0>
<complex\0>
<real*8\0>
<real\0>
<\0>
source/fort/f1/f13.s
+101
View File
@@ -0,0 +1,101 @@
/
/
/ f13 -- dimension and array declarator
/
/ dimension
/
/
.globl sdime
.globl sdime1
.globl getsym
.globl error
.globl geti
.globl dimu
sdime:
jsr r5,getsym
tst r0
bne 3f / junk error
mov r3,-(sp)
jsr r5,getsym
mov (sp)+,r3
cmp r0,$32. / (
beq 2f
jsr r5,error; 4. / no ( in dimension
rts r5
2:
jsr r5,sdime1
jsr r5,getsym
cmp r0,$36. / ,
beq sdime
cmp r0,$40.
beq 1f
3:
jsr r5,error; 5.
1:
rts r5
/ get dimension info and store in
/ symbol table entry
/ r3 points at symbol table
/ r1 points just beyond (
sdime1:
bit $70,symtab(r3) / class
beq 1f
jsr r5,error; 6. / already classed
1:
mov r3,-(sp)
bic $70,symtab(r3)
bis $20,symtab(r3) / set as array
clr -(sp) / marker
1:
jsr r5,getsym
cmp r0,$2 / constant
bne 2f
cmp r3,$intcon / integer*4
bne 3f
jsr r5,geti
tst r0
ble 3f
mov r0,-(sp)
br 4f
2:
tst r0
bne 3f / identifer
tstb symtab(r3)
bge 3f / not parameter
neg r3
mov r3,-(sp)
mov sp,r0
2:
tst (r0)+
bne 2b
mov (r0),r0
tstb symtab(r0)
bge 3f / array not a param
4:
jsr r5,getsym
cmp r0,$36. / ,
beq 1b
cmp r0,$34. / )
beq 1f
3:
jsr r5,error; 7.
1:
mov esymp,r0
clr r2
mov dimu,-(r0)
inc dimu / unique number
1:
inc r2
mov (sp)+,-(r0)
bne 1b
dec r2
mov r2,(r0)
mov r0,esymp
mov (sp)+,r3
mov r0,symtab+2(r3)
rts r5
source/fort/f1/f14.s
+85
View File
@@ -0,0 +1,85 @@
/
/
/ f14 -- common statement
/
.globl scomm
.globl getsym
.globl sdime1
.globl error
.globl getid
.globl lookid
scomm:
mov r5,-(sp)
jsr r5,getsym
cmp r0,$6 / / for named common
beq ncom
3:
tst r0
bne 9f
mov r3,-(sp)
clr r5
br 2f
ncom:
cmpb (r1),$'/
bne 3f
inc r1
jsr r5,getsym
br 3b
3:
jsr r5,getid
br 9f / not identifier
jsr r5,lookid; symbuf-1
bis $40,symtab(r3) / set named common
mov r3,r5
jsr r5,getsym
cmp r0,$6 / /
bne 9f
1:
jsr r5,getsym
tst r0
bne 9f
mov r3,-(sp)
2:
jsr r5,getsym
cmp r0,$32. / (
bne 2f
mov (sp),r3
jsr r5,sdime1
jsr r5,getsym
2:
mov (sp)+,r3
bit $300,symtab(r3) / test param/common
beq 2f
jsr r5,error; 9. / not commonable or already commoned
br 3f
2:
mov r0,-(sp)
mov symtab+4(r5),r0
beq 2f
mov r3,symtab+4(r0) / next ptr of old last block
2:
mov (sp)+,r0
mov r3,symtab+4(r5) / new last ptr of head block
tst symtab+2(r5)
bne 3f
mov r3,symtab+2(r5) / first ptr if first block
3:
bis $100,symtab(r3)
cmp r0,$36. / ,
beq 1b
cmp r0,$6 / another /
beq ncom
cmp r0,$40. / =|
beq 8f
9:
jsr r5, error; 10. / common syntax error
8:
mov (sp)+,r5
rts r5
source/fort/f1/f15.s
+86
View File
@@ -0,0 +1,86 @@
/
/
/ f15 -- subroutine/function
.globl ssubr
.globl sfunc
.globl sbloc
.globl sfunc1
.globl funok
.globl getsym
.globl error
ssubr:
mov $2,progt
br 1f
sfunc:
mov $4,progt
1:
clr r0
br 2f
sfunc1:
mov $4,progt
2:
tst funok
beq 1f
jsr r5,error; 11.
1:
add $10,r0 / class=simple
mov r0,-(sp)
jsr r5,getsym
mov (sp)+,r2
tst r0
beq 1f
2:
jsr r5,error; 12.
rts r5
1:
mov r2,symtab(r3)
jsr r5,getsym
cmp r0,$32. / (
beq 1f
cmp r0,$40. / eos
bne 2b
rts r5
1:
clr -(sp)
1:
add $2,(sp)
jsr r5,getsym
tst r0
beq 3f
tst (sp)+
br 2b
3:
bis $200,symtab(r3) / param
mov (sp),symtab+6(r3) / param number
jsr r5,getsym
cmp r0,$36. / ,
beq 1b
tst (sp)+
cmp r0,$34. / )
bne 2b
jsr r5,getsym
cmp r0,$40.
bne 2b
rts r5
sbloc:
mov $6,progt
jsr r5,getsym
tst funok
beq 1f
jsr r5,error; 11.
1:
cmp r0,$40.
beq 1f
jsr r5,error; 13.
1:
rts r5
.data
funok: 0
source/fort/f1/f16.s
+37
View File
@@ -0,0 +1,37 @@
/
/
/ f16 -- extrn, equiv, data
.globl sextr
.globl sequi
.globl getsym
.globl putc
.globl error
.globl ptemp
sextr:
jsr r5,getsym
tst r0
bne 1f
bit $70,symtab(r3)
beq 2f
jsr r5,error; 14.
2:
bis $30,symtab(r3)
jsr r5,getsym
cmp r0,$36. / ,
beq sextr
cmp r0,$40. / eos
beq 2f
1:
jsr r5,error; 15.
2:
rts r5
sequi:
jsr r5,ptemp; 'e; efno; line
rts r5
source/fort/f1/f17.s
+70
View File
@@ -0,0 +1,70 @@
/
/
/ f17 -- implicit statement
.globl simpl
.globl getype
.globl chrtab
.globl error
simpl:
jsr r5,getype
br 9f
mov r2,r1
mov r0,-(sp)
movb (r1)+,r0
cmp r0,$'(
beq 1f
cmpb r0,$'/
bne 8f
1:
movb (r1)+,r0
cmpb chrtab(r0),$2
bne 8f
cmpb r0,$'a
blo 2f
sub $6,r0 / map 'a into 'Z+1
2:
movb (r1)+,r2
cmpb r2,$'-
bne 2f
movb (r1)+,r2
cmpb chrtab(r2),$2
bne 8f
cmp r2,$'a
blo 3f
sub $6,r2 / map 'a into 'Z+1
br 3f
2:
mov r0,r2
dec r1
3:
cmp r0,r2
bhi 8f
asl r0
asl r2
3:
mov (sp),imptab-[2*'A](r0)
add $2,r0
cmp r0,r2
blos 3b
movb (r1)+,r0
cmp r0,$',
beq 1b
tst (sp)+
cmp r0,$')
beq 1f
cmp r0,$'/
bne 9f
1:
tstb (r1)
bne simpl
rts r5
8:
tst (sp)+
9:
jsr r5,error; 16. / implicit syntax error
rts r5
source/fort/f2/f21.s
+24
View File
@@ -0,0 +1,24 @@
/
/
/ f21 -- storage allocation
/
.globl pass2
.globl signon
.globl signoff
.globl calloc
.globl salloc
.globl equiv
.globl entry
pass2:
jsr r5,signon; 2
mov $errb,errp
jsr r5,calloc
jsr r5,equiv
jsr r5,salloc
jsr r5,entry
jsr r5,signoff; 2
source/fort/f2/f22.s
+125
View File
@@ -0,0 +1,125 @@
/
/
/ f22 -- allocate common
.globl calloc
.globl entry
.globl declimpl
.globl size
.globl getc
.globl getw
.globl xbuf
.globl code
.globl typ
calloc:
clr r3
1:
cmp r3,symtp
bhis 1f
mov symtab(r3),r0
bic $!70,r0 / class
cmp r0,$40 / common block
bne 3f
mov r3,-(sp)
mov symtab+2(r3),r3
clr r2 / byte offset
2:
tst r3
beq 2f
jsr r5,declimpl
mov symtab+4(r3),-(sp)
mov 2(sp),symtab+4(r3)
mov r2,symtab+6(r3)
jsr r5,size
add r0,r2
mov (sp)+,r3
br 2b
2:
mov (sp)+,r3
clr symtab+2(r3)
mov r2,symtab+6(r3) / common block size
3:
add $8,r3
br 1b
1:
rts r5
entry:
mov progt,r0
jmp *1f(r0)
1:
main
subr
funct
blocd
main:
jsr r5,code
<main:\n\0>; .even
rts r5
subr:
funct:
jsr r5,code
<%n.: %n_\n\0>; .even
8
8
clr r3
1:
cmp r3,symtp
bhis 1f
mov symtab+2(r3),r0
beq 2f
mov (r0)+,r1 / num dims
asl r1
add r0,r1 / ptr to last dim
mov r3,-(sp)
mov (r1),-(sp) / dope id
clr r2 / dope offset
3:
add $2,r2
mov -(r1),r3
cmp r0,r1
bhi 3f
neg r3 / adjustable dimension
ble 3b
mov r0,-(sp)
jsr r5,declimpl
mov symtab(r3),r0
clrb r0
swab r0
jsr r5,code
< rval%dp; %n_\n\0>; .even
r0
r3
mov symtab(r3),r3
bic $![377\<8+7],r3
cmp r3,$2\<8+1 / is it i*2
beq 4f
bic $!7,r3
movb typ(r3),r3
jsr r5,code
< %c%di2\n\0>; .even
r3
r0
4:
mov 2(sp),r0
jsr r5,code
< stst; d%d+%d.\n\0>; .even
r0
r2
mov (sp)+,r0
br 3b
3:
tst (sp)+
mov (sp)+,r3
2:
add $8,r3
br 1b
1:
blocd:
rts r5
source/fort/f2/f23.s
+120
View File
@@ -0,0 +1,120 @@
/
/
/ f23 -- do equivalence statements
.globl equiv
.globl getsym
.globl consub
.globl eqvtab
.globl error
.globl declimpl
.globl perror
.globl setln
.globl getln
/ equivalence statements, part 1
/ destroys all registers
equiv:
jsr r5,setln
1:
jsr r5,getln
rts r5
cmp r0,$'e
bne 1b
mov $line+11.,r1
mov r5,-(sp)
2: / start equivalence group
cmpb (r1)+,$'( / check (
bne 9f / syntax error
jsr r5,getsym
tst r0
bne 9f / not identifier
mov r3,r5
jsr r5,equset
movb (r1)+,r2
clr r4 / offset
cmp r2,$',
beq 3f
cmp r2,$'( / subscripted vble
bne 9f / syntax error
jsr r5,consub / get subscript
mov r0,r4
cmpb (r1)+,$',
bne 9f
3: / rest of group
jsr r5,getsym / next ident
tst r0
bne 9f / syntax
jsr r5,equset
clr r0
mov r3,r2
cmpb (r1),$'( / subscript?
bne 4f
inc r1
jsr r5,consub
4:
mov eqvtab+2(r2),r2
cmp r2,r5
beq 5f / already in same group
cmp r2,r3
bne 4b / not yet in different group
sub r4,r0 / adjust offsets
sub eqvtab+4(r5),r0 / left vble's offset
add eqvtab+4(r3),r0 / new vble's offset
4:
sub r0,eqvtab+4(r2)
mov eqvtab+2(r2),r2
cmp r2,r3
bne 4b
mov eqvtab+2(r3),r0 / link up groups
mov eqvtab+2(r5),eqvtab+2(r3)
mov r0,eqvtab+2(r5) / link groups
br 6f
5: / here already in same group
cmp r0,r4 / offset must be same
beq 6f
jsr r5,error; 23. / inconsistency!
6:
movb (r1)+,r0
cmp r0,$',
beq 3b
cmp r0,$')
bne 9f
movb (r1)+,r0
bne 3f
jsr r5,perror
mov (sp)+,r5
br 1b
3:
cmp r0,$',
beq 2b
9:
jsr r5,error; 24. / equivalence syntax
jsr r5,perror
mov (sp)+,r5
br 1b
/ initialize member of equivalence group
equset:
jsr r5,declimpl / declare if necessary
mov symtab(r3),r0
bit $200,r0 / test parameter
bne 2f
bic $!70,r0
cmp r0,$10 / simple
beq 1f
cmp r0,$20 / array
beq 1f
2:
jsr r5,error; 31. / non-equivalencable variable
1:
tst eqvtab+2(r3) / see if mentioned yet
bne 1f
mov r3,eqvtab+2(r3) / points to itself
1:
rts r5
source/fort/f2/f24.s
+130
View File
@@ -0,0 +1,130 @@
/
/
/ f24 -- allocate storage for non-common variables
/ called after common and equivalence have been done
.globl salloc
.globl eqvtab
.globl error
.globl declimpl
.globl size
.globl perror
/ destroys all registers
salloc:
mov r5,-(sp)
clr r3 / loop over symbol table
br 2f
1:
add $8.,r3 / next variable
2:
cmp r3,symtp
blo 2f
mov (sp)+,r5
mov $line,r1
jsr r5,perror / flush errors
rts r5
2:
bit $70,symtab(r3)
beq 1b / unclassed
jsr r5,declimpl / just in case
tst eqvtab(r3) / test for already allocated
bne 1b / yes
mov symtab(r3),r0
bic $!70,r0
cmp r0,$10 / test class=simple
beq 2f
cmp r0,$20 / test array
bne 1b / no, not a variable
2:
bit $200,symtab(r3) / test parameter
bne 1b
tst eqvtab+2(r3) / test for equivalence
bne 2f / yes
bit $100,symtab(r3) / test common
bne 1b / yes, nothing to do
mov nxtaloc,symtab+6(r3) / offset
jsr r5,size / get byte count
add r0,nxtaloc
inc eqvtab(r3) / mark allocated
br 1b
2:
clr r4 / common variable of group
mov $77777,r1 / infinity to smallest offset
mov r3,r5
2:
cmp eqvtab+4(r3),r1
bgt 3f
mov eqvtab+4(r3),r1 / replace smallest offset
3:
bit $100,symtab(r3) / test common
beq 3f
mov r3,r4 / yes
3:
mov eqvtab+2(r3),r3 / next group member
cmp r3,r5
bne 2b
tst r4
bne 2f / *there was a common in group
/ equivalence group w/o common
sub nxtaloc,r1 / get -(group offset)
3:
inc eqvtab(r3) / mark allocated
mov eqvtab+4(r3),r2
sub r1,r2 / compute offset
mov r2,symtab+6(r3) / enter offset
jsr r5,size
add r0,r2 / highest loc of variable
cmp r2,r4
ble 4f
mov r2,r4 / extends storage
4:
mov eqvtab+2(r3),r3 / next of group
cmp r3,r5
bne 3b
mov r4,nxtaloc / account for space
br 1b / done!
2: / equivalence group w/ common
mov symtab+6(r4),r1 / actual common offset
sub eqvtab+4(r4),r1 / virtual common offset
2:
inc eqvtab(r3) / mark allocated
bit $100,symtab(r3) / is variable already in common
beq 3f / *no
cmp symtab+4(r4),symtab+4(r3)
beq 4f
jsr r5,error; 25. / different blocks equiv.
4:
mov r1,r0
add eqvtab+4(r3),r0
cmp r0,symtab+6(r3)
beq 4f / ok
jsr r5,error; 27. / same variable, different offsets
br 4f
3:
bis $100,symtab(r3) / mark common now
mov symtab+4(r4),symtab+4(r3)/ get right common block
mov r1,r0
add eqvtab+4(r3),r0
bge 3f
jsr r5,error; 26. / block extended leftward
clr r0
3:
mov r0,symtab+6(r3) / get proper offset
mov r0,-(sp)
jsr r5,size / see if size is extended
add (sp)+,r0
mov symtab+4(r3),r2 / common block
cmp symtab+6(r2),r0
bge 4f / ok
mov r0,symtab+6(r2) / extend size
4:
mov eqvtab+2(r3),r3
cmp r3,r5
bne 2b
jmp 1b
source/fort/f3/f31.s
+179
View File
@@ -0,0 +1,179 @@
/
/
/ f31 - pass3 dispatcher
/
/ main scan loop for pass3
/ picks up executable statements
/
.globl pass3
.globl ifstmt
.globl isagn
.globl signon
.globl signoff
.globl getline
.globl lookup
.globl sasgn
.globl error
.globl perror
.globl doend
.globl sform
.globl sdata
.globl sdo
.globl sassi
.globl scall
.globl scont
.globl sretu
.globl sgoto
.globl sif
.globl spaus
.globl sstop
.globl sread
.globl sprin
.globl swrit
.globl srewi
.globl sback
.globl sendf
.globl blocks
.globl blockp
.globl code
.globl ptemp
.globl dotabp
pass3:
jsr r5,signon; 3
br 2f
scan3:
jsr r5,getline
2:
mov $blocks,blockp
mov $line,r1
mov r1,r2
jsr r5,lookup; fmttab
br 2f
mov r0,-(sp)
jsr r5,isagn
br 1f
mov (sp)+,r0
jsr r5,*fmtlst(r0)
br scan3
1:
tst (sp)+
2:
mov efno,r0
beq 1f
jsr r5,ptemp; 's; efno; line
jsr r5,code
<.%d:\n\0>; .even
r0
1:
jsr r5,isagn
br 1f
mov r1,r2
jsr r5,lookup; stmtab
br 2f
mov r2,r1
jsr r5,*sublst(r0)
br 3f
1:
jsr r5,sasgn
br 3f
2:
jsr r5,error; 101.
3:
cmp progt,$6
bne 1f
jsr r5,error; 50. / execut in block data
1:
jsr r5,perror
mov efno,r0
beq scan3
jsr r5,doend
br scan3
ifstmt:
mov $blocks,blockp
jsr r5,isagn
br 1f
mov r1,r2
jsr r5,lookup; stmtab1
br 2f
mov r2,r1
cmp r0,$4 / don't allow end
beq 2f
jmp *sublst1(r0)
1:
jmp sasgn
2:
jsr r5,error; 101.
rts r5
send:
tst dotabp
beq 1f
clr r0
jsr r5,doend
br send
1:
tst progt
bne 1f
jsr r5,sstop
br 2f
1:
cmp progt,$6 / block data
beq 2f
jsr r5,sretu
2:
jsr r5,perror
jsr r5,signoff; 3
sublst:
sdo
sublst1:
sif
sendf
send
sassi
scall
scont
sretu
sgoto
spaus
sstop
sread
sprin
swrit
srewi
sback
fmtlst:
sform
sdata
stmtab:
<do\0>
stmtab1:
<if(\0>
<endfile\0>
<end\0> / keep in this spot!!!
<assign\0>
<call\0>
<continue\0>
<return\0>
<goto\0>
<pause\0>
<stop\0>
<read\0>
<print\0>
<write\0>
<rewind\0>
<backspace\0>
<\0>
fmttab:
<format\0>
<data\0>
<\0>
.even
source/fort/f3/f32.s
+227
View File
@@ -0,0 +1,227 @@
/
/
/ f32 -- expression to tree
.globl e1
.globl e2
.globl e11
.globl error
.globl getsym
.globl blockp
.globl blocks
.globl declimpl
.globl conu
.globl ptemp
.globl functn
.globl funimpl
/ e1: e2[,e1]
/ e2: e2[.or.e3]
/ e3: e3[.and.e4]
/ e4: [.not.]e5
/ e5: e6[.rel.e6]
/ e6: [+-]e7[+-e6]
/ e7: e7[*/e8]
/ e8: e9[**e9]
/ e9: constant
/ name[(e1)]
/ (e2)
e1:
jsr r5,e2
cmp r0,$36. / ,
bne 1f
jsr r5,block; e1
rts r5
e2:
jsr r5,e3
2:
cmp r0,$30. / or
bne 1f
jsr r5,block; e3
br 2b
e3:
jsr r5,e4
2:
cmp r0,$28. / and
bne 1f
jsr r5,block; e4
br 2b
e4:
jsr r5,getsym
cmp r0,$26. / not
bne e5
clr r2
jsr r5,block; e5a
rts r5
e5a:
jsr r5,getsym
e5:
jsr r5,e6
cmp r0,$14. / .lt.
blo 1f
cmp r0,$24. / .ge.
bhi 1f
jsr r5,block; e6a
rts r5
e6a:
jsr r5,getsym
e6:
cmp r0,$12. / +
beq e6a
cmp r0,$10. / -
bne 2f
clr r2
jsr r5,block; e7a
br 3f
2:
jsr r5,e7
3:
cmp r0,$10. / -
blo 1f
cmp r0,$12. / +
bhi 1f
jsr r5,block; e7a
br 3b
e7a:
jsr r5,getsym
e7:
jsr r5,e8
2:
cmp r0,$6. / /
blo 1f
cmp r0,$8. / *
bhi 1f
jsr r5,block; e8a
br 2b
e8a:
jsr r5,getsym
e8:
jsr r5,e9
cmp r0,$4 / **
bne 1f
jsr r5,block; e9a
1:
rts r5
e9a:
jsr r5,getsym
e9:
cmp r0,$2 / constant
beq 3f
/ (e2)
cmp r0,$32. / (
bne 1f
jsr r5,e2
br 2f
e10:
jsr r5,e1
2:
cmp r0,$34. / )
beq 2f
jsr r5,error; 29.
rts r5
2:
jsr r5,getsym
rts r5
1:
tst r0
beq e11
/ unknown
jsr r5,error; 30.
rts r5
/ name
e11:
mov r3,r2
jsr r5,getsym
cmp r0,$32. / (
bne 1f
jsr r5,appl
jsr r5,block; e10
rts r5
1:
mov r2,r3
mov r0,-(sp)
jsr r5,declimpl
mov symtab(r3),r0
bic $!70,r0
cmp r0,$30 / class =| funct
bne 1f
jsr r5,appl
mov $42.,r3 / just function name
br 2f
1:
clr r3
2:
mov (sp)+,r0
mov r2,-(sp)
mov blockp,r2
add $6,blockp
mov r3,(r2)
mov (sp)+,2(r2)
clr 4(r2)
rts r5
/ number
3:
mov blockp,r2
add $6,blockp
mov r0,(r2)
mov r3,2(r2)
cmpb 2(r2),$5 / const->int
bne 4f
movb $1,2(r2)
4:
mov r3,temp
mov conu,4(r2)
inc conu
jsr r5,ptemp; 'c; temp; symbuf
jsr r5,getsym
rts r5
appl:
clr functn
bit $70,symtab(r2) / class
bne 1f
bis $30,symtab(r2)
jsr r5,funimpl
1:
mov r2,r3
jsr r5,declimpl
mov symtab(r2),r0
bic $!70,r0 / class again
cmp r0,$20 / array
beq 1f
cmp r0,$30 / funct
beq 2f
jsr r5,error; 33.
bic $70,symtab(r2)
br appl
1:
mov $32.,r0
rts r5
2:
mov $34.,r0
rts r5
block:
mov blockp,r3
add $6,blockp
mov r0,(r3)+
mov r2,(r3)+
mov r3,-(sp)
jsr r5,*(r5)+
mov r2,*(sp)
mov (sp)+,r2
sub $4,r2
rts r5
source/fort/f3/f33.s
+143
View File
@@ -0,0 +1,143 @@
/
/
/ f33 -- do, etal
.globl sdo
.globl dobeg
.globl doend
.globl getlab
.globl e2
.globl error
.globl lvalue
.globl rvalue
.globl code
.globl convrt
.globl dou
.globl dotabp
.globl edotab
.globl dotab
sdo:
jsr r5,getlab
br 9f
jsr r5,dobeg
cmp r0,$40.
bne 9f
rts r5
7:
tst (sp)+
8:
tst (sp)+
9:
jsr r5,error; 42.
rts r5
dobeg:
mov dotabp,r2
cmp r2,$edotab
blo 1f
jsr r5,error; 44.
rts r5
1:
mov dou,dotab(r2)
inc dou
mov r0,dotab+2(r2)
add $4,dotabp
jsr r5,e2
cmp r0,$38. / =
bne 9b
mov r2,-(sp)
jsr r5,lvalue
mov r3,-(sp)
bic $!7,r3
cmp r3,$1 / integer
bne 7b
jsr r5,e2
cmp r0,$36. / ,
bne 7b
jsr r5,rvalue
mov (sp),r2
jsr r5,convrt
mov (sp),r3
clrb r3
swab r3
jsr r5,code
< gas%d\n goto; 2f\n\0>; .even
r3
mov dotabp,r2
mov dotab-4(r2),r0
jsr r5,code
<t%d:\n\0>; .even
r0
mov (sp)+,r3
mov (sp)+,r2
mov r0,-(sp)
mov r3,-(sp)
jsr r5,lvalue
jsr r5,e2
mov r0,-(sp)
jsr r5,rvalue
mov 2(sp),r2
jsr r5,convrt
cmp (sp)+,$36. / ,
bne 1f
jsr r5,e2
mov r0,-(sp)
jsr r5,rvalue
mov 2(sp),r2
jsr r5,convrt
mov (sp)+,r0
jsr r5,code
< do2\0>; .even
br 2f
1:
jsr r5,code
< do1\0>; .even
2:
mov (sp)+,r3
clrb r3
swab r3
mov (sp)+,r2
jsr r5,code
<%d; o%d\n2:\n\0>; .even
r3
r2
rts r5
doend:
tst r0
bne 1f
jsr pc,gen
rts r5
1:
clr r2
1:
cmp r2,dotabp
bhis 1f
add $4,r2
cmp r0,dotab-2(r2)
bne 1b
jsr pc,gen
br doend
1:
rts r5
gen:
mov r0,-(sp)
mov dotabp,r2
cmp r0,dotab-2(r2)
beq 1f
jsr r5,error; 43.
1:
mov dotab-4(r2),r0
sub $4,dotabp
jsr r5,code
< goto; t%d\no%d:\n\0>; .even
r0
r0
mov (sp)+,r0
rts pc
source/fort/f3/f34.s
+65
View File
@@ -0,0 +1,65 @@
/
/
/ f34 -- if statement
.globl sif
.globl e2
.globl error
.globl rvalue
.globl code
.globl ifstmt
.globl iserror
.globl getsym
.globl geti
.globl genop
.globl getlab
.globl newline
sif:
jsr r5,e2 / expression
jsr r5,iserror
br 9f
cmp r0,$34. / )
bne 9f
jsr r5,rvalue
mov $"if,r0
jsr r5,genop
bic $!7,r3
cmp r3,$3 / logical
bne 1f
jsr r5,code
<; 1f\n\0>; .even
jsr r5,ifstmt
jsr r5,code
<1:\n\0>; .even
rts r5
1:
mov $3,-(sp)
1:
jsr r5,getlab
br 8f
jsr r5,code
<; .%d\0>; .even
r0
dec (sp)
beq 1f
jsr r5,getsym
cmp r0,$36.
beq 1b
8:
tst (sp)+
br 9f
1:
tst (sp)+
jsr r5,newline
jsr r5,getsym
cmp r0,$40.
bne 9f
rts r5
9:
jsr r5,error; 40.
rts r5
source/fort/f3/f35.s
+87
View File
@@ -0,0 +1,87 @@
/
/
/ f35 -- assignment statement
.globl sasgn
.globl sassi
.globl error
.globl e2
.globl lvalue
.globl rvalue
.globl code
.globl convrt
.globl geti
.globl getsym
.globl getlab
.globl genop
.globl newline
.globl name
sasgn:
jsr r5,e2
cmp r0,$38. / =
bne 9f
mov r2,-(sp)
jsr r5,e2
cmp r0,$40. / =|
bne 8f
tst *(sp)
bne 1f / too hard for simple as
jsr r5,rvalue
mov (sp)+,r2
mov 2(r2),r2
mov r2,-(sp)
mov symtab(r2),r2
jsr r5,convrt
mov r2,r3
bis $7,r3
mov $"mv,r0
jsr r5,genop
mov (sp)+,r3
jsr r5,name
rts r5
1:
mov r2,r3
mov (sp)+,r2
mov r3,-(sp)
jsr r5,lvalue
mov (sp)+,r2
mov r3,-(sp)
jsr r5,rvalue
1:
mov (sp)+,r2
jsr r5,convrt
mov r2,r3
bis $7,r3 / type 'g'
mov $"as,r0
jsr r5,genop
jsr r5,newline
rts r5
sassi:
jsr r5,getlab
br 9f
mov r0,-(sp)
cmpb (r1)+,$'t
bne 8f
cmpb (r1)+,$'o
bne 8f
jsr r5,e2
cmp r0,$40. / =|
bne 8f
jsr r5,lvalue
mov (sp)+,r0
mov r3,-(sp)
jsr r5,code
< lval; .%d\n\0>; .even
r0
mov $int2con,r3
br 1b
8:
tst (sp)+
9:
jsr r5,error; 39.
rts r5
source/fort/f3/f36.s
+467
View File
@@ -0,0 +1,467 @@
/
/
/ f36 -- expression code generation
.globl lvalue
.globl rvalue
.globl convrt
.globl type
.globl funcappl
.globl name
.globl error
.globl lookup
.globl code
.globl iserror
.globl genop
.globl typ
.globl newline
.globl functn
.globl size
lvalue:
jsr r5,iserror
rts r5
tst (r2)
bne 1f
mov 2(r2),r3
jsr r5,code
< lval>; .even
br name
1:
mov r2,-(sp)
cmp (r2),$32. / array appl
bne 1f
jsr r5,aryappl
dec r0
bne 2f / dim =| 1
tstb symtab(r3)
blt 2f / p-bit, not simple
mov $"al,r0
br simpary
2:
jsr r5,code
< alval\0>; .even
arydope:
jsr r5,pbit
mov symtab+2(r3),r2
mov (r2)+,r0
asl r0
add r0,r2
mov (r2),r0
jsr r5,code
<; d%d\0>; .even
r0
br 2f
1:
jsr r5,error; 54.
mov (sp)+,r2
rts r5
simpary:
mov r3,-(sp)
mov symtab(r3),r3
bis $7,r3
jsr r5,genop
mov (sp)+,r3
jsr r5,size
jsr r5,code
<; %d.\0>; .even
r0
br 2f
name:
mov r2,-(sp)
jsr r5,pbit
2:
jsr r5,code
<; \0>; .even
bit $100,symtab(r3) / common
beq 1f
mov symtab+4(r3),r2
jsr r5,code
<%n+\0>; .even
r2
1:
movb symtab(r3),r2
bic $!70,r2
cmp r2,$30 / external
bne 1f
jsr r5,code
<%n.\n\0>; .even
r3
br 2f
1:
jsr r5,code
<%n_\n\0>; .even
r3
2:
mov symtab(r3),r3
mov (sp)+,r2
rts r5
rvalue:
jsr r5,iserror
rts r5
mov r2,-(sp)
tst (r2)
bne 1f
mov 2(r2),r3
movb symtab+1(r3),r2
jsr r5,code
< rval%d>; .even
r2
mov (sp)+,r2
br name
1:
cmp (r2),$32.
bne 1f
jsr r5,aryappl
dec r0
bne 3f
tstb symtab(r3)
blt 3f
mov $"ar,r0
br simpary
3:
jsr r5,code
< arval\0>; .even
br arydope
1:
cmp (r2),$34. / array appl
bne 1f
jsr r5,funcappl
mov (sp)+,r2
mov 2(r2),r3
movb symtab+1(r3),r0
jsr r5,code
<%d.\n\0>; .even
r0
mov symtab(r3),r3
rts r5
1:
cmp (r2),$2
bne 1f
movb 3(r2),r3
mov 4(r2),r2
jsr r5,code
< rval%d; c%d\n\0>; .even
r3
r2
mov (sp)+,r2
mov 2(r2),r3
rts r5
1:
cmp (r2),$24. / arith or relat
bhi 1f
mov 2(r2),r2
bne 3f
mov (sp),r2
sub $10.,(r2) / - bin -> - unary
mov 4(r2),r2
jsr r5,rvalue
br 2f
3:
jsr r5,rvalue
mov (sp),r2
mov r3,-(sp)
mov 4(r2),r2
jsr r5,type
cmp *2(sp),$4 / **
bne 3f
mov r3,r2
bic $!7,r2
cmp r2,$1 / ** integer
bne 3f
mov 2(sp),r2
sub $2,(r2) / pr -> pi
mov 4(r2),r2
jsr r5,rvalue
mov $intcon,r2
jsr r5,convrt
mov (sp)+,r3
br 2f
3:
mov (sp),r2
jsr pc,maxtyp
mov (sp)+,r3
mov r2,-(sp)
jsr r5,convrt
mov 2(sp),r2
mov 4(r2),r2
jsr r5,rvalue
mov (sp)+,r2
jsr r5,convrt
mov r2,r3
br 2f
1:
cmp (r2),$30. / and or not
bhi 1f
mov 2(r2),r2
beq 3f
jsr r5,rvalue
mov $logcon,r2
jsr r5,convrt
3:
mov (sp),r2
mov 4(r2),r2
jsr r5,rvalue
mov $logcon,r2
jsr r5,convrt
2:
mov (sp)+,r2
mov (r2),r0
cmp r0,$4
bhis 2f
add $10.,(r2) / back to binary
tst r0
beq 2f
sub $8,(r2) / back to pr
2:
mov optab(r0),r0
jsr r5,genop
jsr r5,newline
cmp (r2),$14. / relat
blo 2f
mov $logcon,r3
2:
rts r5
1:
jsr r5,error; 54.
mov (sp)+,r2
rts r5
pbit:
tstb symtab(r3)
bge 1f
jsr r5,code
<p\0>
1:
rts r5
funcappl:
mov r2,-(sp)
mov functn,r3
jsr r5,code
< stsp; ft+%d.\n\0>; .even
r3
mov r3,-(sp)
add $2,r3
mov r3,functn
clr -(sp) / nargs
1:
mov 4(r2),r2
beq 2f
inc (sp)
cmp (r2),$36. / ,
bne 1f
mov r2,-(sp)
mov 2(r2),r2
mov 6(sp),r3
jsr r5,fapp1
mov (sp)+,r2
br 1b
1:
mov 4(sp),r3
jsr r5,fapp1
2:
mov (sp)+,r0 / nargs
mov (sp)+,r2
mov (sp)+,r3
mov 2(r3),r3
jsr r5,code
< call\0>; .even
jsr r5,pbit
jsr r5,code
<; %n.; ft+%d.; %d.; \0>; .even
r3
r2
r0
cmp functn,functm
ble 1f
mov functn,functm
1:
mov r2,functn
rts r5
fapp1:
mov 2(r3),r3 / fetch out function name
mov symtab+2(r3),r3 / arg conversion
bne 2f
tst (r2)
beq 1f
cmp (r2),$32.
beq 4f
cmp (r2),$42. / lv if funct or name or arry app
beq 1f
cmp (r2),$2 / lv if const
bne 2f
mov 4(r2),r3
jsr r5,code
< lval; c%d\n\0>
r3
br 3f
2:
mov r3,-(sp)
jsr r5,rvalue
mov (sp)+,r2
beq 2f
jsr r5,convrt
2:
mov functn,r3
jsr r5,code
< stsp; ft+%d.\n\0>; .even
r3
add $2,functn
rts r5
1:
clr (r2) / turn func/array names into lvs
4:
jsr r5,lvalue
3:
mov functn,r3
jsr r5,code
< stst; ft+%d.\n\0>; .even
r3
add $2,functn
rts r5
aryappl:
mov r2,-(sp)
clr -(sp) / arg count
2:
inc (sp)
mov 4(r2),r2
cmp (r2),$36. / ,
bne 2f
mov r2,-(sp)
mov 2(r2),r2
jsr r5,rvalue
mov $intcon,r2
jsr r5,convrt
mov (sp)+,r2
br 2b
2:
jsr r5,rvalue
mov $intcon,r2
jsr r5,convrt
mov (sp)+,r0
mov (sp)+,r2
mov 2(r2),r3
cmp r0,*symtab+2(r3)
beq 1f
jsr r5,error; 53. / dimension mismatch
1:
rts r5
/ converts stack from type in r3 to type in r2
convrt:
mov r2,-(sp)
mov r3,-(sp)
bic $![377\<8+7],r2
bic $![377\<8+7],r3
cmp r2,r3
beq 1f
jsr r5,code
< \0>; .even
jsr pc,2f
mov r2,r3
jsr pc,2f
jsr r5,code
<\n\0>; .even
1:
mov (sp)+,r3
mov (sp)+,r2
rts r5
2:
mov r2,-(sp)
mov r3,r2
clrb r3
swab r3
bic $!7,r2
movb typ(r2),r2
jsr r5,code
<%c%d\0>; .even
r2
r3
mov (sp)+,r2
rts pc
type:
cmp (r2),$32.
beq 2f
cmp (r2),$34.
beq 2f
tst (r2)
bne 1f
2:
mov 2(r2),r3
mov symtab(r3),r3
rts r5
1:
cmp (r2),$2
bne 1f
mov 2(r2),r3
rts r5
1:
cmp (r2),$14.
blo 1f
mov $logcon,r3
rts r5
1:
mov r2,-(sp)
mov 2(r2),r2
bne 1f
mov (sp),r2
mov 4(r2),r2
jsr r5,type
br 2f
1:
jsr r5,type
mov (sp),r2
mov r3,-(sp)
mov 4(r2),r2
jsr r5,type
mov (sp)+,r2
jsr pc,maxtyp
mov r2,r3
2:
mov (sp)+,r2
rts r5
maxtyp:
mov r2,r0
cmp r2,r3
bhis 2f
mov r3,r2
2:
clrb r2
bic $!7,r0
bic $!7,r3
cmp r0,r3
bhis 2f
mov r3,r0
2:
bis r0,r2
rts pc
optab:
<ng>
<pi>
<pr>
<dv>
<mp>
<sb>
<ad>
<lt>
<le>
<eq>
<ne>
<gt>
<ge>
<nt>
<an>
<or>
source/fort/f3/f37.s
+96
View File
@@ -0,0 +1,96 @@
/
/
/ f37 -- goto statements of all kinds
.globl sgoto
.globl intexp
.globl e2
.globl code
.globl getsym
.globl error
.globl getlab
.globl rvalue
.globl convrt
.globl chrtab
sgoto:
movb (r1),r0
cmpb chrtab(r0),$4 / test digit
bne 1f / not constant
jsr r5,getlab
br 8f
jsr r5,code
< goto; .%d\n\0>; .even
r0
br 9f
1:
cmpb (r1),$'(
beq 1f
jsr r5,intexp
cmp r0,$36. / ,
beq 2f
jsr r5,code
< agoto\n\0>; .even
br 9f
2:
jsr r5,code
< cagoto\n\0>; .even
cmpb (r1)+,$'(
bne 8f / syntax
jsr pc,stmlist
br 9f
1:
mov r1,r4
1:
movb (r1)+,r0
beq 8f
cmp r0,$')
bne 1b
cmpb (r1)+,$',
bne 8f
jsr r5,intexp
mov r1,-(sp)
jsr r5,code
< cgoto\n\0>; .even
mov r4,r1
tstb (r1)+
jsr pc,stmlist
mov (sp)+,r1
9:
tstb (r1)
beq 1f
8:
jsr r5,error; 35.
1:
rts r5
stmlist:
jsr r5,getlab
br 9f
jsr r5,code
< .%d\n\0>; .even
r0
movb (r1)+,r0
cmp r0,$',
beq stmlist
cmp r0,$')
bne 8f
jsr r5,code
< 0\n\0>; .even
rts pc
8:
jsr r5,error; 35.
9:
rts pc
intexp:
jsr r5,e2
mov r0,-(sp)
jsr r5,rvalue
mov $intcon,r2
jsr r5,convrt
mov (sp)+,r0
rts r5
source/fort/f3/f38.s
+95
View File
@@ -0,0 +1,95 @@
/
/
/ f38 -- wierdo statements
.globl sstop
.globl scall
.globl spaus
.globl sretu
.globl scont
.globl iserror
.globl ptemp
.globl code
.globl geti
.globl getsym
.globl error
.globl declimpl
.globl e11
.globl funcappl
sstop:
clr r0
tstb (r1)
beq 1f
jsr r5,getsym
cmp r0,$2. / const
bne 7f
cmp r3,$intcon
bne 7f
jsr r5,geti
1:
jsr r5,code
< stop; %d\n\0>; .even
r0
br 8f
spaus:
jsr r5,getsym
cmp r0,$2
bne 7f
cmp r3,$intcon
bne 7f
jsr r5,geti
jsr r5,code
< paus; %d\n\0>; .even
r0
br 8f
sretu:
tst progt
bne 1f
jsr r5,error; 37. / return in main
br sstop
1:
jsr r5,code
< retrn\n\0>; .even
8:
scont:
tstb (r1)
bne 7f
rts r5
7:
jsr r5,error; 38.
rts r5
iserror:
cmp errp,$errb
bne 1f
tst (r5)+
1:
rts r5
scall:
jsr r5,getsym
tst r0
bne 7b
bit $70,symtab(r3)
bne 1f
bis $30,symtab(r3)
1:
jsr r5,declimpl
jsr r5,e11
cmp r0,$40.
bne 7b
cmp (r2),$34.
beq 1f
cmp (r2),$42.
bne 7b
1:
jsr r5,funcappl
jsr r5,code
<0\n\0>; .even
br 8b
source/fort/f3/f39.s
+258
View File
@@ -0,0 +1,258 @@
/
/
/ f39 -- i/o statements
.globl sread
.globl swrit
.globl sprin
.globl sback
.globl srewi
.globl sendf
.globl getsym
.globl error
.globl geticon
.globl e2
.globl lvalue
.globl rvalue
.globl iserror
.globl convrt
.globl code
.globl chrtab
.globl blocks
.globl blockp
.globl doend
.globl genop
.globl levzer
.globl dobeg
.globl intexp
.globl ptemp
.globl blocks
.globl blockp
.globl intexp
.globl newline
.globl nelem
sprin:
mov $8.,-(sp)
jsr r5,getfmt
br 9f
cmp r0,$36. / ,
beq 1f
cmp r0,$40. / =|
bne 8f
clrb (r1)
1:
mov $34.,r0 / simulate )
br 2f
sread:
mov $2,-(sp)
br 1f
swrit:
clr -(sp)
1:
cmpb (r1)+,$'(
bne 8f
jsr r5,intexp
mov $blocks,blockp
cmp r0,$34. / ), implies unformatted
beq 2f
cmp r0,$36. / ,
bne 8f
jsr r5,getfmt
br 9f
add $4,(sp)
cmp r0,$34. / )
bne 8f
2:
mov (sp),r0
mov iotype(r0),r0
jsr r5,code
< %s\n\0>; .even
r0
1:
tstb (r1)
beq 9f
1:
jsr r5,list
cmp r0,$40. / |=
beq 9f
8:
jsr r5,error; 41.
9:
jsr r5,code
< endio\n\0>; .even
tst (sp)+
rts r5
iotype:
1f
2f
3f
4f
5f
1:
<iowu\0>
2:
<ioru\0>
3:
<iowf\0>
4:
<iorf\0>
5:
<iowp\0>
.even
getfmt:
movb (r1),r0
cmpb chrtab(r0),$4 / digit
beq 1f
jsr r5,e2
jsr r5,iserror
rts r5
mov r0,-(sp)
jsr r5,lvalue
mov $blocks,blockp
br 8f
1:
jsr r5,geticon
br 8f
mov r0,temp
jsr r5,ptemp; 'i; temp; line / register use of format
jsr r5,code
< lval; .%d\n\0>; .even
r0
jsr r5,getsym
mov r0,-(sp)
8:
mov (sp)+,r0
tst (r5)+
rts r5
list:
jsr r5,lstitm
cmp r0,$36. / ,
beq list
rts r5
lstitm:
mov $blocks,blockp
cmpb (r1),$'( / test for sublist
beq 1f
jsr r5,e2
jsr r5,iserror
rts r5
mov r0,-(sp)
clr -(sp)
tst (r2)
bne 2f / test for name
mov 2(r2),r3
mov symtab(r3),r0
bic $!70,r0
cmp r0,$20 / test for short list
bne 2f
mov pc,(sp)
mov symtab+2(r3),r3
mov (r3)+,-(sp)
asl (sp)
add (sp)+,r3
mov (r3),r3
jsr r5,code
< slist1; d%d\n2:\0>; .even
r3
2:
jsr r5,lvalue
tst (sp)
beq 3f
jsr r5,code
< slist3\n\0>; .even
3:
mov $"io,r0
jsr r5,genop
tst (sp)+
beq 2f
jsr r5,code
<\n slist2; 2b\0>; .even
2:
jsr r5,newline
mov (sp)+,r0
rts r5
1:
inc r1
jsr r5,levzer; '=
br 1f / yes, implied do
jsr r5,list
jsr r5,chkel
jsr r5,getsym
rts r5
1:
cmp r1,r0
bhis 8f
cmpb -(r0),$', / look backwards
bne 1b
mov r0,-(sp)
mov r1,-(sp)
movb $'),(r0) / fake!!
mov r0,r1
inc r1
clr r0
jsr r5,dobeg / get do
jsr r5,chkel
mov (sp)+,r0
mov r1,-(sp)
mov r0,r1
jsr r5,list
jsr r5,chkel
clr r0
jsr r5,doend
mov (sp)+,r1
movb $',,*(sp)+ / unfake!!
jsr r5,getsym
rts r5
chkel:
cmp r0,$34. / )
beq 1f
8:
jsr r5,error; 41.
1:
rts r5
sback:
mov $bksp,r2
br 1f
srewi:
mov $rewi,r2
br 1f
sendf:
mov $enfl,r2
1:
mov r2,-(sp)
jsr r5,intexp
mov (sp),r2
jsr r5,code
< %s\n\0>; .even
r2
cmp r0,$40. / =|
beq 9f
8:
jsr r5,error; 41.
9:
tst (sp)+
rts r5
bksp:
<bksp\0>
rewi:
<rewi\0>
enfl:
<enfl\0>
source/fort/f4/f41.s
+40
View File
@@ -0,0 +1,40 @@
/
/
/ f41 -- everything else
.globl pass4
.globl signon
.globl flush
.globl dope
.globl formts
.globl globls
.globl constn
.globl fopen
.globl bsss
.globl tfil2
pass4:
setd
jsr r5,signon; 4
mov ibuf,r0
sys close
jsr r5,flush; obuf
jsr r5,flush; tbuf
jsr r5,dope
jsr r5,formts
jsr r5,constn
jsr r5,bsss
jsr r5,globls / uses r4 from bsss
jsr r5,flush; obuf
sys unlink; tfil2
clr r0
tst nerror
beq 1f
sys seek; 0; 2
mov $1,r0 / syntax errors
1:
sys exit
source/fort/f4/f42.s
+97
View File
@@ -0,0 +1,97 @@
/
/
/ 42 -- definition
.globl bsss
.globl code
.globl size
.globl declimpl
.globl cdata
.globl dodata
.globl dattab
bsss:
jsr r5,cdata
cmp progt,$6 / test block common
bne 1f
rts r5
1:
jsr r5,code
<.bss\n\0>; .even
mov functm,r3
beq 1f
jsr r5,code
<ft: .=.+%d.\n\0>; .even
r3
1:
cmp r4,$dattab / any data?
beq 1f
jsr r5,code
<.data\n\0>; .even
1:
jsr r5,code
<base:\n\0>; .even
clr r3
1:
cmp r3,symtp
bhis pass2
bit $70,symtab(r3) / test classed
bne 2f
jsr r5,declimpl
2:
mov symtab(r3),r0
mov symtab+6(r3),r2
bic $!70,r0 / class
cmp r0,$10 / simple
beq 1f
cmp r0,$20 / array
beq 1f
cmp r0,$30 / extrn
bne 2f
bit $200,symtab(r3) / param
beq 2f
jsr r5,code
<%n. = %d.\n\0>; .even
r3
r2
2:
cmp r0,$40 / common block
bne 2f
mov symtab+6(r3),r2 / size
beq 2f
jsr r5,code
<.comm %n,%d.\n\0>; .even
r3
r2
2:
add $8,r3
br 1b
1:
bit $300,symtab(r3)
beq 1f
jsr r5,code
<%n_ = %d.\n\0>; .even
r3
r2
br 2b
1:
tst r2
bne 1f
jsr r5,size
mov nxtaloc,r2
mov r2,symtab+6(r3)
add r0,nxtaloc
1:
jsr r5,code
<%n_ = base+%d.\n\0>; .even
r3
r2
br 2b
pass2:
jsr r5,dodata
rts r5
source/fort/f4/f43.s
+83
View File
@@ -0,0 +1,83 @@
/
/
/ f43 -- output globals and bdata bss's
.globl globls
.globl code
.globl dattab
.globl onedata
.globl error
.globl perror
globls:
mov progt,r0
jmp *1f(r0)
1:
1f
2f
3f
4f
1:
jsr r5,code
<.globl main\n\0>; .even
rts r5
2:
3:
jsr r5,code
<.globl %n.\n\0>; .even
8
rts r5
4:
1:
clr r3
1:
cmp r3,symtp
blo 2f
rts r5
2:
mov symtab(r3),r0
bic $!270,r0
cmp r0,$40 / common block
bne 2f
mov symtab+6(r3),r2
beq 2f
mov $dattab,r1
3:
cmp r1,r4
bhis 3f
cmp (r1),r3
beq 4f
add $8.,r1
br 3b
3:
jsr r5,code
<.bss\n.globl %n\n%n: .=.+%d.\n.text\n\0>; .even
r3
r3
r2
br 2f
4:
jsr r5,code
<.data\n.globl %n\n%n:\n\0>; .even
r3
r3
mov r2,-(sp)
mov r3,-(sp)
mov r1,r3
jsr r5,onedata
mov (sp)+,r3
mov (sp)+,r2
sub r1,r2
bge 9f
jsr r5,error; 22. / data overrun
jsr r5,perror
9:
jsr r5,code
<.=.+%d.\n.text\n\0>; .even
r2
2:
add $8,r3
br 1b
source/fort/f4/f44.s
+110
View File
@@ -0,0 +1,110 @@
/
/
/ f44 -- formats
.globl formts
.globl strout
.globl setln
.globl getln
.globl code
.globl error
.globl perror
.globl putc
.globl xbuf
formts:
jsr r5,setln
mov $2,r3
clr xbuf+518. / pick up zero efn formats
1:
jsr r5,getln
br 1f
cmp r0,$'s
beq 2f
cmp r0,$'f
bne 1b
mov efno,r0
jsr r5,code
<.%d: <\0>; .even
r0
mov $line+6,r1
jsr r5,strout
mov efno,r0
neg r0
br 3f
2:
mov efno,r0
3:
clr r2
2:
cmp r2,r3
bhis 2f
cmp r0,xbuf+518.(r2)
beq 3f
neg r0
cmp r0,xbuf+518.(r2)
beq 3f
add $2,r2
neg r0
br 2b
3:
jsr r5,error; 51.
jsr r5,perror
2:
mov r0,xbuf+518.(r3)
add $2,r3
br 1b
1:
jsr r5,code
< .even\n>; .even
jsr r5,setln
1:
jsr r5,getln
br 1f
cmp r0,$'r
beq 2f
cmp r0,$'i
bne 1b
mov efno,r0
neg r0
br 3f
2:
mov efno,r0
3:
mov $2,r2 / not zero
2:
cmp r2,r3
bhis 2f
cmp r0,xbuf+518.(r2)
beq 1b
add $2,r2
br 2b
2:
jsr r5,error; 52.
jsr r5,perror
br 1b
1:
rts r5
strout:
movb (r1)+,r0
beq 3f
cmp r0,$'>
beq 4f
cmp r0,$'\\
bne 5f
4:
mov r0,-(sp)
mov $'\\,r0
jsr r5,putc; obuf
mov (sp)+,r0
5:
jsr r5,putc; obuf
br strout
3:
jsr r5,code
<\\0\>\n\0>; .even
rts r5
source/fort/f4/f45.s
+144
View File
@@ -0,0 +1,144 @@
/
/
/ f45 -- constant pool
.globl constn
.globl evalcon
.globl error
.globl perror
.globl code
.globl getcon
.globl setln
.globl getln
.globl xbuf
.globl symbuf
.globl negflg
constn:
jsr r5,setln
mov $xbuf+518.,r3 / pool max pointer
mov $ibuf+518.,r4 / pool pointer pointer
1:
jsr r5,getln
br 1f
cmp r0,$'c
bne 1b
jsr r5,packcon
mov r2,-(r4) / put p ptr in p p ptr
cmp r3,r4
blo 1b
jsr r5,error; 99.
jsr r5,perror
1:
mov $xbuf+518.,r2
1:
cmp r2,r3
bhis 1f
mov $ibuf+518.,r1
2:
cmp r1,r4
blo 2f
cmp -(r1),r2
bne 2b
mov r1,r0
sub $ibuf+516.,r0
asr r0
neg r0
jsr r5,code
<c%d:\n\0>; .even
r0
br 2b
2:
mov (r2)+,r0
jsr r5,code
< %o\n\0>; .even
r0
br 1b
1:
rts r5
packcon:
mov $line,r1
jsr r5,evalcon
mov r1,-(sp)
mov r3,-(sp)
sub r2,(sp)
asr (sp)
mov r2,-(sp)
mov $xbuf+518.,r2
1:
mov (sp),r3
mov r2,r1
tst (r2)+
mov 2(sp),r0
2:
cmp (r1)+,(r3)+
bne 1b
dec r0
bgt 2b
tst -(r2)
mov (sp)+,r3
asl (sp)
add r2,(sp)
cmp (sp),r3
blos 1f
mov (sp),r3 / eureka
1:
tst (sp)+
mov (sp)+,r1
rts r5
evalcon:
cmpb efno,$5
bne 2f
movb efno+1,r0
mov r3,r2
br 1f
2:
jsr r5,getcon
tst negflg
beq 2f
negf fr0
negf fr1
2:
mov r3,r2
mov efno,r0
mov r0,r1
clrb r0
swab r0
bic $!7,r1
cmpb r1,$realcon
beq 3f
cmpb r1,$cplxcon
beq 2f
setl
movfi r0,symbuf+1
seti
mov $symbuf+5,r1
sub r0,r1
br 1f
2:
mov $symbuf+1,r1
movf fr1,symbuf+1
cmp r0,$8
beq 2f
movf fr0,symbuf+9.
br 1f
2:
movf fr0,symbuf+5
br 1f
3:
movf fr0,symbuf+1
mov $symbuf+1,r1
1:
movb (r1)+,(r3)+
dec r0
bgt 1b
bit $1,r3
beq 1f
clrb (r3)+
1:
rts r5
source/fort/f4/f46.s
+166
View File
@@ -0,0 +1,166 @@
/
/
/ f46 -- constant evaluation
.globl getcon
.globl dope
.globl code
getcon:
mov r0,-(sp)
mov r2,-(sp)
clr r2 / dec . counter
clrf fr0
movif $10.,fr1
clr -(sp) / - flag
cmpb (r1)+,$'+
beq 1f
cmpb -(r1),$'-
bne 1f
inc r1
inc (sp)
1:
movb (r1)+,r0
sub $'0,r0
cmp r0,$9
blos 2f
cmp r0,$'.-'0
bne 1f
dec r2
br 1b
2:
tst r2
beq 2f
dec r2
2:
mulf fr1,fr0
movif r0,fr2
addf fr2,fr0
br 1b
1:
tst r2
bne 1f
dec r2
1:
cmp r0,$'e-'0
beq 2f
cmp r0,$'d-'0
bne 1f
2:
mov r3,-(sp)
clr r3
clr -(sp)
cmpb (r1),$'-
bne 3f
inc r1
inc (sp)
br 2f
3:
cmpb (r1),$'+
bne 2f
inc r1
2:
movb (r1)+,r0
sub $'0,r0
cmp r0,$9
bhi 2f
mpy $10.,r3
add r0,r3
br 2b
2:
tst (sp)+
beq 2f
neg r3
2:
add r3,r2
mov (sp)+,r3
1:
movf fr1,fr2
add $1,r2
beq 1f
blt 2f
clr -(sp)
br 3f
2:
mov pc,-(sp)
neg r2
3:
sub $1,r2
ble 2f
mulf fr1,fr2
br 3b
2:
tst (sp)+
bne 2f
mulf fr2,fr0
br 1f
2:
divf fr2,fr0
1:
tst (sp)+
beq 1f
negf fr0
1:
cmpb -(r1),$',
bne 1f
movf fr0,-(sp)
inc r1
jsr r5,getcon
movf (sp)+,fr1 / a,b -> r1,r0
1:
mov (sp)+,r2
mov (sp)+,r0
rts r5
dope:
cmp progt,$6 / test "block data"
bne 1f
rts r5
1:
clr r3
1:
cmp r3,symtp
bhis 1f
mov symtab(r3),r0
bic $!70,r0
cmp r0,$20
bne 2f
mov symtab+2(r3),r0
beq 2f
mov (r0)+,r1
mov r1,r2
asl r2
add r0,r2
mov (r2),r0
jsr r5,code
<d%d: %d.\n \0>; .even
r0
r1
3:
dec r1
blt 3f
mov -(r2),r0
bge 4f
jsr r5,code
<..; \0>; .even
br 3b
4:
jsr r5,code
<%d.; \0>; .even
r0
br 3b
3:
mov symtab(r3),r2
clrb r2
swab r2
jsr r5,code
<%d.\n\0>; .even
r2
2:
add $8,r3
br 1b
1:
rts r5
source/fort/f4/f47.s
+298
View File
@@ -0,0 +1,298 @@
/
/
/ f47 -- analysis of data statements
.globl cdata
.globl dodata
.globl onedata
.globl compare
.globl code
.globl getcon
.globl error
.globl getsym
.globl consub
.globl size
.globl geti
.globl setln
.globl getln
.globl declimpl
.globl evalcon
.globl dattab
.globl contab
.globl efno
.globl perror
.globl qsort
.globl negflg
.globl repfact
.globl geti
.globl holround
cdata:
mov r5,-(sp)
jsr r5,setln
mov $dattab,r4
mov $contab,r5
dloop:
jsr r5,getln
br 2f
br 1f
2:
mov r4,-(sp)
mov $dattab,r1
mov r4,r2
mov $8.,r3
jsr pc,qsort
mov (sp)+,r4
mov (sp)+,r5
rts r5
1:
cmp r0,$'d
bne dloop
mov $line+4,r1
/ loop per specification-set
1:
clr repfact
mov r1,r2
2:
jsr r5,getsym
cmp r0,$40. / =|
bne 3f
8:
jmp 8f
9:
jmp 9f
3:
cmp r0,$6 / /
bne 2b
mov r1,-(sp)
mov r2,r1
mov (sp)+,r2
/ loop per specification
2:
cmp r4,r5
blo 3f
jmp 7f
3:
jsr r5,getsym
tst r0
bne 8b
bit $70,symtab(r3) / test classed
bne 3f
jsr r5,declimpl
3:
mov symtab(r3),r0
mov r0,holquo / temp storage
incb holquo+1 / round size
bicb $1,holquo+1
bit $200,r0 / test parameter
bne 9b
bic $!70,r0
cmp r0,$10 / simple
beq 3f
cmp r0,$20 / array
bne 9b
3:
bit $100,symtab(r3) / test common
beq 3f
cmp progt,$6 / test block data
bne 9b
mov symtab+4(r3),(r4)+ / common block
br 4f
3:
cmp progt,$6 / test block data
beq 9b
clr (r4)+
tst symtab+6(r3) / test allocated
bne 4f
mov nxtaloc,symtab+6(r3)
jsr r5,size
add r0,nxtaloc
4:
clr (r4) / offset slot
cmpb (r1),$'( / test subscript
bne 3f
inc r1
jsr r5,consub
bic $70,holquo
bis $10,holquo / array -> scalar
mov r0,(r4)
3:
movb symtab+1(r3),r0 / width of item
inc r0
bic $1,r0
mov r0,holround
add symtab+6(r3),(r4)+
tst repfact
beq 3f
dec repfact
movb efno+1,r3
mov r3,(r4)+
mov r5,(r4)+
br 4f
3:
mov r1,-(sp)
mov r2,r1
mov (sp)+,r2
5:
jsr r5,getsym
cmp r0,$2 / constant
beq 3f
cmp r0,$10. / -
bne 8f
inc negflg
jsr r5,getsym
cmp r0,$2 / constant
bne 8f
3:
cmpb (r1)+,$'*
bne 3f
cmp r3,$intcon
bne 8f
jsr r5,geti
dec r0
bmi 8f
mov r0,repfact
br 5b
3:
dec r1
mov r1,-(sp)
mov r2,-(sp)
mov r3,efno
clrb r3
swab r3
mov r3,(r4)+
sub r3,r5
mov r5,(r4)+ / ptr to const
mov r5,r3
mov $symbuf,r1
jsr r5,evalcon
clr negflg
mov (sp)+,r1
mov (sp)+,r2 / note r1 <=> r2
4:
cmpb efno+1,holquo+1 / compare sizes
blt 9f / constant too small
beq 3f
bicb $!77,holquo
cmp holquo,$int2con+10 / simple int*2?
bne 4f
sub $2,-4(r4) / reduce const length
cmpb efno,$5
beq 3f / hollerith, OK
add $2,-2(r4) / get least sig.
br 3f
4:
bit $20,holquo / test array
beq 9f
cmpb efno,$5 / test hollerith
bne 9f
3:
cmpb (r1),$'/
beq 3f
cmpb (r1)+,$',
bne 8f
tst repfact
bne 4f
cmpb (r2)+,$',
bne 8f
4:
jmp 2b
3:
cmpb (r2)+,$'/
bne 8f
tstb (r2)
beq 1f
cmpb (r2),$',
bne 3f
inc r2
3:
mov r2,r1
tst repfact
bne 8f
jmp 1b
7:
jsr r5,error; 28. / data table overflow
br 2f
8:
jsr r5,error; 21. / data syntax error
br 2f
9:
jsr r5,error; 22. / data semantic error
2:
mov $dattab,r4 / reset ptrs
mov $contab,r5
jsr r5,perror
1:
jmp dloop
dodata:
cmp progt,$6
beq 1f / block data
mov $dattab,r3
cmp r3,r4
bne 2f / is data
mov nxtaloc,r0
jsr r5,code
<.=.+%d.\n.text\n\0>; .even
r0
rts r5
2:
jsr r5,onedata
sub nxtaloc,r1
neg r1
blt 9b
jsr r5,code
<.=.+%d.\n.text\n\0>; .even
r1
1:
rts r5
onedata:
clr r1
2:
mov 2(r3),r0
sub r1,r0
bmi 9f
beq 3f
jsr r5,code
<.=.+%d.\n\0>; .even
r0
add r0,r1
3:
mov 4(r3),r0
add r0,r1
asr r0
mov r0,-(sp)
mov 6(r3),r2
3:
mov (r2)+,r0
jsr r5,code
<%o\n\0>; .even
r0
dec (sp)
bne 3b
tst (sp)+
add $8.,r3
cmp r3,r4
bhis 1f
cmp (r3),-8(r3) / any more in this block
beq 2b
1:
rts r5
9:
clr line
jsr r5,error; 32. / overlapping data init
jsr r5,perror
rts r5
/ comparison routine for qsort
compare:
cmp (r0),(r4)
bne 1f
cmp 2(r0),2(r4)
1:
rts pc
source/fort/fx/fhd.s
+53
View File
@@ -0,0 +1,53 @@
/
/
/ fhd -- data segment header
/
symsize = 1600.
linsize = 800.
namsize = 1200.
smblsize = 399.
intcon = 4\<8+1 / type of integer constant
realcon = 4\<8+2
logcon = 2\<8+3 / type of logical constant
log1con = 1\<8+3
int1con = 1\<8+1
int2con = 2\<8+1
dblcon = 10\<8+2
dcplxcon = 20\<8+4
cplxcon = 10\<8+4
.globl data
.globl ibuf
.globl obuf
.globl tbuf
.globl line
.globl eline
.globl ifno
.globl efno
.globl errp
.globl errb
.globl eerrb
.globl symtab
.globl esymtab
.globl esymp
.globl symtp
.globl namebuf
.globl enamebuf
.globl namep
.globl symbuf
.globl esymbuf
.globl ch
.globl ch1
.globl progt
.globl holquo
.globl nxtaloc
.globl imptab
.globl nerror
.globl temp
.globl functm
.globl edata
.globl dsize
source/fort/fx/fx1.s
+40
View File
@@ -0,0 +1,40 @@
/
/
/ fx1 -- utility
.globl lookup
/ lookup
/ lookup string pointed at by r2
/ in table pointed at by arg1
/ r0 returns symbol number*2
/ r2 is advanced by matched string
/ registers used: r0,r2
lookup:
mov r1,-(sp)
clr r0
mov r2,-(sp)
mov (r5)+,r1
1:
mov (sp),r2
tstb (r1)
beq 1f
2:
cmpb (r2)+,(r1)+
bne 2f
tstb (r1)
bne 2b
asl r0
cmp (r5)+,(sp)+
mov (sp)+,r1
rts r5
2:
tstb (r1)+
bne 2b
inc r0
br 1b
1:
mov (sp)+,r2
mov (sp)+,r1
rts r5
source/fort/fx/fx2.s
+134
View File
@@ -0,0 +1,134 @@
/
/
/ fx2 -- error setting and printing
.globl error
.globl perror
.globl tput
.globl tdecml
error:
inc nerror
mov r0,-(sp)
mov r2,-(sp)
mov (r5)+,r0
mov $errb,r2
1:
cmp r2,errp
bhis 1f
cmp r0,(r2)+
beq 2f
tst (r2)+
br 1b
1:
cmp r2,$eerrb
bhis 2f
mov r0,(r2)+
mov r1,(r2)
dec (r2)+ / r1 is often 1 too far
mov r2,errp
2:
mov (sp)+,r2
mov (sp)+,r0
rts r5
perror:
cmp errp,$errb
beq 1f
mov r1,-(sp)
mov r2,-(sp)
mov ifno,r0
jsr r5,tdecml
mov $'\t,r0
jsr r5,tput
mov $line,r1
2:
movb (r1),r0
beq 2f
jsr r5,tput
mov $errb+2,r2
3:
cmp r1,(r2)+
bne 4f
mov $1,r0
sys write; mes2; 2 / bs, _
br 3f
4:
cmp r2,errp
blo 3b
3:
inc r1
br 2b
2:
mov $errb,r1
2:
mov $1,r0
sys write; mes1; 4
3:
sys open; errfil; 0
bec 3f
mov (r1)+,r0
tst (r1)+
jsr r5,tdecml
cmp r1,errp
bhis 2f
mov $',,r0
jsr r5,tput
br 3b
3:
mov r0,-(sp)
mov (r1)+,r2
tst (r1)+
3:
dec r2
ble 3f
4:
mov (sp),r0
sys read; ich; 1
bes 4f
tst r0
beq 4f
cmpb ich,$'\n
bne 4b
br 3b
3:
mov (sp),r0
sys read; ich; 1
bes 4f
tst r0
beq 4f
movb ich,r0
cmp r0,$'\n
beq 3f
jsr r5,tput
br 3b
4:
mov $1,r0
sys write; mes3; 18.
3:
mov (sp)+,r0
sys close
cmp r1,$errp
blo 2b
2:
mov $'\n,r0
jsr r5,tput
mov $errb,errp
mov (sp)+,r2
mov (sp)+,r1
1:
rts r5
mes1:
<\n** >
mes2:
.byte 010, '_
mes3:
<Unknown diagnostic>
errfil:
</usr/fort/errors\0>
.even
.bss
ich: .=.+2
source/fort/fx/fx3.s
+49
View File
@@ -0,0 +1,49 @@
/
/
/ fx3 -- get integer
.globl geti
.globl ptemp
.globl putc
.globl putw
geti:
mov r1,-(sp)
mov r3,-(sp)
clr r3
mov $symbuf,r0
1:
movb (r0)+,r1
sub $'0,r1
cmp r1,$9
bhi 1f
mpy $10.,r3
add r1,r3
br 1b
1:
mov r3,r0
mov (sp)+,r3
mov (sp)+,r1
rts r5
ptemp:
mov r0,-(sp)
mov r1,-(sp)
mov (r5)+,r0 / character
jsr r5,putc; tbuf
mov *(r5)+,r0 / word
jsr r5,putw; tbuf
mov ifno,r0
jsr r5,putw; tbuf
mov (r5)+,r1 / string
1:
movb (r1),r0
jsr r5,putc; tbuf
tstb (r1)+
bne 1b
mov (sp)+,r1
mov (sp)+,r0
rts r5
source/fort/fx/fx4.s
+364
View File
@@ -0,0 +1,364 @@
/
/
/ fx4 -- get symbol
.globl getsym
.globl getid
.globl lookid
.globl chrtab
.globl lookup
.globl error
.globl geti
.globl holround
/ getsym returns the next basic symbol
/ 0 name (symbol table entry in r3)
/ 2 number (type in r3)
/ 4 **
/ 6 /
/ 8 *
/ 10 -
/ 12 +
/ 14 .lt.
/ 16 .le.
/ 18 .eq.
/ 20 .ne.
/ 22 .gt.
/ 24 .ge.
/ 26 .not.
/ 28 .and.
/ 30 .or.
/ 32 (
/ 34 )
/ 36 ,
/ 38 =
/ 40 =|
/
getsym:
mov r2,-(sp)
mov r1,r2
jsr r5,lookup; bastab
br 1f
mov r2,r1
cmp r0,$4
bhis 2f
asr r0
add $'0,r0
movb r0,symbuf
movb $12,symbuf+1
clrb symbuf+2
mov $logcon,r3 / logical*2
mov $2,r0
2:
cmp r0,$32.
bne 2f
/ check for possible complex constant
mov r1,-(sp)
movb -2(r1),r0
movb chrtab(r0),r0
beq 4f
cmp r0,$4
blos 3f
4:
jsr r5,srconst
br 3f
mov r3,r2
cmpb (r1)+,$',
bne 3f
jsr r5,srconst
br 3f
cmp r3,r2
bhis 4f
mov r2,r3
4:
cmpb (r1)+,$')
bne 3f
mov (sp)+,r1
mov $symbuf,r2
4:
movb (r1)+,(r2)
cmpb (r2)+,$')
bne 4b
clrb -(r2)
mov $2,r0
br 2f
3:
mov (sp)+,r1
mov $32.,r0
2:
mov (sp)+,r2
rts r5
1:
clr lstchr
cmp r1,$line
blos 1f
movb -1(r1),lstchr
1:
mov $symbuf,r2
movb (r1)+,r0
movb r0,(r2)+
bic $!177,r0
movb chrtab(r0),r0
jmp *1f(r0)
1:
eos
let
num
per
eos:
mov $40.,r0
tstb -(r1)
beq 2b
jsr r5,error; 8.
br 2b
let:
dec r1
jsr r5,getid
br .+2 / cannot happen
jsr r5,lookid; symbuf
mov (sp)+,r2
clr r0
rts r5
num:
mov $intcon,r3 / integer*4
jsr r5,numst
cmpb (r1),$'.
bne 2f
mov r2,-(sp)
mov r1,r2
jsr r5,lookup; bastab
br 1f
mov (sp)+,r2
br 3f
1:
mov (sp)+,r2
movb (r1)+,(r2)+
br 1f
2:
cmpb (r1),$'h / hollerith const?
bne 2f
mov lstchr,r0
cmpb chrtab(r0),$2 / letter?
beq 2f / not h, then
cmp r0,$'*
beq 2f / e.g. real*4 h...
clrb (r2)
jsr r5,geti
mov $symbuf,r2
inc r1
mov holround,-(sp)
dec (sp)
clr -(sp)
4:
movb (r1)+,(r2)+
bne 5f
jsr r5,error; 55.
br 6f
5:
inc (sp)
dec r0
bgt 4b
6:
bit (sp),2(sp)
beq 6f
movb $' ,(r2)+
inc (sp)
br 6b
6:
mov (sp)+,r3
tst (sp)+
swab r3
clrb r3
bis $5,r3
mov $2,r0
mov (sp)+,r2
rts r5
.bss
lstchr: .=.+2
.text
per:
jsr r5,isnum
br eos
1:
mov $realcon,r3 / real*4
jsr r5,numst
2:
jsr r5,expon
3:
clrb (r2)
mov $2,r0
mov (sp)+,r2
rts r5
isnum:
movb (r1),r0
cmpb chrtab(r0),$4
bne 1f
tst (r5)+
1:
rts r5
numst:
jsr r5,isnum
br 1b
inc r1
movb r0,(r2)+
br numst
expon:
cmpb (r1)+,$'e
beq 1f
cmpb -1(r1),$'d
beq 1f
2:
dec r1
rts r5
1:
cmpb (r1),$'+
beq 1f
cmpb (r1),$'-
beq 1f
jsr r5,isnum
br 2b
1:
mov $realcon,r3 / real*4
cmpb -(r1),$'e
beq 1f
mov $dblcon,r3 / real*8
1:
movb (r1)+,(r2)+
movb (r1)+,(r2)+
jsr r5,numst
rts r5
getid:
mov r0,-(sp)
mov r2,-(sp)
movb (r1),r0
cmpb chrtab(r0),$2
bne 3f
tst (r5)+
mov $symbuf,r2
1:
movb (r1)+,r0
movb r0,(r2)+
movb chrtab(r0),r0
cmp r0,$2
beq 1b
cmp r0,$4
beq 1b
dec r1
clrb (r2)
movb $12,-(r2)
3:
mov (sp)+,r2
mov (sp)+,r0
rts r5
lookid:
mov r0,-(sp)
mov r2,-(sp)
2:
mov (r5),r2
jsr r5,lookup; namebuf
br 1f
asl r0
asl r0
mov r0,r3
mov (sp)+,r2
mov (sp)+,r0
tst (r5)+
rts r5
1:
mov namep,r0
add $8.,symtp
1:
movb (r2)+,(r0)+
bne 1b
mov r0,namep
cmp r0,$enamebuf
bhis 1f
mov symtp,r0
add $symtab,r0
cmp r0,esymp
blo 2b
1:
mov $1,r0
sys write; ovfl; eovfl-ovfl
clr r0
sys seek; 0; 2
mov $-1,r0
sys exit
ovfl:
<Symbol table overflow\n>
eovfl:
.even
srconst:
cmpb (r1)+,$'+
beq 1f
cmpb -(r1),$'-
bne 1f
inc r1
1:
jsr r5,getsym
cmp r0,$2
bne 1f
clrb r3
add r3,r3
bisb $cplxcon,r3
tst (r5)+
1:
rts r5
chrtab:
.byte 0,0,0,0,0,0,0,0
.byte 0,0,0,0,0,0,0,0
.byte 0,0,0,0,0,0,0,0
.byte 0,0,0,0,0,0,0,0
.byte 0,0,0,0,0,0,0,0
.byte 0,0,0,0,0,0,6,0
.byte 4,4,4,4,4,4,4,4
.byte 4,4,0,0,0,0,0,0
.byte 0,2,2,2,2,2,2,2
.byte 2,2,2,2,2,2,2,2
.byte 2,2,2,2,2,2,2,2
.byte 2,2,2,0,0,0,0,0
.byte 0,2,2,2,2,2,2,2
.byte 2,2,2,2,2,2,2,2
.byte 2,2,2,2,2,2,2,2
.byte 2,2,2,0,0,0,0,0
bastab:
<.false.\0>
<.true.\0>
<**\0>
</\0>
<*\0>
<-\0>
<+\0>
<.lt.\0>
<.le.\0>
<.eq.\0>
<.ne.\0>
<.gt.\0>
<.ge.\0>
<.not.\0>
<.and.\0>
<.or.\0>
<(\0>
<)\0>
<,\0>
<=\0>
<\0>
source/fort/fx/fx5.s
+46
View File
@@ -0,0 +1,46 @@
/
/
/ fx5 -- declare implicit
.globl declimpl
.globl getname
declimpl:
bit $7,symtab(r3)
bne 1f / already declared
jsr r5,getname
movb symbuf,r0
cmp r0,$'a
blo 2f
sub $6,r0 / map 'a -> 'Z+1
2:
asl r0
bis imptab-[2*'A](r0),symtab(r3)
1:
bit $70,symtab(r3) / class
bne 1f
bis $10,symtab(r3) / simple
1:
rts r5
getname:
mov r3,-(sp)
clr r3
mov $namebuf,r0
1:
cmp r3,(sp)
bhis 1f
2:
tstb (r0)+
bne 2b
add $8,r3
br 1b
1:
mov $symbuf,r3
2:
movb (r0)+,(r3)+
bne 2b
mov (sp)+,r3
rts r5
source/fort/fx/fx6.s
+31
View File
@@ -0,0 +1,31 @@
/
/
/ fx6 -- teletype
.globl tput
.globl tdecml
tdecml:
mov r1,-(sp)
jsr r5,td
mov (sp)+,r1
rts r5
td:
mov r0,r1
clr r0
dvd $10.,r0
mov r1,-(sp)
tst r0
beq 1f
jsr r5,td
1:
mov (sp)+,r0
add $'0,r0
tput:
movb r0,ch+1
mov $1,r0
sys write; ch+1; 1
rts r5
source/fort/fx/fx7.s
+34
View File
@@ -0,0 +1,34 @@
/
/
/ fx7 -- passes advancement
.globl signon
.globl signoff
.globl pass2
.globl pass3
.globl pass4
signon:
tst (r5)+
rts r5
signoff:
mov (r5)+,r0
tst (sp)+
dec r0
asl r0
jmp *passtab(r0)
passtab:
pass2
pass3
pass4
.data
source/fort/fx/fx8.s
+269
View File
@@ -0,0 +1,269 @@
/
/
/ fx8 -- read source line
.globl getline
.globl isagn
.globl levzer
.globl error
.globl getc
.globl chrtab
getline:
mov r3,-(sp)
clr holquo
clr r3 / line number
clr line
mov $line,r1
1:
jsr pc,get
sub $'0,r0
cmp r0,$9
bhi 1f
mpy $10.,r3
add r0,r3
br 1b
1:
add $'0,r0
movb r0,ch
mov r3,efno
1:
mov lino, ifno
inc ifno
jsr pc,get
cmp r0,$'\n / nl
beq 1f
cmp r0,$''
beq 2f
cmp r0,$'"
bne 3f
2:
mov r0,holquo
add $4,r1 / room for h count
mov r1,-(sp)
2:
jsr pc,get
cmp r0,$'\n
beq 4f
cmp r0,holquo
beq 2f
bis $200,r0
movb r0,(r1)+
cmp r1,$eline-1
blo 2b
4:
tst (sp)+
br err1
2:
mov (sp)+,r3
mov r1,-(sp)
sub r3,r1
movb $'h,-(r3)
clr r0
div $10.,r0
add $'0,r1
movb r1,-(r3)
mov r0,r1
clr r0
div $10.,r0
add $'0,r1
movb r1,-(r3)
add $'0,r0
movb r0,-(r3)
mov (sp)+,r1
clr holquo
br 1b
3:
cmp r0,$'h
bne 2f
clr r3 / quote count
mov r1,-(sp)
3:
cmp r1,$line
blos 4f
movb -(r1),r0
cmpb chrtab(r0),$4 / digit?
beq 3b
cmpb chrtab(r0),$2 / test letter
beq 3f
cmp r0,$'*
beq 3f
inc r1
4:
cmp r1,(sp)
bhis 4f
movb (r1)+,r0
sub $'0,r0
mpy $10.,r3
add r0,r3
br 4b
4:
mov r3,r0
beq 3f
mov r0,holquo
mov (sp)+,r1
movb $'h,(r1)+
4:
jsr pc,get
cmp r0,$'\n
bne 5f
mov r0,ch
mov $' ,r0
5:
bis $200,r0
movb r0,(r1)+
cmp r1,$eline-1
bhis err1
dec holquo
bne 4b
br 1b
3:
mov (sp)+,r1
mov $'h,r0
2:
movb r0,(r1)+
cmp r1,$eline-1
blo 1b
err1:
jsr r5,error; 1.
1:
clrb (r1)+
mov (sp)+,r3
tstb line
bne 1f
jmp getline
1:
rts r5
isagn:
jsr r5,levzer; '=
br 1f
br 3f
1:
mov r0,-(sp)
jsr r5,levzer; ',
br 4f
jsr r5,levzer; '(
br 1f
tst (sp)+
2:
rts r5
1:
cmp (sp)+,r0
blt 2b
mov r1,-(sp)
mov r0,r1
inc r1
jsr r5,levzer; ')
br 1f
1:
mov (sp)+,r1
cmpb 1(r0),$'=
bne 3f
rts r5
levzer:
mov r1,r0
clr -(sp)
1:
tst (sp)
bne 2f
cmpb (r0),(r5)
beq 1f
2:
cmpb (r0),$'(
bne 2f
inc (sp)
2:
cmpb (r0),$')
bne 2f
dec (sp)
blt 5f
2:
tstb (r0)+
bne 1b
5:
tst (r5)+
1:
4:
tst (sp)+
3:
tst (r5)+
rts r5
get:
movb ch,r0
beq 1f
clrb ch
rts pc
1:
jsr pc,get1
cmp r0,$'\n
bne 2f
jsr pc,get1
cmp r0,$'&
beq 1b
movb r0,ch1
mov $'\n,r0
2:
tst holquo
bne 1f
cmp $' ,r0
beq 1b
cmp $'\t,r0
beq 1b
1:
cmp r0,$4 / test EOT
bne 1f
mov $1,r0
sys write; mes; emes-mes
mov $1,r0 / syntax errors detected
sys exit
1:
rts pc
get1:
movb ch1,r0
beq 1f
clrb ch1
br 2f
1:
jsr r5,getc; ibuf
bcs 1f
bic $!177,r0
beq 1b
cmp r0,$'\n
bne 2f
inc lino
2:
tst nlflg
beq 2f
clr nlflg
cmp r0,$'c
bne 2f
3:
jsr pc,get1
cmp r0,$'\n
beq 1b
cmp r0,$4
bne 3b
2:
cmp r0,$'\n
bne 2f
inc nlflg
2:
rts pc
1:
mov $4,r0
rts pc
.data
nlflg: 1
.text
mes:
<EOF on input\n\0>
emes:
.bss
lino: .=.+2
source/fort/fx/fx9.s
+125
View File
@@ -0,0 +1,125 @@
/
/
/ fx9 -- code
/ jsr r5,code; <string\0>; .even
/ arg1
/ arg2
/ ...
/
/ args specified by %<c> in string.
/ %s: string
/ %d: decimal number
/ %o: octal number
/ %c: character
/
/ args are addresses
/ or registers r0-r4
.globl code
.globl putc
.globl getname
code:
mov r4,-(sp)
mov r3,-(sp)
mov r2,-(sp)
mov r1,-(sp)
mov r0,-(sp)
mov r5,r4
1:
tstb (r5)+
bne 1b
inc r5
bic $1,r5
1:
movb (r4)+,r0
beq 1f
cmp r0,$'%
beq 2f
jsr r5,putc; obuf
br 1b
2:
movb (r4)+,r0
beq 1f
cmp r0,$'s
beq cstr
cmp r0,$'c
beq cchr
cmp r0,$'d
beq cdec
cmp r0,$'o
beq coct
cmp r0,$'n
beq cnam
jsr r5,putc; obuf
br 1b
cnam:
jsr pc,cget
mov r1,r3
jsr r5,getname
mov $symbuf,r1
br 2f
cstr:
jsr pc,cget
2:
movb (r1)+,r0
beq 1b
cmp r0,$'\n
beq 2b
jsr r5,putc; obuf
br 2b
cchr:
jsr pc,cget
mov r1,r0
jsr r5,putc; obuf
mov r1,r0
clrb r0
swab r0
beq 1b
jsr r5,putc; obuf
br 1b
coct:
jsr pc,cget
mov $8.,r2
br 2f
cdec:
jsr pc,cget
mov $10.,r2
2:
jsr pc,2f
br 1b
2:
clr r0
dvd r2,r0
mov r1,-(sp)
mov r0,r1
beq 2f
jsr pc,2b
2:
mov (sp)+,r0
add $'0,r0
jsr r5,putc; obuf
rts pc
1:
mov (sp)+,r0
mov (sp)+,r1
mov (sp)+,r2
mov (sp)+,r3
mov (sp)+,r4
rts r5
cget:
mov (r5)+,r1
cmp r1,$4
blos 1f
rts pc
1:
asl r1
add $2,r1
add sp,r1
mov (r1),r1
rts pc
source/fort/fx/fxa.s
+36
View File
@@ -0,0 +1,36 @@
/
/
/ fxa -- genop -- output a typed operator
.globl genop
.globl newline
.globl code
.globl typ
genop:
mov r1,-(sp)
mov r3,-(sp)
bic $!7,r3
movb typ(r3),r1
mov (sp),r3
clrb r3
swab r3
jsr r5,code
< %c%c%d\0>; .even
r1
r0
r3
mov (sp)+,r3
mov (sp)+,r1
rts r5
newline:
jsr r5,code
<\n\0>; .even
rts r5
typ:
<?irlc??g>
source/fort/fx/fxb.s
+32
View File
@@ -0,0 +1,32 @@
/
/
/ fxb -- get integer constant or label
.globl geticon
.globl getlab
.globl getsym
.globl geti
.globl ptemp
geticon:
jsr r5,getsym
cmp r0,$2
bne 1f
cmp r3,$intcon
bne 1f
jsr r5,geti
tst (r5)+
1:
rts r5
getlab:
jsr r5,geticon
br 1f
mov r0,temp
jsr r5,ptemp; 'r; temp; line
tst (r5)+
1:
rts r5
source/fort/fx/fxc.s
+36
View File
@@ -0,0 +1,36 @@
/
/
/ fxc -- size of array
.globl size
.globl nelem
.globl error
size:
movb symtab+1(r3),r0
jsr r5,nelem
inc r0
bic $1,r0 / round to 0 mod 2
rts r5
nelem:
mov r1,-(sp)
mov r0,r1
mov symtab(r3),r0
bic $!70,r0
cmp r0,$20
bne 1f
mov symtab+2(r3),r0
mov (r0)+,-(sp)
2:
mpy (r0)+,r1
dec (sp)
bgt 2b
tst (sp)+
1:
mov r1,r0
mov (sp)+,r1
rts r5
source/fort/fx/fxd.s
+50
View File
@@ -0,0 +1,50 @@
/
/
/ xd -- tmp file 2 handl
.globl setln
.globl getln
.globl tfil2
.globl tfildiag
.globl fopen
.globl getc
.globl getw
.globl xbuf
setln:
mov $tfil2,r0
jsr r5,fopen; xbuf
bcc 1f
jmp tfildiag
1:
rts r5
getln:
jsr r5,getc; xbuf
bcs 3f
mov r0,-(sp)
jsr r5,getw; xbuf
mov r0,efno
jsr r5, getw; xbuf
mov r0,ifno
mov $line,r1
1:
jsr r5,getc; xbuf
bcs 1f
tst r0
beq 1f
bic $200,r0
movb r0,(r1)+
br 1b
1:
clrb (r1)+
mov (sp)+,r0
tst (r5)+
rts r5
3:
mov xbuf,r0
sys close
rts r5
source/fort/fx/fxe.s
+24
View File
@@ -0,0 +1,24 @@
/
/
/ xe -- temp file junk
.globl tfildiag
.globl tfil1, tfil2
tfildiag:
mov $1,r0
sys write; mes1; emes1-mes1
clr r0
sys seek; 0; 2
mov $-1,r0 / failure return
sys exit
mes1:
<Temp file?\n>
emes1:
tfil1:
<f.tmp1\0>
tfil2:
<f.tmp2\0>
source/fort/fx/fxf.s
+23
View File
@@ -0,0 +1,23 @@
/
/
/ fxf -- format statements
.globl sform
.globl sdata
.globl ptemp
.globl error
sform:
cmp progt,$6 / block data
bne 1f
jsr r5,error; 50.
1:
jsr r5,ptemp; 'f; efno; line
rts r5
sdata:
jsr r5,ptemp; 'd; efno; line
rts r5
source/fort/fx/fxg.s
+186
View File
@@ -0,0 +1,186 @@
/
/
/ fxg -- declare implicit functions
.globl funimpl
.globl getname
.globl lookup
funimpl:
bit $7,symtab(r3)
bne 1f
jsr r5,getname
mov r2,-(sp)
mov $symbuf,r2
jsr r5,lookup; funtab
br 2f
cmpb (r2),$'\n
bne 2f
asr r0
movb funtabt(r0),r0
mov r0,-(sp)
bic $!17,r0
bis typtab(r0),symtab(r3)
mov (sp)+,r0
asr r0
asr r0
asr r0
asr r0
bic $!17,r0
mov typtab(r0),symtab+2(r3) / save argument conversion
2: / in dimension pointer
mov (sp)+,r2
1:
rts r5
typtab:
intcon
realcon
dblcon
cplxcon
dcplxcon
funtab:
<tanh\0>
<sqrt\0>
<sngl\0>
<sin\0>
<sign\0>
<real\0>
<mod\0>
<min1\0>
<min0\0>
<max1\0>
<max0\0>
<isign\0>
<int\0>
<ifix\0>
<idint\0>
<idim\0>
<iabs\0>
<float\0>
<exp\0>
<dsqrt\0>
<dsin\0>
<dsign\0>
<dreal\0>
<dmod\0>
<dmin1\0>
<dmax1\0>
<dlog10\0>
<dlog\0>
<dimag\0>
<dim\0>
<dexp\0>
<dcsqrt\0>
<dcsin\0>
<dcos\0>
<dconjg\0>
<dcmplx\0>
<dclog\0>
<dcexp\0>
<dccos\0>
<dcabs\0>
<dble\0>
<datan2\0>
<datan\0>
<dabs\0>
<csqrt\0>
<csin\0>
<cos\0>
<conjg\0>
<cmplx\0>
<clog\0>
<cexp\0>
<ccos\0>
<cabs\0>
<atan2\0>
<atan\0>
<amod\0>
<amin1\0>
<amin0\0>
<amax1\0>
<amax0\0>
<alog10\0>
<alog\0>
<aint\0>
<aimag\0>
<abs\0>
<\0>
/ function type xy
/ x = arg types
/ y = result type
/ 0 = integer
/ 2 = real
/ 4 = double
/ 6 = complex
/ 8 = doublecomplex
funtabt:
.byte 2\<4+2 / tanh
.byte 2\<4+2 / sqrt
.byte 4\<4+2 / sngl
.byte 2\<4+2 / sin
.byte 2\<4+2 / sign
.byte 6\<4+2 / real
.byte 0\<4+0 / mod
.byte 2\<4+0 / min1
.byte 0\<4+0 / min0
.byte 2\<4+0 / max1
.byte 0\<4+0 / max0
.byte 0\<4+0 / isign
.byte 2\<4+0 / int
.byte 2\<4+0 / ifix
.byte 4\<4+0 / idint
.byte 0\<4+0 / idim
.byte 0\<4+0 / iabs
.byte 0\<4+2 / float
.byte 2\<4+2 / exp
.byte 4\<4+4 / dsqrt
.byte 4\<4+4 / dsin
.byte 4\<4+4 / dsign
.byte 8\<4+4 / dreal
.byte 4\<4+4 / dmod
.byte 4\<4+4 / dmin1
.byte 4\<4+4 / dmax1
.byte 4\<4+4 / dlog10
.byte 4\<4+4 / dlog
.byte 8\<4+4 / dimag
.byte 2\<4+2 / dim
.byte 4\<4+4 / dexp
.byte 8\<4+8 / dcsqrt
.byte 8\<4+8 / dcsin
.byte 4\<4+4 / dcos
.byte 8\<4+8 / dconjg
.byte 4\<4+8 / dcmplx
.byte 8\<4+8 / dclog
.byte 8\<4+8 / dcexp
.byte 8\<4+8 / dccos
.byte 8\<4+4 / dcabs
.byte 2\<4+4 / dble
.byte 4\<4+4 / datan2
.byte 4\<4+4 / datan
.byte 4\<4+4 / dabs
.byte 6\<4+6 / csqrt
.byte 6\<4+6 / csin
.byte 2\<4+2 / cos
.byte 6\<4+6 / conjg
.byte 2\<4+6 / cmplx
.byte 6\<4+6 / clog
.byte 6\<4+6 / cexp
.byte 6\<4+6 / ccos
.byte 6\<4+2 / cabs
.byte 2\<4+2 / atan2
.byte 2\<4+2 / atan
.byte 2\<4+2 / amod
.byte 2\<4+2 / amin1
.byte 0\<4+2 / amin0
.byte 2\<4+2 / amax1
.byte 0\<4+2 / amax0
.byte 2\<4+2 / alog10
.byte 2\<4+2 / alog
.byte 2\<4+2 / aint
.byte 6\<4+2 / aimag
.byte 2\<4+2 / abs
source/fort/fx/fxh.s
+77
View File
@@ -0,0 +1,77 @@
/
/
/ fxh -- array constant offset
.globl consub
.globl getsym
.globl geti
.globl error
.globl geticon
/ turn constant subscripts into offset.
/ in: r3 -> symtab
/ r1 -> just beyond (
/ out:r0 has offset
consub:
mov symtab(r3),r0
bic $!70,r0
cmp r0,$20 / test class == array
beq 1f
jsr r5,error; 17.
clr r0
rts r5
1:
mov r5,-(sp)
mov r4,-(sp)
mov r3,-(sp)
mov r2,-(sp)
clr r4 / accumulated offset
mov symtab+2(r3),r2 / ptr to declarator
mov (r2)+,-(sp) / dimensionality
mov $1,r5 / prod of declarators
1:
jsr r5,geticon
br 9f
cmp r0,(r2)
bgt 3f
dec r0
bge 2f
3:
jsr r5,error; 19. / out of range
clr r0
2:
mov r5,-(sp)
mpy r0,r5
add r5,r4
mov (sp)+,r5
mpy (r2)+,r5
jsr r5,getsym
cmp r0,$36. / comma
bne 1f
dec (sp)
bgt 1b
jsr r5,error; 18. / wrong subscript count
br 1b
1:
cmp r0,$34. / )
beq 1f
9:
jsr r5,error; 20.
clr r0
1:
cmp (sp)+,$1
beq 1f
jsr r5,error; 18. / subscript count
1:
mov (sp)+,r2
mov (sp)+,r3
movb symtab+1(r3),r5
mpy r4,r5
mov r5,r0
mov (sp)+,r4
mov (sp)+,r5
rts r5
source/fort/fx/fxi.s
+145
View File
@@ -0,0 +1,145 @@
/
/
/ quicker sort
/ mov $base,r1
/ mov $base+[n*width],r2
/ mov $width,r3
/ jsr pc,qsort
/ r0,r1,r2,r3,r4 are used
.globl qsort
.globl compare
qsort:
mov r5,-(sp)
mov r4,-(sp)
bit $1,r3
bne 1f
bit $1,r1
bne 1f
cmp r3,$2
bne 2f
mov $exch1,exchange
br 3f
2:
mov r3,r5
clc
ror r5
mov r5,width
mov $exchw,exchange
br 3f
1:
mov $exchb,exchange
3:
jsr pc,qs1
mov (sp)+,r4
mov (sp)+,r5
rts pc
qs1:
mov r1,r5
neg r5
add r2,r5
bgt 1f
rts pc
1:
clr r4
dvd r3,r4
asr r4
mpy r3,r4
mov r5,r4
add r1,r4
mov r1,-(sp)
mov r2,-(sp)
loop:
cmp r1,r4
bhis loop1
mov r1,r0
jsr pc,compare
bgt loop1
add r3,r1
br loop
loop1:
cmp r2,r4
blos 1f
sub r3,r2
mov r2,r0
jsr pc,compare
bge loop1
jsr pc,*exchange
cmp r1,r4
bne loop
mov r2,r4
br loop
1:
cmp r1,r4
beq 1f
jsr pc,*exchange
mov r1,r4
br loop1
1:
mov (sp)+,r2
mov r4,-(sp)
mov r4,r1
add r3,r1
mov r2,r0
sub r1,r0
sub 2(sp),r4
cmp r0,r4
blo 1f
mov (sp)+,r0
mov (sp)+,r4
mov r1,-(sp)
mov r2,-(sp)
mov r0,r2
mov r4,r1
1:
jsr pc,qs1
mov (sp)+,r2
mov (sp)+,r1
br qs1
exchb:
mov r1,-(sp)
mov r2,-(sp)
mov r3,r5
1:
movb (r1),r0
movb (r2),(r1)+
movb r0,(r2)+
sob r5,1b
mov (sp)+,r2
mov (sp)+,r1
rts pc
exchw:
mov r1,-(sp)
mov r2,-(sp)
mov width,r5
1:
mov (r1),r0
mov (r2),(r1)+
mov r0,(r2)+
sob r5,1b
mov (sp)+,r2
mov (sp)+,r1
rts pc
exch1:
mov (r1),r0
mov (r2),(r1)
mov r0,(r2)
rts pc
.bss
exchange: .=.+2
width: .=.+2
source/fort/fx/fxx.s
+100
View File
@@ -0,0 +1,100 @@
/
/
/ fxx -- data segment definition
.data
.globl holround
holround: 4
.bss
/ pass 1
.globl dimu
dimu: .=.+2
/ pass 2
.globl eqvtab
/ pass 3 stuff
.globl conu
.globl dou
.globl blockp
.globl dotabp
.globl dotab
.globl edotab
.globl functn
.globl blocks
conu: .=.+2
dou: .=.+2
blockp: .=.+2
dotabp: .=.+2
dotab: .=.+60.
edotab:
functn: .=.+2
/ pass 4
.globl negflg
.globl repfact
.globl contab
.globl dattab
negflg: .=.+2
repfact:.=.+2
/ general buffer
xbufsiz = 2200.
.globl xbuf
xbuf: .=.+xbufsiz
eqvtab = xbuf+518. / for pass 2
blocks = xbuf / for pass 3
dattab = xbuf+518. / for pass 4
contab = xbuf+xbufsiz
/ for all passes
data:
ibuf: .=.+518.
obuf: .=.+518.
tbuf: .=.+518.
line: .=.+linsize
eline: .=.+4
ifno: .=.+2
efno: .=.+2
errp: .=.+2 / init(errb)
errb: .=.+12.
eerrb: / size 0 mod 4
symtab: .=.+symsize
esymtab:
esymp: .=.+2 / init(esymtab)
symtp: .=.+2
namebuf:.=.+namsize
enamebuf:
namep: .=.+2 / init(namebuf)
.=.+40 /fake
.=.+1 / make odd
symbuf: .=.+smblsize / init(<_>)
esymbuf:
ch: .=.+1
ch1: .=.+1
progt: .=.+2
holquo: .=.+2
nxtaloc:.=.+2
imptab: .=.+[26.*2*2] / 26 letters, 2 alphabets, 2 bytes
nerror: .=.+2
temp: .=.+2
functm: .=.+2
edata:
dsize =.-data
source/fort/io/io1.s
+78
View File
@@ -0,0 +1,78 @@
/
/
/ io1 -- I/O operators
.globl rerr
.globl endio
.globl rio4
.globl rio8
.globl iio2
.globl iio4
.globl lio2
.globl lio1
.globl cio8
.globl cio16
.globl ecvt
.globl fcvt
.globl _ndigit
endio:
mov (sp)+,r5
rts r5
cio8:
tst slcnt
bne 2f
inc slcnt
tst -(r4)
br rio4
2:
clr slcnt
mov ilval,-(sp)
add $4,(sp)
br rio4
cio16:
tst slcnt
bne 2f
inc slcnt
tst -(r4)
br rio8
2:
clr slcnt
mov ilval,-(sp)
add $8,(sp)
br rio8
rio8:
mov $8.\<8+'r,r0
br 1f
rio4:
mov $4\<8+'r,r0
br 1f
iio4:
mov $4\<8+'i,r0
br 1f
iio2:
mov $2\<8+'i,r0
br 1f
lio2:
mov $2\<8+'l,r0
br 1f
lio1:
mov $1\<8+'l,r0
1:
mov r0,itype
mov (sp)+,ilval
mov (sp)+,r5
tst (r5)+
rts r5
source/fort/io/io2.s
+268
View File
@@ -0,0 +1,268 @@
/
/
/ io2 -- format cracker
.globl iowf
.globl iowp
.globl iorf
iowp:
mov (sp)+,formp
mov $6,r1
br 1f
iowf:
mov (sp)+,formp
tst (sp)+
mov (sp)+,r1
1:
jsr r5,setio; 2 / write
clr rdflg
br 1f
iorf:
mov (sp)+,formp
tst (sp)+
mov (sp)+,r1
jsr r5,setio; 1 / read
mov pc,rdflg
1:
clr binflg
clr slcnt
clr itmfnd
clr scale
clr itmflg
mov $pbuf,ppar
mov $-1,llpcnt
jsr r5,fmtchr
mov formp,llp
cmp r0,$'(
beq crack
jsr r5,rerr; 106.
sys exit
crack:
clr ngflg
mov $1,rep
item:
jsr r5,fmtchr
cmp $' ,r0
beq item
cmp $'\t,r0
beq item
jsr r5,switch; mswitch
jsr r5,rerr; 105.
sys exit
mswitch:
'a; afmt
'f; ffmt
'e; efmt
'g; gfmt
'd; dfmt
'i; ifmt
'l; lfmt
'h; hfmt
'x; xfmt
'p; scal
'-; minus
'0; numb
'1; numb
'2; numb
'3; numb
'4; numb
'5; numb
'6; numb
'7; numb
'8; numb
'9; numb
',; crack
'/; slash
'(; lpar
'); rpar
'"; quote
' ; item
0; 0
minus:
jsr r5,gnum
neg r0
br 1f
numb:
dec formp
jsr r5,gnum
1:
mov r0,rep
br item
scal:
mov rep,scale
br crack
elist:
tst _nocr
beq 1f
tst rdflg
bne 1f
jsr r5,eorec1
br 2f
1:
jsr r5,eorec
2:
jmp *(r4)+
slash:
jsr r5,eorec
br crack
rpar:
mov ppar,r0
cmp r0,$pbuf / see if outer parens
blos 2f
dec -2(r0)
ble 1f / no repeats left
mov -4(r0),formp / reset scan
br crack
1:
sub $4,ppar
br crack / pop parens
2:
jsr r5,getitm
br elist
tst itmfnd
bne 1f
jsr r5,rerr; 107.
sys exit
1:
jsr r5,eorec
inc itmflg
mov llpcnt,r1
bpl 1f
mov llp,formp
jmp crack
1:
mov llp,r2
mov r2,formp
mov ppar,r0
mov r2,(r0)+
mov r1,(r0)+
mov r0,ppar
jbr crack1
lpar:
mov ppar,r0
cmp r0,$pbuf+10
blo 1f
jsr r5,rerr; 108.
sys exit
1:
mov formp,(r0)+
mov rep,(r0)+
mov r0,ppar
cmp r0,$pbuf+4
bhi 1f
mov formp,llp
mov rep,llpcnt
1:
jmp crack
quote:
inc ngflg
mov $44,-(sp)
br 3f
hfmt:
inc ngflg
mov $40,-(sp)
br 3f
xfmt:
inc ngflg
mov $34,-(sp)
br 3f
afmt:
mov $30,-(sp)
br 1f
ifmt:
clr -(sp)
br 1f
lfmt:
mov $4,-(sp)
1:
jsr r5,gnum
mov r0,width
br 2f
ffmt:
mov $10,-(sp)
br 1f
dfmt:
mov $14,-(sp)
br 1f
gfmt:
mov $20,-(sp)
br 1f
efmt:
mov $24,-(sp)
1:
jsr r5,gnum
mov r0,width
4:
jsr r5,fmtchr
cmp r0,$' /
beq 4b
cmp r0,$'.
bne err1
jsr r5,gnum
mov r0,ndig
2:
inc itmfnd
3:
add $cvsw,(sp)
tst rdflg
beq 1f
add $2,(sp)
1:
mov *(sp)+,-(sp)
1:
tst ngflg
bne 2f
jsr r5,getitm
br 1f
2:
clr gflg
jsr r5,*(sp)
dec rep
bgt 1b
tst (sp)+
br crack1
1:
tst (sp)+
jmp elist
cvsw:
iocv; iicv / 0
locv; licv / 4
focv; ficv / 10
docv; dicv / 14
gocv; gicv / 20
eocv; eicv / 24
aocv; aicv / 30
xocv; xicv / 34
hocv; hicv / 40
qocv; qicv / 44
crack1:
jmp crack
err1:
jsr r5,rerr; 109.
sys exit
source/fort/io/io3.s
+299
View File
@@ -0,0 +1,299 @@
/
/
/ io3 -- Fortran I/O
.globl getbuf
.globl chkunit
.globl creatf
.globl openf
setio:
mov r1,unit
jsr r5,chkunit
movb utable(r1),r0
beq 1f
bpl 2f
mov r1,r0
asl r0
mov btable(r0),r0
mov r0,r2
br 4f
2:
cmp (r5),r0
beq 3f
jsr r5,rerr; 101. / inconsistent use of unit
sys exit
1:
mov r1,-(sp)
clr r0
dvd $10.,r0
swab r1
bis r1,r0
add $"00,r0
mov r0,filnam+4
mov (sp)+,r1
jsr r5,getbuf
mov $filnam,r0
4:
movb (r5),utable(r1)
bit $1,(r5)
bne 2f
jsr r5,creatf
br 3f
2:
jsr r5,openf
3:
tst (r5)+
asl r1
mov btable(r1),buffer
rts r5
getbuf:
mov $utable,r0
mov $btable,r2
1:
tstb (r0)+
beq 2f
tst (r2)+
br 3f
2:
tst (r2)+
beq 3f
mov -(r2),r0
clr (r2)
mov r0,r2
br 2f
3:
cmp r0,$utable+20.
blo 1b
mov bufp,r2
add $134.,bufp
mov bufp,0f
sys break; 0:..
2:
mov r1,r0
asl r0
mov r2,btable(r0)
mov r2,buffer
rts r5
chkunit:
cmp r1,$20.
blo 1f
jsr r5,rerr; 100. / illegal unit number
sys exit
1:
rts r5
creatf:
cmp unit,$6
bne 2f
mov $1,r0
br 1f
2:
mov r0,0f
sys creat; 0:..; 666
bec 1f
jsr r5,rerr; 102. / create error
sys exit
1:
mov r2,-(sp)
mov r0,(r2)+
clr (r2)+
clr (r2)+
mov r2,-(r2)
mov (sp)+,r2
rts r5
openf:
cmp unit,$5
bne 2f
clr r0
br 1f
2:
mov r0,0f
sys open; 0:..; 0
bec 1f
jsr r5,rerr; 103. / open error
sys exit
1:
mov r2,-(sp)
mov r0,(r2)+
clr (r2)+
clr (r2)+
mov (sp)+,r2
rts r5
fputc:
mov r1,-(sp)
mov buffer,r1
dec 2(r1)
bge 1f
mov r0,-(sp)
jsr pc,flush1
dec 2(r1)
mov (sp)+,r0
1:
movb r0,*4(r1)
inc 4(r1)
mov (sp)+,r1
rts r5
fflush:
mov r1,-(sp)
mov buffer,r1
jsr pc,flush1
mov (sp)+,r1
rts r5
flush1:
mov r1,r0
add $6,r0
mov r0,-(sp)
mov r0,0f
neg r0
add 4(r1),r0
bhis 1f
mov r0,0f+2
mov (r1),r0
sys write; 0:..; ..
1:
mov (sp)+,4(r1)
mov $128.,2(r1)
rts pc
fgetc:
tst nlflg
bne 4f
mov r1,-(sp)
mov buffer,r1
dec 2(r1)
bge 1f
mov r1,r0
add $6,r0
mov r0,0f
mov r0,4(r1)
mov (r1),r0
sys read; 0:..; 128.
bes 2f
tst r0
bne 3f
2:
jsr r5,rerr; 104. / EOF on input
sys exit
3:
dec r0
mov r0,2(r1)
1:
clr r0
bisb *4(r1),r0
inc 4(r1)
mov (sp)+,r1
tst binflg
bne 1f
cmp r0,$'\n
bne 1f
4:
mov pc,nlflg
mov $' ,r0
1:
rts r5
gnum:
mov r1,-(sp)
clr r1
1:
jsr r5,fmtchr
cmp r0,$' /
beq 1b
sub $'0,r0
cmp r0,$9.
bhi 1f
mpy $10.,r1
add r0,r1
br 1b
1:
mov r1,r0
mov (sp)+,r1
dec formp
rts r5
switch:
mov (r5)+,r1
1:
tst (r1)
beq 1f
cmp r0,(r1)+
bne 1b
tst (sp)+
jmp *(r1)
1:
rts r5
fmtchr:
movb *formp,r0
inc formp
rts r5
getitm:
tst itmflg
bne 1f
mov r5,-(sp)
jmp *(r4)+
1:
clr itmflg
tst (r5)+
rts r5
/ just a fake, there's no carriage control
fputcc:
cmp $' ,r0
bne 1f
inc nspace
rts r5
1:
mov r0,-(sp)
1:
dec nspace
blt 1f
mov $' ,r0
jsr r5,fputc
br 1b
1:
clr nspace
mov (sp)+,r0
beq 1f
jsr r5,fputc
1:
rts r5
eorec:
mov unit,r0
bitb $1,utable(r0)
bne 1f
clr nspace
mov $'\n,r0
jsr r5,fputc
eorec1:
clr r0
jsr r5,fputcc
/ cmp unit,$6 / tty output
/ bne 2f
jsr r5,fflush
2:
rts r5
1:
tst nlflg
bne 1f
jsr r5,fgetc
br 1b
1:
clr nlflg
rts r5
spaces:
add r1,nspace
rts r5
source/fort/io/io4.s
+231
View File
@@ -0,0 +1,231 @@
/
/
/ io4 -- numeric output conversion
qicv:
hicv:
jsr r5,rerr; 999.
sys exit
xicv:
jsr r5,fgetc
rts r5
gocv:
mov pc,gflg
jsr r5,getarg
mov ndig,_ndigit
jsr pc,ecvt
tst r2
bmi eocv
cmp r2,ndig
bgt eocv
sub r2,ndig
sub $4,width
jsr r5,focv
add $4,width
add $4,nspace
rts r5
eocv:
mov $'e,-(sp)
br 1f
docv:
mov $'d,-(sp)
1:
tst gflg
bne 1f
jsr r5,getarg
1:
mov ndig,r1
add $6,r1
add nflg,r1
sub width,r1
bge 2f
sub r1,nspace
2:
tst nflg
beq 2f
mov $'-,r0
jsr r5,fputcc
2:
mov ndig,r1
mov scale,r0
bgt 2f
add r0,r1
br 3f
2:
inc r1
3:
mov r1,_ndigit
jsr pc,ecvt
mov r0,r1
mov r2,-(sp)
mov scale,r2
sub r2,(sp)
tst r2
bgt 2f
mov $'0,r0
jsr r5,fputcc
br 3f
2:
movb (r1)+,r0
dec _ndigit
jsr r5,fputcc
sob r2,2b
3:
mov $'.,r0
jsr r5,fputcc
neg r2
ble 2f
3:
mov $'0,r0
jsr r5,fputcc
sob r2,3b
2:
mov _ndigit,r2
ble 2f
3:
movb (r1)+,r0
jsr r5,fputcc
sob r2,3b
2:
mov 2(sp),r0
jsr r5,fputcc
mov (sp)+,r1
bge 2f
mov $'-,r0
jsr r5,fputcc
neg r1
br 3f
2:
mov $'+,r0
jsr r5,fputcc
3:
clr r0
div $10.,r0
add $'0,r0
jsr r5,fputcc
mov r1,r0
add $'0,r0
jsr r5,fputcc
tst (sp)+
rts r5
iocv:
clr -(sp)
clr ndig
br 1f
focv:
mov $1,-(sp)
1:
clr -(sp)
tst gflg
bne 1f
jsr r5,getarg
tst 2(sp)
beq 1f
mov scale,(sp)
1:
mov ndig,_ndigit
add (sp)+,_ndigit
jsr pc,fcvt
mov r0,r1
tst (sp)
beq 1f
tst gflg
bne 1f
add scale,r2
1:
mov ndig,r0
add (sp),r0
add nflg,r0
tst r2
ble 1f
add r2,r0
br 2f
1:
inc r0
2:
sub width,r0
bge 1f
sub r0,nspace
1:
tst nflg
beq 1f
mov $'-,r0
jsr r5,fputcc
1:
tst r2
bgt 1f
mov $'0,r0
jsr r5,fputcc
br 2f
1:
movb (r1)+,r0
jsr r5,fputcc
sob r2,1b
2:
tst (sp)+
beq 1f
mov $'.,r0
jsr r5,fputcc
1:
mov ndig,-(sp)
ble 1f
tst r2
bge 1f
neg r2
2:
mov $'0,r0
jsr r5,fputcc
dec ndig
ble 1f
sob r2,2b
1:
mov ndig,r2
ble 2f
1:
movb (r1)+,r0
jsr r5,fputcc
sob r2,1b
2:
mov (sp)+,ndig
rts r5
getarg:
clr nflg
setd
cmpb itype,$'r
beq 1f
seti
cmpb ilen,$4
bne 2f
setl
2:
cmpb ilen,$1
beq 3f
movif *ilval,r0
br 2f
3:
movb *ilval,r0
movif r0,fr0
br 2f
1:
cmpb ilen,$4
bne 1f
movof *ilval,r0
br 2f
1:
movf *ilval,r0
2:
cfcc
bge 1f
absf r0
mov $1,nflg
1:
rts r5
source/fort/io/io5.s
+96
View File
@@ -0,0 +1,96 @@
/
/
/ io5 -- more conversions
/.globl hocv
/.globl qocv
/.globl xocv
/.globl aocv
/.globl locv
/
/.globl fmtchr
/.globl fputcc
/.globl rep
/.globl formp
/.globl spaces
/.globl ilen
/.globl width
/.globl ilval
.globl rerr
hocv:
jsr r5,fmtchr
tst r0
beq 2f
jsr r5,fputcc
dec rep
bgt hocv
rts r5
2:
jsr r5,rerr; 111.
sys exit
qocv:
mov formp,-(sp)
1:
jsr r5,fmtchr
tst r0
beq 2f
cmp r0,$'"
beq 2f
jsr r5,fputcc
br 1b
2:
dec rep
ble 1f
mov (sp),formp
br 1b
1:
tst (sp)+
rts r5
xocv:
mov $1,r1
jsr r5,spaces
rts r5
aocv:
movb ilen,r1
sub width,r1
neg r1
bpl 1f
clr r1
1:
jsr r5,spaces
mov ilval,r2
mov width,r1
cmpb r1,ilen
ble 2f
movb ilen,r1
2:
movb (r2)+,r0
jsr r5,fputcc
dec r1
bgt 2b
rts r5
locv:
mov width,r1
dec r1
jsr r5,spaces
mov $'f,r0
movb ilen,r1
mov ilval,r2
2:
tstb (r2)+
bne 1f
dec r1
bgt 2b
br 2f
1:
mov $'t,r0
2:
jsr r5,fputcc
rts r5
source/fort/io/io6.s
+248
View File
@@ -0,0 +1,248 @@
/
/
/ io6 -- input conversions
/.globl aicv
/.globl gicv
/
/.globl ilval
/.globl width
/.globl ilen
/.globl fgetc
/.globl itype
/.globl nlflg
/.globl gcflg
aicv:
mov ilval,r1
movb width,r2
movb ilen,r0
mov r0,-(sp)
1:
cmp r2,(sp)
ble 1f
jsr r5,fgetc
dec r2
br 1b
1:
tst r2
ble 1f
jsr r5,fgetc
movb r0,(r1)+
dec r2
dec (sp)
br 1b
1:
tst (sp)
ble 1f
movb $' ,(r1)+
dec (sp)
br 1b
1:
tst (sp)+
rts r5
licv:
mov width,twidth
setd
seti
clrf fr0
1:
jsr r5,fgetcn
cmp r0,$'t
beq 2f
cmp r0,$'T
beq 2f
cmp r0,$'1
beq 2f
cmp r0,$',
beq 1f
br 1b
2:
movif $1,fr0
br 1b
1:
br storin
iicv:
clr ndig
ficv:
eicv:
dicv:
mov width,twidth
br 1f
gicv:
mov $16383.,twidth
clr ndig
mov pc,gcflg
br 2f
1:
clr gcflg
2:
jsr r5,gatof
storin:
cmpb itype,$'r
beq 1f
cmpb ilen,$1
beq 3f
cmpb ilen,$4
bne 2f
setl
2:
movfi fr0,*ilval
rts r5
3:
movfi fr0,r0
movb r0,*ilval
rts r5
1:
cmpb ilen,$8.
beq 2f
setf
2:
movf fr0,*ilval
rts r5
gatof:
setd
seti
movif $10.,fr3
clr r2
clrf fr0
clr -(sp)
1:
jsr r5,fgetcn
cmp $' ,r0
bne 1f
tst nlflg
beq 1b
tst (sp)+
rts r5
1:
cmp r0,$'+
beq 1f
cmp r0,$'-
bne 2f
inc (sp)
1:
jsr r5,fgetcn
2:
cmp $' ,r0
bne 3f
tst gcflg
bne 3f
mov $'0,r0
3:
sub $'0,r0
cmp r0,$9.
bhi 2f
mulf fr3,fr0
movif r0,fr1
addf fr1,fr0
dec r1
br 1b
2:
add $'0,r0
cmp r0,$'.
bne 1f
inc r2
clr r1
br 1b
1:
mov r3,-(sp)
clr r3
cmp r0,$'d
beq 3f
cmp r0,$'+
beq 3f
cmp r0,$'-
beq 3f
cmp r0,$'e
bne 2f
3:
jsr r5,atoi
2:
tst r2
bne 1f
mov ndig,r1
neg r1
1:
movf fr3,fr2
add r3,r1
mov (sp)+,r3
tst r1
beq 1f
bpl 3f
neg r1
mov pc,-(sp)
br 2f
3:
clr -(sp)
2:
dec r1
ble 2f
mulf fr3,fr2
br 2b
2:
tst (sp)+
bne 2f
mulf fr2,fr0
br 1f
2:
divf fr2,fr0
1:
tst (sp)+
beq 1f
negf r0
1:
cmp r0,$',
beq 1f
cmp $' ,r0
beq 1f
jsr r5,rerr; 110.
1:
rts r5
atoi:
clr -(sp)
cmp r0,$'+
beq 1f
cmp r0,$'-
beq 3f
jsr r5,fgetcn
cmp r0,$'+
beq 1f
cmp r0,$'-
bne 2f
3:
inc (sp)
1:
jsr r5,fgetcn
2:
sub $'0,r0
cmp r0,$'9.
bhi 2f
mpy $10.,r3
add r0,r3
br 1b
2:
add $'0,r0
tst (sp)+
beq 1f
neg r3
1:
rts r5
fgetcn:
tst twidth
bgt 1f
mov $',,r0
rts r5
1:
jsr r5,fgetc
dec twidth
rts r5
source/fort/io/io7.s
+62
View File
@@ -0,0 +1,62 @@
/
/
/ Fortran binary I/O
.globl iowu
.globl ioru
.globl rewi
.globl enfl
iowu:
tst (sp)+
mov (sp)+,r1 / unit number
jsr r5,setio; 42
1:
jsr r5,getitm
br 1f
movb ilen,r1
mov ilval,r2
2:
movb (r2)+,r0
jsr r5,fputc
sob r1,2b
br 1b
1:
jsr r5,fflush
jmp *(r4)+
ioru:
tst (sp)+
mov (sp)+,r1 / unit number
jsr r5,setio; 41
clr nlflg
mov pc,binflg
1:
jsr r5,getitm
br 1f
movb ilen,r1
mov ilval,r2
2:
jsr r5,fgetc
movb r0,(r2)+
sob r1,2b
br 1b
1:
jmp *(r4)+
rewi:
enfl:
tst (sp)+
mov (sp)+,r1 / unit number
jsr r5,chkunit
clrb utable(r1)
asl r1
mov *btable(r1),r0
cmp r0,$1
bhi 1f
sys seek; 0; 0
jmp *(r4)+
1:
sys close
jmp *(r4)+
source/fort/io/iox.s
+51
View File
@@ -0,0 +1,51 @@
/
/
/ iox -- io variables
.globl _nocr
.globl utable
.globl btable
.globl ftable
.globl _end
.globl formp
bufp: _end
filnam:
<fortxx\0>; .even
.bss
gflg: .=.+2
formp: .=.+2
rdflg: .=.+2
nflg: .=.+2
unit: .=.+2
buffer: .=.+2
slcnt: .=.+2
itype: .=.+1
ilen: .=.+1
ilval: .=.+2
width: .=.+2
twidth: .=.+2
ndig: .=.+2
pbuf: .=.+10
ppar: .=.+2
llp: .=.+2
llpcnt: .=.+2
itmflg: .=.+2
nspace: .=.+2
gcflg: .=.+2
binflg: .=.+2
utable: .=.+20.
btable: .=.+40.
ftable: .=.+2.
rep: .=.+2
scale: .=.+2
itmfnd: .=.+2
ngflg: .=.+2
nlflg: .=.+2
_nocr: .=.+2
source/fort/rt/r0.s
+50
View File
@@ -0,0 +1,50 @@
/
/
.globl main
.globl temp
.globl rerr
.globl fptrap
.comm erret,2
.comm argp,2
ldfps = 170100^tst
sys signal; 4; fptrap
ldfps $5400
mov sp,argp
mov $main,r4
jmp *(r4)+
rerr:
mov (r5)+,r1
tst erret
beq 1f
jsr pc,erret
1:
mov $temp,r2
jsr r5,1f
movb $'\n,(r2)+
sub $mesg,r2
mov r2,0f
mov $2,r0
sys write; mesg; 0:..
sys exit
1:
clr r0
div $10.,r0
mov r1,-(sp)
mov r0,r1
beq 1f
jsr r5,1b
1:
mov (sp)+,r0
add $'0,r0
movb r0,(r2)+
rts r5
mesg:
<Runtime error >
temp: .=.+16.
source/fort/rt/r1.s
+147
View File
@@ -0,0 +1,147 @@
/
/
/ r1 -- fortran runtime
.globl gas1
.globl gas2
.globl gas4
.globl gas8
.globl stop
.globl lval
.globl rval4
.globl rval8
.globl do1
.globl do12
.globl do14
.globl do2
.globl do22
.globl do24
.globl goto
.globl cgoto
.globl cagoto
.globl agoto
.globl rerr
gas8:
mov 8.(sp),r0
mov (sp)+,(r0)+
mov (sp)+,(r0)+
br 1f
gas1:
movb (sp)+,*(sp)+
jmp *(r4)+
gas2:
mov (sp)+,*(sp)+
jmp *(r4)+
gas4:
mov 4(sp),r0
1:
mov (sp)+,(r0)+
mov (sp)+,(r0)
tst (sp)+
jmp *(r4)+
stop:
sys exit
lval:
mov (r4)+,-(sp)
jmp *(r4)+
rval8:
mov (r4)+,r0
add $8.,r0
mov -(r0),-(sp)
mov -(r0),-(sp)
mov -(r0),-(sp)
mov -(r0),-(sp)
jmp *(r4)+
rval4:
mov (r4)+,r0
mov 2(r0),-(sp)
mov (r0),-(sp)
jmp *(r4)+
do22:
mov (sp)+,r1
br 1f
do12:
mov $1,r1
1:
mov (sp)+,r2
mov (sp)+,r0
add r1,(r0)
cmp (r0),r2
bgt goto
tst (r4)+
jmp *(r4)+
do24:
do2:
mov (sp)+,r2
mov (sp)+,r1
br 1f
do14:
do1:
clr r2
mov $1,r1
1:
mov 4(sp),r0
add r1,2(r0)
adc r2
add r2,(r0)
cmp (r0)+,(sp)+
bgt 1f
blt 2f
cmp (r0),(sp)
bhi 1f
2:
cmp (sp)+,(sp)+
tst (r4)+
jmp *(r4)+
1:
cmp (sp)+,(sp)+
goto:
mov (r4),r4
jmp *(r4)+
cgoto:
tst (sp)+
mov (sp)+,r0
asl r0
add r4,r0
1:
tst (r4)+
beq gotoe
cmp r0,r4
bne 1b
mov -(r0),r4
jmp *(r4)+
cagoto:
tst (sp)+
mov (sp)+,r0
1:
tst (r4)
beq gotoe
cmp r0,(r4)+
bne 1b
mov r0,r4
jmp *(r4)+
agoto:
tst (sp)+
mov (sp)+,r4
jmp *(r4)+
gotoe:
jsr r5,rerr; 14.
source/fort/rt/r2.s
+143
View File
@@ -0,0 +1,143 @@
/
/
/ r2 -- comparison of 4-byte integers
.globl ilt4
.globl ile4
.globl ieq4
.globl ine4
.globl ige4
.globl igt4
.globl lan2
.globl lor2
.globl lnt2
.globl ieq2
.globl ile2
.globl igt2
.globl ige2
.globl leq2
.globl ine2
.globl ilt2
.globl lne2
.globl leq1
.globl lne1
ilt4:
jsr pc,compar
blt one
br zero
blo one
br zero
ile4:
jsr pc,compar
ble one
br zero
blos one
br zero
ieq4:
jsr pc,compar
beq one
br zero
beq one
br zero
ine4:
jsr pc,compar
bne one
br zero
bne one
br zero
ige4:
jsr pc,compar
bge one
br zero
bhis one
br zero
igt4:
jsr pc,compar
bgt one
br zero
bhi one
br zero
one:
mov $1,(sp)
jmp *(r4)+
zero:
clr (sp)
jmp *(r4)+
compar:
mov (sp)+,r0
mov (sp)+,r1
mov (sp)+,r2
cmp (sp)+,r1
beq 1f
jmp (r0)
1:
cmp (sp),r2
jmp 4(r0)
lor2:
bis (sp)+,(sp)
jmp *(r4)+
lan2:
tst (sp)+
bne 1f
clr (sp)
1:
jmp *(r4)+
lnt2:
tst (sp)
beq one
br zero
ieq2:
leq2:
cmp (sp)+,(sp)
beq one
br zero
ilt2: cmp (sp)+,(sp)
bgt one
br zero
ile2:
cmp (sp)+,(sp)
bge one
br zero
igt2:
cmp (sp)+,(sp)
blt one
br zero
ige2:
cmp (sp)+,(sp)
ble one
br zero
ine2:
lne2:
cmp (sp)+,(sp)
bne one
br zero
leq1:
cmpb (sp)+,(sp)
beq one
br zero
lne1:
cmpb (sp)+,(sp)
bne one
br zero
source/fort/rt/r3.s
+50
View File
@@ -0,0 +1,50 @@
/
/
/ r3 -- comparisons
.globl lif2
.globl lif1
.globl rif4
.globl iif2
.globl iif4
.globl rif8
lif2:
lif1:
tst (sp)+
bne 1f
mov (r4),r4
jmp *(r4)+
1:
tst (r4)+
jmp *(r4)+
rif8:
setd
tstf (sp)+
cfcc
br 2f
iif4:
rif4:
mov (sp)+,r0
mov (sp)+,r1
tst r0
bne 2f
tst r1
cln
br 2f
iif2:
tst (sp)+
2:
bmi 1f
beq 2f
tst (r4)+
2:
tst (r4)+
1:
mov (r4),r4
jmp *(r4)+
source/fort/rt/r4.s
+65
View File
@@ -0,0 +1,65 @@
/
/
/ r4 -- short integer arithmetic
.globl iad2
.globl isb2
.globl imp2
.globl idv2
.globl i2i4
.globl i1i4
.globl i4i2
.globl i4i1
.globl ing2
.globl rval2
.globl rval1
.globl l2l1
iad2:
add (sp)+,(sp)
jmp *(r4)+
isb2:
sub (sp)+,(sp)
jmp *(r4)+
imp2:
mov (sp)+,r1
mul (sp)+,r1
mov r1,-(sp)
jmp *(r4)+
idv2:
mov 2(sp),r1
sxt r0
div (sp)+,r0
mov r0,(sp)
jmp *(r4)+
i4i2:
i4i1:
tst (sp)+
jmp *(r4)+
i2i4:
i1i4:
tst (sp)
sxt -(sp)
jmp *(r4)+
ing2:
neg (sp)
jmp *(r4)+
rval2:
mov *(r4)+,-(sp)
jmp *(r4)+
rval1:
movb *(r4)+,r0
mov r0,-(sp)
l2l1:
jmp *(r4)+
source/fort/rt/r5.s
+49
View File
@@ -0,0 +1,49 @@
/
/
/ r5 -- long integer arithmetic
.globl iad4
.globl isb4
.globl imp4
.globl idv4
.globl ing4
.globl rerr
iad4:
jsr pc,load
addf fr0,fr1
br store
isb4:
jsr pc,load
subf fr0,fr1
br store
imp4:
jsr pc,load
mulf fr0,fr1
br store
idv4:
jsr pc,load
divf fr0,fr1
store:
movfi fr1,-(sp)
jmp *(r4)+
load:
mov (sp)+,r0
setd
setl
movif (sp)+,fr0
movif (sp)+,fr1
jmp (r0)
ing4:
neg (sp)
neg 2(sp)
sbc (sp)
jmp *(r4)+
source/fort/rt/r6.s
+137
View File
@@ -0,0 +1,137 @@
/
/
/ r6 -- real arithmetic
.globl rad4
.globl rad8
.globl rsb4
.globl rsb8
.globl rmp4
.globl rmp8
.globl rdv4
.globl rdv8
.globl rng4
.globl rng8
.globl r4r8
.globl r8r4
.globl i4r4
.globl i2r4
.globl r4i4
.globl r8i2
.globl i2r8
.globl r4i2
.globl i4r8
.globl r8i4
.globl rerr
rad8:
setd
br 1f
rad4:
setf
1:
movf (sp)+,fr0
addf (sp)+,fr0
br store
rsb8:
setd
br 1f
rsb4:
setf
1:
movf (sp)+,fr0
negf fr0
addf (sp)+,fr0
br store
rmp8:
setd
br 1f
rmp4:
setf
1:
movf (sp)+,fr0
mulf (sp)+,fr0
br store
rdv8:
setd
br 1f
rdv4:
setf
1:
movf (sp)+,fr1
movf (sp)+,fr0
divf fr1,fr0
store:
movf fr0,-(sp)
jmp *(r4)+
rng8:
setd
br 1f
rng4:
setf
1:
negf (sp)
jmp *(r4)+
r8r4:
setd
br 1f
r4r8:
setf
1:
movf (sp)+,fr0
movfo fr0,-(sp)
jmp *(r4)+
i2r8:
seti
br 1f
i4r8:
setl
1:
setd
br 2f
i2r4:
seti
br 1f
i4r4:
setl
1:
setf
2:
movif (sp)+,fr0
movf fr0,-(sp)
jmp *(r4)+
r8i2:
seti
br 1f
r8i4:
setl
1:
setd
br 2f
r4i2:
seti
br 1f
r4i4:
setl
1:
setf
2:
movf (sp)+,fr0
movfi fr0,-(sp)
jmp *(r4)+
source/fort/rt/r7.s
+124
View File
@@ -0,0 +1,124 @@
/
/
/ r7 -- fortran runtime
achk = 1 / 1 to check array bounds
.globl lvalp
.globl rval1p
.globl rval2p
.globl rval4p
.globl rval8p
.globl alval
.globl alvalp
.globl arval
.globl arvalp
.globl rerr
lvalp:
mov r3,r0
add (r4)+,r0
mov (r0)+,-(sp)
jmp *(r4)+
rval1p:
mov r3,r0
add (r4)+,r0
movb *(r0)+,-(sp)
jmp *(r4)+
rval2p:
mov r3,r0
add (r4)+,r0
mov *(r0)+,-(sp)
jmp *(r4)+
rval4p:
mov r3,r0
add (r4)+,r0
mov (r0),r0
cmp (r0)+,(r0)+
mov -(r0),-(sp)
mov -(r0),-(sp)
jmp *(r4)+
rval8p:
setd
mov r3,r0
add (r4)+,r0
movf *(r0)+,fr0
movf fr0,-(sp)
jmp *(r4)+
alval:
jsr r5,getsub; 1
mov (r4)+,-(sp)
add r1,(sp)
jmp *(r4)+
arvalp:
jsr r5,getsub; 0
mov r3,r2
add (r4)+,r2
mov (r2),r2
br 1f
arval:
jsr r5,getsub; 1
mov (r4)+,r2
1:
add r2,r1
mov -(r0),r2
asr r2
bcc 1f
movb (r1),-(sp)
jmp *(r4)+
1:
add (r0),r1
1:
mov -(r1),-(sp)
sob r2,1b
jmp *(r4)+
getsub:
tst (sp)+
mov (r4)+,r0
mov (r0)+,r2
clr r1
tst (r0)+
1:
tst (sp)+
dec (sp)
add (sp)+,r1
mpy (r0)+,r1
sob r2,1b
tst (r5)+
beq 2f
mov r1,-(sp)
mov -2(r4),r0
mov (r0)+,r2
inc r2
mov $1,r1
1:
mpy (r0)+,r1
sob r2,1b
.if achk
cmp r1,(sp)
bhi 1f
jsr r5,rerr; 15.
.endif
1:
mov (sp)+,r1
2:
jmp (r5)
alvalp:
jsr r5,getsub; 0
mov r3,r0
add (r4)+,r0
mov (r0),-(sp)
add r1,(sp)
jmp *(r4)+
source/fort/rt/r8.s
+32
View File
@@ -0,0 +1,32 @@
/
/
/ r8 - fortran runtime -- powers of integers
.globl ipi2
ipi2:
tst (sp)+
mov (sp)+,r0
bge 1f
clr (sp)
jmp *(r4)+
1:
mov (sp)+,r1
mov r3,-(sp)
mov $1,r3
1:
tst r0
beq 1f
asr r0
bcc 2f
mpy r1,r3
2:
mpy r1,r1
br 1b
1:
mov r3,r1
mov (sp)+,r3
mov r1,-(sp)
jmp *(r4)+
source/fort/rt/r9.s
+61
View File
@@ -0,0 +1,61 @@
/
/
one = 40200
/ r9 -- fortran runtime -- real**integer
.globl ipi4
.globl rpi4
.globl rpi8
.globl rerr
ipi4:
setf
setl
movif 4(sp),fr0
movf fr0,4(sp)
jsr r5,1f
movfi fr1,-(sp)
jmp *(r4)+
rpi4:
setf
br 2f
rpi8:
setd
2:
jsr r5,1f
movf fr1,-(sp)
jmp *(r4)+
1:
cmp (sp)+,(sp)+ / jsr + msp of i4
mov (sp)+,r0
movf $one,fr1
movf (sp)+,fr0
tst r0
bgt 1f
cfcc
beq 9f
tst r0
beq 3f
divf fr0,fr1
movf fr1,fr0
neg r0
movf $one,fr1
1:
asr r0
bcc 2f
mulf fr0,fr1
2:
tst r0
beq 3f
mulf fr0,fr0
br 1b
3:
jmp (r5)
9:
jsr r5, rerr; 17.
source/fort/rt/ra.s
+43
View File
@@ -0,0 +1,43 @@
/
/
/ ra -- fortran runtime -- real ** real
.globl rpr4
.globl rpr8
.globl log
.globl exp
.globl rerr
rpr8:
setd
br 1f
rpr4:
setf
1:
seti
movf (sp)+,fr1
movf (sp)+,fr0
cfcc
beq 3f / 0**x
movf fr1,-(sp)
jsr pc,log
bes error
mulf (sp)+,fr0
jsr pc,exp
bes error
2:
movf fr0,-(sp)
jmp *(r4)+
3:
tstf r1
cfcc
bgt 2b
error:
jsr r5,rerr; 17.
source/fort/rt/rb.s
+49
View File
@@ -0,0 +1,49 @@
/
/
/ rb -- funct/subr stuff
.globl call
.globl callp
.globl retrn
.globl stsp
callp:
mov (r4)+,r0
add r3,r0
mov (r0),r0
br 1f
call:
mov (r4)+,r0
1:
mov r3,-(sp)
mov (r4)+,r3
mov r4,-(sp)
mov r0,r4
mov (r4)+,-(sp) / lv of funct
jmp *(r4)+
retrn:
mov r3,r0
mov (sp)+,r1 / lv of funct
mov (sp)+,r4
mov (sp)+,r3
mov (r0),sp
tst (r4)+ / arg count
mov (r4)+,r0 / return byte count
inc r0
bic $1,r0
add r0,r1
1:
sub $2,r0
blt 1f
mov -(r1),-(sp)
br 1b
1:
jmp *(r4)+
stsp:
mov sp,*(r4)+
jmp *(r4)+
source/fort/rt/rc.s
+320
View File
@@ -0,0 +1,320 @@
/
/
/ rc -- complex arithmetic
.globl c8c16
.globl c16c8
.globl i4c8
.globl r4c8
.globl r8c8
.globl i4c16
.globl r4c16
.globl r8c16
.globl cad8
.globl csb8
.globl cmp8
.globl cdv8
.globl cng8
.globl cad16
.globl csb16
.globl cmp16
.globl cdv16
.globl cng16
.globl rval16
.globl rval16p
.globl gas16
.globl ceq8
.globl cne8
.globl ceq16
.globl cne16
.globl cpi8
.globl cpi16
one = 040200
a = r2
b = r3
c = r4
d = r5
e = r0
f = r1
gas16:
mov 16.(sp),r0
setd
movf (sp)+,a
movf (sp)+,b
tst (sp)+
movf a,(r0)+
movf b,(r0)+
jmp *(r4)+
rval16p:
mov r3,r0
add (r4)+,r0
mov (r0),r0
br 1f
rval16:
mov (r4)+,r0
1:
setd
movf (r0)+,a
movf (r0)+,b
movf b,-(sp)
movf a,-(sp)
jmp *(r4)+
cad16:
setd
br 1f
cad8:
setf
1:
jsr pc,garg
addf a,e
addf b,f
br sarg
csb16:
setd
br 1f
csb8:
setf
1:
jsr pc,garg
subf a,e
negf e
subf b,f
negf f
br sarg
cmp16:
setd
br 1f
cmp8:
setf
1:
jsr pc,garg
mulf a,e
mulf b,f
subf f,e
mulf d,a
mulf c,b
movf a,f
addf b,f
sarg:
movf f,-(sp)
movf e,-(sp)
jmp *(r4)+
cdv16:
setd
br 1f
cdv8:
setf
1:
divide:
jsr pc,garg
absf e
absf f
cmpf e,f
cfcc
blt 1f
/ algorithm #1 |c| > |d|
movf d,e
divf c,e / r = d/c
movf d,f
mulf e,f
addf c,f / x = c+rd
movf f,c
movf a,f
mulf e,f
negf f
addf b,f
mulf b,e
addf a,e
divf c,e
divf c,f
br sarg
/ algorithm #2 |c| < |d|
1:
movf c,e
divf d,e / r = c/d
movf c,f
mulf e,f
addf d,f / x = d+rc
movf f,c
movf b,f
mulf e,f
subf a,f
mulf a,e
addf b,e
divf c,e
divf c,f
br sarg
cng16:
setd
br 1f
cng8:
setf
1:
movf (sp)+,a
negf a
negf (sp)
movf a,-(sp)
jmp *(r4)+
/ setup the following registers
/ (a,bi) +o (c,di) -> (e+fi)
/ a,b,c,d are input
/ e,f are output and also contain
/ c,d on input
garg:
mov (sp)+,r0
movf (sp)+,e
movf e,c
movf (sp)+,f
movf f,d
movf (sp)+,a
movf (sp)+,b
jmp (r0)
i4c8:
setf
br 1f
i4c16:
setd
1:
setl
movif (sp)+,fr0
br 2f
r4c8:
setf
br 1f
r8c16:
setd
1:
movf (sp)+,fr0
br 2f
r4c16:
setd
br 1f
r8c8:
setf
1:
movof (sp)+,fr0
2:
clrf -(sp)
movf fr0,-(sp)
jmp *(r4)+
c16c8:
setd
br 1f
c8c16:
setf
1:
movf (sp)+,r0
movf (sp)+,r1
movfo r1,-(sp)
movfo r0,-(sp)
jmp *(r4)+
ceq16:
setd
br 1f
ceq8:
setf
1:
mov $1,r1
br 2f
cne16:
setd
br 1f
cne8:
setf
1:
clr r1
2:
jsr pc,garg
cmpf c,a
cfcc
bne 1f
cmpf d,b
cfcc
beq 2f
1:
inc r1
bic $2,r1
2:
mov r1,-(sp)
jmp *(r4)+
cpi8:
setf
br 1f
cpi16:
setd
1:
clr r0
tst (sp)+
mov (sp)+,r1
bge 1f
inc r0
neg r1
1:
movf (sp)+,fr0
movf fr0,fr4
movf (sp)+,fr0
movf fr0,fr5
movf $one,fr0
clrf fr1
1:
dec r1
bmi 1f
movf fr0,fr2
movf fr1,fr3
mulf fr4,fr0
mulf fr4,fr1
mulf fr5,fr2
mulf fr5,fr3
subf fr3,fr0
addf fr2,fr1
br 1b
1:
tst r0
beq 1f
clrf -(sp)
movf $one,fr2
movf fr2,-(sp)
movf fr1,-(sp)
movf fr0,-(sp)
jmp divide
1:
movf fr1,-(sp)
movf fr0,-(sp)
jmp *(r4)+
source/fort/rt/rd.s
+38
View File
@@ -0,0 +1,38 @@
/
/
/ rd -- short list I/O do loop
.globl slist1
.globl slist2
.globl slist3
.globl temp
slist1:
mov (r4)+,r0
mov (r0)+,r2
mov $1,r1
1:
mpy (r0)+,r1
sob r2,1b
mov $temp,r2
mov r1,(r2)+
clr (r2)+
mov (r0)+,(r2)+
jmp *(r4)+
slist2:
mov (r4)+,r0
dec temp
ble 1f
mov r0,r4
1:
jmp *(r4)+
slist3:
mov $temp+2,r0
add (r0)+,(sp)
add (r0),-(r0)
jmp *(r4)+
source/fort/rt/re.s
+57
View File
@@ -0,0 +1,57 @@
/
/
/ re -- comparison of 8-byte quantities
.globl rle8
.globl rlt8
.globl req8
.globl rne8
.globl rge8
.globl rgt8
rlt8:
jsr pc,compar
blt one
br zero
rle8:
jsr pc,compar
ble one
br zero
req8:
jsr pc,compar
beq one
br zero
rne8:
jsr pc,compar
bne one
br zero
rge8:
jsr pc,compar
bge one
br zero
rgt8:
jsr pc,compar
bgt one
br zero
one:
mov $1,-(sp)
jmp *(r4)+
zero:
clr -(sp)
jmp *(r4)+
compar:
setd
mov (sp)+,r0
movf (sp)+,fr0
cmpf (sp)+,fr0
cfcc
jmp (r0)
source/fort/rt/rf.s
+58
View File
@@ -0,0 +1,58 @@
/
/
/ rf -- real comparisons
.globl rlt4
.globl rle4
.globl req4
.globl rne4
.globl rge4
.globl rgt4
rlt4:
jsr pc,compar
blt one
br zero
rle4:
jsr pc,compar
ble one
br zero
req4:
jsr pc,compar
beq one
br zero
rne4:
jsr pc,compar
bne one
br zero
rge4:
jsr pc,compar
bge one
br zero
rgt4:
jsr pc,compar
bgt one
br zero
one:
mov $1,-(sp)
jmp *(r4)+
zero:
clr -(sp)
jmp *(r4)+
compar:
mov (sp)+,r0
setf
movf (sp)+,r0
cmpf (sp)+,r0
cfcc
jmp (r0)
source/fort/rt/rg.s
+87
View File
@@ -0,0 +1,87 @@
/
/
/ rg -- assignments
.globl gmv1
.globl gmv2
.globl gmv4
.globl gmv8
.globl gmv16
.globl stst
gmv1:
movb (sp)+,*(r4)+
jmp *(r4)+
gmv2:
stst:
mov (sp)+,*(r4)+
jmp *(r4)+
gmv4:
mov (r4)+,r0
mov (sp)+,(r0)+
mov (sp)+,(r0)+
jmp *(r4)+
gmv8:
setd
movf (sp)+,fr0
movf fr0,*(r4)+
jmp *(r4)+
gmv16:
setd
mov (r4)+,r0
movf (sp)+,fr0
movf fr0,(r0)+
movf (sp)+,fr0
movf fr0,(r0)+
jmp *(r4)+
.globl gmv1p
.globl gmv2p
.globl gmv4p
.globl gmv8p
.globl gmv16p
gmv1p:
mov (r4)+,r0
add r3,r0
movb (sp)+,*(r0)+
jmp *(r4)+
gmv2p:
mov (r4)+,r0
add r3,r0
mov (sp)+,*(r0)+
jmp *(r4)+
gmv4p:
mov (r4)+,r0
add r3,r0
mov (r0),r0
mov (sp)+,(r0)+
mov (sp)+,(r0)+
jmp *(r4)+
gmv8p:
setd
mov (r4)+,r0
add r3,r0
movf (sp)+,fr0
movf fr0,*(r0)+
jmp *(r4)+
gmv16p:
setd
mov (r4)+,r0
add r3,r0
mov (r0),r0
movf (sp)+,fr0
movf fr0,(r0)+
movf (sp)+,fr0
movf fr0,(r0)+
jmp *(r4)+
source/fort/rt/rh.s
+141
View File
@@ -0,0 +1,141 @@
/
/
/ rh -- simple array l/r values
achk = 1 / 1 to check array bounds
.globl gal1
.globl gal2
.globl gal4
.globl gal8
.globl gal16
.globl gar1
.globl gar2
.globl gar4
.globl gar8
.globl gar16
.globl rerr
gal1:
tst (sp)+
dec (sp)
br 1f
gal2:
tst (sp)+
dec (sp)
asl (sp)
br 1f
gal4:
tst (sp)+
dec (sp)
asl (sp)
asl (sp)
br 1f
gal8:
tst (sp)+
dec (sp)
asl (sp)
asl (sp)
asl (sp)
br 1f
gal16:
tst (sp)+
dec (sp)
asl (sp)
asl (sp)
asl (sp)
asl (sp)
1:
cmp (sp),(r4)+
.if achk
bhis 9f
.endif
add (r4)+,(sp)
jmp *(r4)+
9:
jsr r5,rerr; 15.
4
gar1:
tst (sp)+
dec (sp)
cmp (sp),(r4)+
.if achk
bhis 9b
.endif
add (r4)+,(sp)
movb *(sp)+,r0
mov r0,-(sp)
jmp *(r4)+
gar2:
tst (sp)+
dec (sp)
asl (sp)
cmp (sp),(r4)+
.if achk
bhis 9b
.endif
add (r4)+,(sp)
mov *(sp)+,-(sp)
jmp *(r4)+
gar4:
tst (sp)+
dec (sp)
mov (sp)+,r0
asl r0
asl r0
cmp r0,(r4)+
.if achk
bhis 9b
.endif
add (r4)+,r0
cmp (r0)+,(r0)+
mov -(r0),-(sp)
mov -(r0),-(sp)
jmp *(r4)+
gar8:
setd
tst (sp)+
dec (sp)
asl (sp)
asl (sp)
asl (sp)
cmp (sp),(r4)+
.if achk
bhis 9b
.endif
add (r4)+,(sp)
movf *(sp)+,fr0
movf fr0,-(sp)
jmp *(r4)+
gar16:
setd
tst (sp)+
dec (sp)
mov (sp)+,r0
asl r0
asl r0
asl r0
asl r0
cmp r0,(r4)+
.if achk
bhis 9b
.endif
add (r4)+,r0
movf (r0)+,fr0
movf (r0)+,fr1
movf fr1,-(sp)
movf fr0,-(sp)
jmp *(r4)+
source/fort/rt/rx.s
+10
View File
@@ -0,0 +1,10 @@
/
/
/ rtx -- last routine
.globl ecore
.bss
ecore:
source/fort/rt1/abs.s
+24
View File
@@ -0,0 +1,24 @@
/
/
/ abs & dabs fortran functions
.globl abs.
.globl dabs.
.globl retrn
.globl temp
dabs.: temp
.+2
setd
br 1f
abs.: temp
.+2
setf
1:
movf *2(r3),r0
absf r0
movf r0,temp
jmp retrn
source/fort/rt1/aimag.s
+19
View File
@@ -0,0 +1,19 @@
/
/
/ aimag fortran function
.globl aimag.
.globl rval8p
.globl retrn
.globl temp
aimag.: temp
rval8p; 2
.+2
setf
tstf (sp)+
movf (sp)+,r0
movf r0,temp
jmp retrn
source/fort/rt1/aint.s
+19
View File
@@ -0,0 +1,19 @@
/
/
/ aint fortran function
.globl aint.
.globl temp
one = 40200
.globl retrn
aint.: temp
.+2
setf
movf *2(r3),r0
modf $one,r0
movf r1,temp
jmp retrn
source/fort/rt1/alog.s
+31
View File
@@ -0,0 +1,31 @@
/
/
/ alog & log fortran functions
.globl alog.
.globl dlog.
.globl log
.globl retrn
.globl rerr
.globl temp
dlog.: temp
.+2
setd
br 1f
alog.: temp
.+2
setf
1:
seti
movf *2(r3),r0
jsr pc,log
bes 1f
movf r0,temp
jmp retrn
1:
jsr r5,rerr; 1
source/fort/rt1/alog10.s
+33
View File
@@ -0,0 +1,33 @@
/
/
/ alog10 & dlog10 fortran functions
.globl dlog10.
.globl alog10.
.globl log
.globl retrn
.globl rerr
.globl temp
dlog10.:temp
.+2
setd
br 1f
alog10.:temp
.+2
setf
1:
movf *2(r3),r0
jsr pc,log
bes 1f
mulf const,r0
movf r0,temp
jmp retrn
1:
jsr r5,rerr; 1
const: 37736;55730;124467;24146
source/fort/rt1/amax0.s
+44
View File
@@ -0,0 +1,44 @@
/
/
/ max0 & amax0 fortran functions
.globl amax0.
.globl max0.
.globl retrn
.globl temp
max0.: temp
.+2
mov pc,r2
br 1f
amax0.: temp
.+2
clr r2
1:
setf
setl
mov *2(sp),r0 / arg count
mov r3,r1
tst (r1)+ / argpp
movif *(r1)+,r1
br 2f
1:
movif *(r1)+,r0
cmpf r0,r1
cfcc
ble 2f
movf r0,r1
2:
dec r0
bgt 1b
tst r2
bne 1f
movf r1,temp
br 2f
1:
movfi r1,temp
2:
jmp retrn
source/fort/rt1/amax1.s
+52
View File
@@ -0,0 +1,52 @@
/
/
/ max1, amax1 & dmax1 fortran functions
.globl amax1.
.globl dmax1.
.globl max1.
.globl retrn
.globl temp
max1.: temp
.+2
setl
setf
mov pc,r2 / integer flag
br 2f
dmax1.: temp
.+2
setd
br 1f
amax1.: temp
.+2
setf
1:
clr r2 / integer flag
2:
mov *2(sp),r0 / arg count
mov r3,r1
tst (r1)+ / argpp
movf *(r1)+,r1
br 2f
1:
movf *(r1)+,r0
cmpf r0,r1
cfcc
ble 2f
movf r0,r1
2:
dec r0
bgt 1b
tst r2
bne 1f
movf r1,temp
br 2f
1:
movfi r1,temp
2:
jmp retrn
source/fort/rt1/amin0.s
+44
View File
@@ -0,0 +1,44 @@
/
/
/ min0 & amin0 fortran functions
.globl amin0.
.globl min0.
.globl retrn
.globl temp
min0.: temp
.+2
mov pc,r2
br 1f
amin0.: temp
.+2
clr r2
1:
setf
setl
mov *2(sp),r0 / arg count
mov r3,r1
tst (r1)+ / argpp
movif *(r1)+,r1
br 2f
1:
movif *(r1)+,r0
cmpf r0,r1
cfcc
bge 2f
movf r0,r1
2:
dec r0
bgt 1b
tst r2
bne 1f
movf r1,temp
br 2f
1:
movfi r1,temp
2:
jmp retrn
source/fort/rt1/amin1.s
+52
View File
@@ -0,0 +1,52 @@
/
/
/ min1, amin1 & dmin1 fortran functions
.globl amin1.
.globl dmin1.
.globl min1.
.globl retrn
.globl temp
min1.: temp
.+2
setl
setf
mov pc,r2
br 2f
dmin1.: temp
.+2
setd
br 1f
amin1.: temp
.+2
setf
1:
clr r2
2:
mov *2(sp),r0 / arg count
mov r3,r1
tst (r1)+ / argpp
movf *(r1)+,r1
br 2f
1:
movf *(r1)+,r0
cmpf r0,r1
cfcc
bge 2f
movf r0,r1
2:
dec r0
bgt 1b
tst r2
bne 1f
movf r1,temp
br 2f
1:
movfi r1,temp
2:
jmp retrn
source/fort/rt1/amod.s
+36
View File
@@ -0,0 +1,36 @@
/
/
/ amod & dmod fortran functions
.globl amod.
.globl dmod.
.globl retrn
one = 40200
.globl temp
.globl rerr
dmod.: temp
.+2
setd
br 1f
amod.: temp
.+2
setf
1:
cmp *2(sp),$2
bne 1f
movf *2(r3),r0
movf r0,r2
movf *4(r3),r1
divf r1,r2
modf $one,r2
mulf r1,r3
subf r3,r0
movf r0,temp
jmp retrn
1:
jsr r5,rerr; 2
source/fort/rt1/atan.s
+25
View File
@@ -0,0 +1,25 @@
/
/
/ atan & datan fortran functions
.globl atan.
.globl datan.
.globl atan
.globl retrn
.globl temp
datan.: temp
.+2
setd
br 1f
atan.: temp
.+2
setf
1:
movf *2(r3),r0
jsr pc,atan
movf r0,temp
jmp retrn
source/fort/rt1/atan2.s
+31
View File
@@ -0,0 +1,31 @@
/
/
/ atan2 & datan2 fortran functions
.globl atan2.
.globl datan2.
.globl retrn
.globl rerr
.globl temp
.globl atan2
datan2.: temp
.+2
setd
br 1f
atan2.: temp
.+2
setf
1:
cmp *2(sp),$2
bne 1f
movf *2(r3),r0
movf *4(r3),r1
jsr pc,atan2
movf r0,temp
jmp retrn
1:
jsr r5,rerr; 3
source/fort/rt1/cabs.s
+57
View File
@@ -0,0 +1,57 @@
/
/
/ cabs fortran function
.globl cabs.
.globl dcabs.
.globl sqrt
.globl retrn
.globl rerr
.globl temp
dcabs.: temp
.+2
setd
br 1f
cabs.: temp
.+2
setf
1:
mov 2(r3),r1
movf (r1)+,r0
movf (r1)+,r1
jsr pc,hypot
bes 1f
movf r0,temp
jmp retrn
1:
jsr r5,rerr; 4
hypot:
movf fr1,-(sp)
absf fr0
absf fr1
cmpf fr0,fr1
cfcc
bne 1f
movf $one,fr0
br 3f
1:
blt 2f
movf fr0,-(sp)
movf fr1,fr0
movf (sp)+,fr1
2:
divf fr1,fr0
mulf fr0,fr0
3:
addf $one,fr0
jsr pc,sqrt
mulf fr1,fr0
cfcc
movf (sp)+,fr1
rts pc
one = 40200
source/fort/rt1/ccos.f
+13
View File
@@ -0,0 +1,13 @@
function ccos(z1)
complex ccos, z1, z2
dimension dummy(2)
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = exp(b)
d = 1.0/c
b = sin(a)*(d-c)/2.0
a = cos(a)*(c+d)/2.0
ccos = z2
return
end
source/fort/rt1/cexp.s
+35
View File
@@ -0,0 +1,35 @@
/
/
/ cexp fortran function
.globl cexp.
.globl rval8p
.globl retrn
.globl temp
.globl rerr
.globl exp
.globl sin
.globl cos
cexp.: temp
rval8p; 2
.+2
setf
movf (sp)+,r0
jsr pc,exp
bes 1f
movf r0,temp
movf (sp),r0
jsr pc,sin
mulf temp,r0
movf r0,temp+4
movf (sp)+,r0
jsr pc,cos
mulf temp,r0
movf r0,temp
jmp retrn
1:
jsr r5,rerr; 5.
source/fort/rt1/clog.f
+12
View File
@@ -0,0 +1,12 @@
function clog(z1)
complex clog, z1, z2
dimension dummy(2)
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = cabs(z2)
b = atan2(b, a)
a = alog(c)
clog = z2
return
end
source/fort/rt1/cmplx.s
+34
View File
@@ -0,0 +1,34 @@
/
/
/ cmplx fortran function
.globl cmplx.
.globl dcmplx.
.globl retrn
.globl temp
.globl rerr
dcmplx.:temp
.+2
setd
br 1f
cmplx.: temp
.+2
setf
1:
cmp *2(sp),$2
bne 1f
mov r3,r1
tst (r1)+
movf *(r1)+,r0
movf *(r1)+,r1
mov $temp,r1
movf r0,(r1)+
movf r1,(r1)+
jmp retrn
1:
jsr r5,rerr; 6.
source/fort/rt1/conjg.s
+21
View File
@@ -0,0 +1,21 @@
/
/
/ conjg fortran function
.globl conjg.
.globl rval8p
.globl retrn
.globl temp
conjg.: temp
rval8p; 2
.+2
setf
movf (sp)+,r0
movf r0,temp
movf (sp)+,r0
negf r0
movf r0,temp+4
jmp retrn
source/fort/rt1/cos.s
+25
View File
@@ -0,0 +1,25 @@
/
/
/ cos & dcos fortran functions
.globl cos.
.globl dcos.
.globl cos
.globl retrn
.globl temp
dcos.: temp
.+2
setd
br 1f
cos.: temp
.+2
setf
1:
movf *2(r3),r0
jsr pc,cos
movf r0,temp
jmp retrn
source/fort/rt1/csin.f
+13
View File
@@ -0,0 +1,13 @@
function csin(z1)
complex csin, z1, z2
dimension dummy(2)
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = exp(b)
d = 1.0/c
b = cos(a)*(c-d)/2.0
a = sin(a)*(c+d)/2.0
csin = z2
return
end
source/fort/rt1/csqrt.f
+14
View File
@@ -0,0 +1,14 @@
function csqrt(z1)
complex csqrt, z1, z2
dimension dummy(2)
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = cabs(z2)
c = sqrt(c)
b = atan2(b, a)/2.0
a = c*cos(b)
b = c*sin(b)
csqrt = z2
return
end
source/fort/rt1/dble.s
+20
View File
@@ -0,0 +1,20 @@
/
/
/ dble fortran function
.globl dble.
.globl rval4p
.globl lval
.globl r4r8
.globl gas8
.globl retrn
.globl temp
dble.: temp
lval; temp
rval4p; 2
r4r8
gas8
retrn
source/fort/rt1/dccos.f
+13
View File
@@ -0,0 +1,13 @@
function dccos(z1)
double complex dccos, z1, z2
double precision dummy(2), a, b, c, d
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = dexp(b)
d = 1.0d0/c
b = dsin(a)*(d-c)/2.0d0
a = dcos(a)*(c+d)/2.0d0
dccos = z2
return
end
source/fort/rt1/dclog.f
+13
View File
@@ -0,0 +1,13 @@
function dclog(z1)
double complex z1, z2, dclog
double precision a,b,c
double precision dummy(2)
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2=z1
c=dcabs(z2)
b=datan2(b,a)
a=dlog(c)
dclog=z2
return
end
source/fort/rt1/dcsin.f
+13
View File
@@ -0,0 +1,13 @@
function dcsin(z1)
double complex dcsin, z1, z2
double precision dummy(2), a, b, c, d
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = dexp(b)
d = 1.0d0/c
b = dcos(a)*(c-d)/2.0d0
a = dsin(a)*(c+d)/2.0d0
dcsin = z2
return
end
source/fort/rt1/dcsqrt.f
+14
View File
@@ -0,0 +1,14 @@
function dcsqrt(z1)
double complex dcsqrt, z1, z2
double precision dummy(2), a, b, c
equivalence (a,z2,dummy(1)), (b,dummy(2))
z2 = z1
c = dcabs(z2)
c = dsqrt(c)
b = datan2(b, a)/2.0d0
a = c*dcos(b)
b = c*dsin(b)
dcsqrt = z2
return
end

Some files were not shown because too many files have changed in this diff Show More