github.com/DoctorWkt.pdp7-unix
1
0
Fork 0
mirror of https://github.com/DoctorWkt/pdp7-unix.git synced 2026-04-24 19:40:14 +00:00
Code Issues Releases Wiki Activity

t[1-7].s: annotate TMG sources (all start with one or more tabs and ") (#230)

Browse Source 
start of TMG resurrection attempt
This commit is contained in:
Phil Budne
2021-08-21 12:46:06 -04:00
committed by GitHub
parent 8d6ea663ff
commit b7733dafea
7 changed files with 770 additions and 677 deletions
Download Patch File Download Diff File Expand all files Collapse all files

53
src/cmd/t1.s
View File

@@ -1,4 +1,10 @@
"** 13-120-147.pdf page 5
" TMG
" console switches:
" bit 0: do not save/dump core!!
" bit 15: trace first recognition or generate instruction & halt
" bit 16: trace all generation instructions
" bit 17: trace all recognition instructions
t=0
main:
lac 017777 i
@@ -23,16 +29,16 @@ main:
jms advance; jmp 1f
jmp rinterp
0:lac 2f
jms obuild
1:lac owrite
spa
jmp 0b
jms oflush
las
spa
sys exit
sys save
0:lac 2f " get EOS
jms obuild " add to obuf
1:lac owrite " here on retreat
spa " anything in obuf?
jmp 0b " no, put EOS
jms oflush " flush buffered output
las " get switches
spa " high bit set?
sys exit " yes: exit
sys save " no, dump core!!!!
2:o777
@@ -40,22 +46,23 @@ main:
"puts out and octal strin g from symtab entry
symoct:
symoct: " BUILTIN: (output last symtab ent in octal?)
lac equ
add equbot
dac 9f+t
lac 1f
jms twoktab; lac 9f+t i
1:gf .+1 x
lac ii
dac 8
lac 8 i
add symbot
dac 9f+t
dac 9f+t " save temp pointer
lac 1f " fetch "gf" (execute native code) inst below
jms twoktab; lac 9f+t i " second word is contents of word *temp
" first word of "two word ktab" entry:
1:gf .+1 x " invoke native code (below), and exit
lac ii " fetch instruction pointer
dac 8 " save in auto-increment register 8
lac 8 i " fetch word after *ii
add symbot " use as offset into symtab
dac 9f+t " save in temp
2:lac 9f+t i
jms putoct
lac onenl
2:lac 9f+t i " fetch symtab word *temp
jms putoct " output octal
lac onenl " output newline
jms obuild
lac 9f+t i
and o600600

508
src/cmd/t2.s
View File

@@ -1,96 +1,112 @@
"** 13-120-147.pdf page 7
" recognition stack frame advance
" push stack frame: called in both recognition and generation
" (despite above comment).
" recognition frame size is 6, generation frame size is 4.
" 0: pointer to previous frame
" 1: jmp instr from after "jms advance" (for retreat/return)
" 2: saved ii (inst ptr)
" 3: saved ignore/env
" 4: saved j (always overwritten by nframe in recog. mode)
" 5: saved k
advance:0
lac frame
dac 8
lac advance i
dac 8 i
lac ii
dac 8 i
lac ignore
dac 8 i
lac j
dac 8 i
lac k
dac 8 i
lac frame
dac nframe i
lac frame " get frame pointer
dac 8 " save in auto-increment register 8
lac advance i " get (retreat) instruction after "jms advance"
dac 8 i " save at offset 1
lac ii " instruction pointer
dac 8 i " save at offset 2
lac ignore " ignore mask pointer (env in recog. mode?)
dac 8 i " save at offset 3
lac j " input char pointer
dac 8 i " save at offset 4
lac k " result pointer
dac 8 i " save at offset 5
lac frame " save current frame pointer
dac nframe i " at nframe offset zero
lac nframe
dac frame
add dffrmsz
dac nframe
dac nframe
jms between; add rbot; add rtop
dac frame " set frame pointer to nframe (new frame)
add dffrmsz " add current frame size
dac nframe " set new new frame pointer
dac nframe " AGAIN??!!
jms between; add rbot; add rtop " check for overflow
jms halt
isz advance
jmp advance i
isz advance " skip instruction after jms
jmp advance i " return
" Here on failure/backup (w/ fflag set to 760000)
" AND at (successful) end of rule
" (exit/indirect bit set on last instr).
" Always restores j/k on failure:
" (no such thing as "failure" in generation mode(?))
retreat:
dzm junk
lac gflag
lac gflag " in generation mode?
sza
jmp 1f
jms bundlep
dac junk
jmp 1f " yes, skip bundling
jms bundlep " no, bundle
dac junk " save pointer (may be zero if no result)
1:lac frame
dac nframe
lac frame i
dac frame
dac 8
lac 8 i
dac nframe " reset nframe to current frame pointer
lac frame i " fetch prev. frame pointer from current frame
dac frame " pop current frame
dac 8 " save in (pre) auto-increment register 8
lac 8 i " restore saved instruction
dac 3f "retrun address
lac 8 i
dac ii
dac ii " restore saved instruction pointer
lac 8 i
dac ignore
lac fflag
sna
jmp 2f
dac ignore " restore saved ignore ("env" in gen mode???)
lac fflag " get failure flag
sna " any bits set?
jmp 2f " no, skip
lac 8 i "restore j and k on failure
dac j
lac 8 i
dac k
2:lac junk
sna
jmp 3f
2:lac junk " get bundle/result(s)
sna " got anything?
jmp 3f " no
dac nframe i "stass reslts
isz nframe
3:jmp
3:jmp " (jump following original "jms advance" call)
" bundle up results and return single pointer to them in ac
" return 0 if no results
"** 13-120-147.pdf page 8
bundlep:0
lac fflag
sza
lac fflag " check failure flag
sza " clear?
jmp 2f "no results on failure
jms nframe0
dac 9f+t
cma
tad nframe
cma
dac 9f+t+1
sma
jmp 2f
sad m1
jms nframe0 " yes: get initial nframe pointer
dac 9f+t " save
cma " get negative, minus one
tad nframe " add current value
cma " get nframe0 - nframe! (-N or zero)
dac 9f+t+1 " save
sma " negative result?
jmp 2f " no, no change
sad m1 " -1 (one result)
jmp 3f "only one result, no bundling necessary
lac 9f+t
tad m1
dac 8
lac 9f+t " get initial nframe
tad m1 " decrement
dac 8 " save in (pre-)auto-increment reg. 8
1:lac 8 i
jms kput
isz 9f+t+1
jmp 1b
1:lac 8 i " fetch result
jms kput " save in ktab
isz 9f+t+1 " increment negative count until zero
jmp 1b " more left, continue
lac k "make up result pointer
add l.gk
add l.gk " return as gk instruction
jmp bundlep i
2:cla
2:cla " here with no results, return zero
jmp bundlep i
3:lac 9f+t i
3:lac 9f+t i " here with one result, fetch it
jmp bundlep i
t=t+1 "where to find results
t=t+1 "negative of result count
@@ -98,54 +114,58 @@ t=t+1 "negative of result count
" the main interpreter loop
" locate original value of nframe for present stack level.
nframe0:0
jms s1get; add d.ii
jms s1get; add d.ii " fetch instr. at saved intruction pointer
dac junk
lac junk i
lac junk i " fetch word referenced by instruction
dac junk
lac junk i
and opmask
sad l.rw
jmp 1f
lac refrsz
lac junk i " fetch word referenced by that word!!
and opmask " get instruction portion
sad l.rw " is it an "rw" instruction?
jmp 1f " yes.
lac refrsz " no, use recog frame size as offset
jmp 2f
1:lac junk i
and o17777
2:add frame
jmp nframe0 i
1:lac junk i " get contents of word ref'ed by rw instr
and o17777 " get rw instr address portion (offset)
2:add frame " make nframe pointer
jmp nframe0 i " return
" halt on various error conditions:
" various table overflows
" console switch 15 set (trace and halt)
" invalid recognize/generate opcodes
halt:0
lac 1f
jms obuild
jms obuild " output "\n?"
lac halt
jms putoct
jms putoct " output return address in octal
lac onenl
jms obuild
xct rstack+1
1:.+1;012077;end
jms obuild " output newline
xct rstack+1 " execute retreat jump from initial advance?!
1:.+1;012077;end " "\n?"; end=-1 -- two 0777 EOSes
"** 13-120-147.pdf page 9
rinterp:
rinterp: " recognition mode interpreter
las "trace check
and d5
sna
jmp .+3
lac bugr
jms bug
jms bug " trace
lac fflag
ral
lac ii i
and opmask
sad l.ra
jmp rera
sad l.rb
jmp rerb
szl
jmp retreat
lrs 14
and o17
add rbranch
dac .+1
lac fflag " fetch failure flag
ral " rotate top bit into LINK
lac ii i " fetch current instruction
and opmask " get opcode
sad l.ra " "ra" (conditional branch on LINK set/fail)?
jmp rera " yes
sad l.rb " "rb" (conditional branch on LINK clear/succ)?
jmp rerb " yes
szl " LINK set (failure)?
jmp retreat " yes: retreat!!
lrs 14 " no: shift opcode bits down
and o17 " isolate opcode bits
add rbranch " create indirect jmp thru rbranch tabe
dac .+1 " save as next
jmp
rbranch:
@@ -153,7 +173,7 @@ rbranch:
reno
rerx
rerc
regc
regc " opcode is "rt"!
rerf
rerw
rera
@@ -167,104 +187,112 @@ rbranch:
reuu
reuu
reuu:
jms halt
reuu: " recognition unused operation
jms halt " halt
rerb:
cml
rera:
dzm fflag
snl
jmp goon
jms aget
dac ii
jmp rinterp
rerb: " recognition "rb" instruction
cml " complement LINK bit
rera: " recognition "ra" instruction
dzm fflag " clear failure flag
snl " LINK bit set?
jmp goon " no: continue (w/ exit check)
jms aget " yes: fetch address part
dac ii " save as new instruction pointer
jmp rinterp " go on (w/o exit check)
backup:
backup: " here on failure from "rx", eof, char builtins
lac jsav
dac j
nuts:
law
nuts: " here on failure from find/prev builtins
" (could possibly be used as a "fail" builtin?)
law " get 0760000
"** 13-120-147.pdf page 10
dac fflag
dac fflag " set failure flag
reno:
goon:
lac ii i
isz ii
and exitmask
reno: " recognition no(op) instruction
goon: " "go on" on success from recog. builtins, ops
lac ii i " fetch current instruction
isz ii " advance instruction pointer
and exitmask " was exit (indirect) bit set on prev instr?
sza
jmp retreat
jmp rinterp
jmp retreat " yes, retreat/return
jmp rinterp " no, go on
rerw:
jms aget
add frame
dac nframe
rerw: " recognition rw instr (nframe0 looks for one!)
jms aget " get address portion of instruction
add frame " use as frame size
dac nframe " set nframe pointer
jmp goon
rerc:
jms advance; jmp goon
jms aget
dac ii
jmp rinterp
rerc: " recognition rc (call tmg code) instruction
jms advance; jmp goon " push new frame, continue on retreat
jms aget " get address from instruction
dac ii " use as new instruction pointer
jmp rinterp " go on (w/o exit check)
gegf:
rerf:
jms aget
add ljmp
gegf: " gen. "gf" intr (invoke builtin func)
rerf: " recognition rf inst (invoke builtin func)
jms aget " get address from instruction
add ljmp " make into abs jmp to native code
dac .+1
jmp
jmp " go to native code
rerx:
rerx: " recognition rx instruction (compare lit str)
lac j
dac jsav
jms aget
dac jsav " save j (input char pointer) in jsav
jms aget " get address from instruction
1:dac 9f+t
jms lchar
sad o777
jmp goon
dac 9f+t+1
jms getj
sad 9f+t+1
jmp 2f
jmp backup
2:lac 9f+t
jms lchar " get lit character
sad o777 " EOS?
jmp goon " yes, continue (success)
dac 9f+t+1 " no, save char
jms getj " get next input char
sad 9f+t+1 " as expected?
jmp 2f " yes
jmp backup " no: restore j and fail.
2:lac 9f+t " continue matching (increment lit ptr)
add o400000
jmp 1b
t=t+1 "address of next comparison char
t=t+1 "character itself
aget:0
aget:0 " fetch address portion of current instruction
lac ii i
and o17777
jmp aget i
regc:
lac ii i
and o757777
xor exitmask
dac nframe i
" Places copy of instruction with exit bit set on stack.
" Interpreted as a "gc" instruction (see note at gegc).
regc: " recognition "rt" instruction [sic]
lac ii i " fetch instruction word
and o757777 " clear exit bit
xor exitmask " set (toggle) exit bit
dac nframe i " push @nframe
"** 13-120-147.pdf page 11
isz nframe
jmp goon
isz nframe " advance nframe pointer
jmp goon " succeed
" push result in AC at "k" (kbuf)
" called from bundlep and twice from twoktab (two word ktab entry)
" returns w/ AC unmodified, k contains index of new entry
kput:0
isz k
dac junk1
lac k
jms between; add d0; add kmax
jms halt
jms halt " halt on ktab overflow
add kbot
dac junk
lac junk1
dac junk i
jmp kput i
" fetch word from current frame using "add offset" following jms.
" Only used by parsedo, to restore k.
s0get:0
lac frame
xct s0get i
@@ -273,6 +301,8 @@ s0get:0
isz s0get
jmp s0get i
" fetch word via ptr in current frame using "add offset" following jms.
" Only used by nframe0, w/ "ii" instruction pointer
s1get:0
lac frame i
xct s1get i
@@ -281,6 +311,8 @@ s1get:0
isz s1get
jmp s1get i
" set word in current frame using "add offset" following jms.
" Only used by "gk" instruction to set "ii"
s0put:0
lmq
lac frame
@@ -293,119 +325,145 @@ s0put:0
" here is the generaion interpreter
" the k table cant move while its active
geno:
ggoon:
lac ii i
isz ii
and exitmask
geno: " gen. noop instruction
ggoon: " "go on" from gen. builtins, ops
lac ii i " fetch prev instr
isz ii " increment
and exitmask " isolate exit bit
sza
jmp retreat
jmp retreat " exit bit set, return.
ginterp:
las "trace check
and d6
sna
jmp .+3
lac bugg
jms bug
jms bug " trace
lac ii i
lrss 14
and o7
lac ii i " fetch current instruction
lrss 14 " shift down to opcode
and o7 " get low 3 of opcode
"** 13-120-147.pdf page 12
add gbranch
dac .+1
add gbranch " make indirect branch thru gbranch table
dac .+1 " save as next instruction
jmp
gbranch:
jmp .+1 i
geno
gegx
geuu
geuu " was once "gz" (in bugg tab)
gegc
gegf
gegk
gegp
gegq
geuu:
geuu: " gen. ununimplemented instruction
jms halt
gegx:
lac ii i
and o417777
jms obuild
jmp ggoon
" pdp-11 analog is .txs? output string
gegx: " gen. "gx" instruction
lac ii i " fetch instruction
and o417777 " extract character address
jms obuild " copy to output
jmp ggoon " continue (checking for exit)
gegq:
jms advance; jmp ggoon
" pdp-11 analog may be .tq: load translation parameter ($1, $2)??
" manual says:
" A translation rule may have parameters, and if it
" does, their number is declared by a parenthesized
" integer prefixed to its body.
gegq: " gen. "gq" instruction
jms advance; jmp ggoon " push state
lac env
add d.ii
add d.ii " get addr of env->ii
dac junk
jms aget
add junk i
jms aget " get address portion of gq instruction
add junk i " add value at *env->ii
dac junk
lac junk i
dac ii
lac junk i " fetch *(*env->ii + aget())
dac ii " save param list ptr as instruction pointer?
lac env
add d.env
add d.env " get addr env->env
dac junk
lac junk i
dac env
jmp ginterp
lac junk i " fetch env->env
dac env " restore env ptr (pop env)
jmp ginterp " go on (w/o exit check)
gegp:
jms advance; jmp ggoon
lac env
add d.ii
dac junk
lac frame i
dac env
jms aget
cma
add junk i
dac ii
jmp ginterp
" pdp-11 analog is .tp?
" execute rule called for by 1 2 ...
" found relative to instruction counter in the k environment
gegk:
lac ii i
jms aget
add kbot
gegp: " gen. "gp" instruction
jms advance; jmp ggoon " push current state
lac env " get saved env pointer
add d.ii " get pointer to saved instruction pointer
dac junk " save in temp
lac frame i " get prev frame pointer
dac env " save as env pointer
jms aget " get address portion of instruction
cma " one's complement negation + one's c. add!!
add junk i " back up env instruction pointer by -aget()
dac ii
jms s0put; add d.ii
lac frame
jmp ginterp " go on (w/o exit check)
" pdp-11 comment @ gk:
" delivered compound translation
" instruction counter is in ktable
" set the k environment for understanding 1, 2 ...
" to designate this frame
" PDP-7 NOTES: only place that sets "env" w/o reading first;
" twoktab stores gk instructions in ktab.
gegk: " gen. "gk" instruction
lac ii i " load instruction (value ignored)
jms aget " get address portion of instruction
add kbot " add to ktab base
dac ii " store as new instruction pointer
jms s0put; add d.ii " set frame saved instruction pointer too
lac frame " get frame pointer
"** 13-120-147.pdf page 13
dac env
jmp ginterp
dac env " save as env pointer
jmp ginterp " go on (w/o exit check)
gegc:
jms advance; jmp ggoon
jms aget
dac ii
jmp ginterp
" NOTE: recognition opcode "rt" (code at label regc!) places
" a copy of itself, with exit bit set on stack, since rt and
" gc use the same opcode, the stacked instruction comes here
" (addr points to "gen" code), so it calls the referenced code.
gegc: " gen. "gc" inst (call tmg coded subroutine)
jms advance; jmp ggoon " push current state
jms aget " get address from instruction
dac ii " use as new instruction pointer
jmp ginterp " go on (w/o exit check)
" trace routine (not a bug!)
" invoked from rinterp if switch 15 or 17 set (mask 05)
" invoked from ginterp if switch 15 or 16 set (mask 06)
" calls halt if switch 15 set (mask 04)
bug:0
dac 1f+2
lac onenl
dac 1f+2 " save pointer to instruction names
lac onenl " output newline
jms obuild
lac ii
lac ii " output instruction address in octal
jms putoct
lac ii i
lrs 14
and o17
add 1f+2
dac 1f+2
lac 1f+2 i
dac 1f+2
lac 1f
jms obuild
lac ii i
jms putoct
las
and d4
sza
jms halt
jmp bug i
lac ii i " get instruction
lrs 14
and o17 " get high four bits (opcode)
add 1f+2 " add to instruction name list pointer
dac 1f+2 " save (into output string!)
lac 1f+2 i " fetch two character instruction name
dac 1f+2 " save back into output string
lac 1f " get pointer to output string
jms obuild " output
lac ii i " get instruction
jms putoct " output in octal
las " get console switches
and d4 " is bit 15 set?
sza " no.
jms halt " yes: halt (output return address, then quit)
jmp bug i " no: continue.
1:0400000 .+1; 040; 0; 040777
1:0400000 .+1; 040; 0; 040777 " char ptr to <SPACE> XX <SPACE> <EOS>
" where XX will be instr name

335
src/cmd/t3.s
View File

@@ -1,161 +1,172 @@
"** 13-120-147.pdf page 14
" move characters
" call with source address in AC
" dest addr after "jms move" instruction
move: 0
dac 9f+t
lac move i
1:dac 2f
lac 9f+t
jms lchar
dac 9f+t+1
jms dchar
2: 0
lac 9f+t+1
sad o777
jmp 3f
lac o400000
add 9f+t
dac 9f+t
lac o400000
add 2b
jmp 1b
dac 9f+t " save source addr
lac move i " get dest addr
1:dac 2f " save dest addr after dchar call
lac 9f+t " restore source addr
jms lchar " load char
dac 9f+t+1 " save source char
jms dchar " store char
2: 0 " dest addr
lac 9f+t+1 " examine source char
sad o777 " EOS?
jmp 3f " yes
lac o400000 " get char addr increment
add 9f+t " add to source addr
dac 9f+t " save incremented source addr
lac o400000 " get char addr increment
add 2b " get incremented dest addr
jmp 1b " go back to top of loop (save dest addr)
3:isz move
lac 2b
3:isz move " skip dest addr arg
lac 2b " return dest addr
jmp move i
t=t+1 "source address
t=t+1 "source character
" load character
" takes source character address in AC
lchar:0
dac junk
ral
lac junk i
snl
lrs 9
and o777
jmp lchar i
dac junk " save source address
ral " rotate addr up (high bit into link)
lac junk i " fetch source word
snl " link set?
lrs 9 " no: move high 9 down
and o777 " get just 9 bits
jmp lchar i " return
" deposit character
" takes dest addr after jms instruction
dchar:0
lmq
lac dchar i
dac junk
spa
jmp 1f
llss 9
lac o777
lmq " save char in MQ
lac dchar i " get dest addr
dac junk " save
spa " high bit set?
jmp 1f " yes: get mask for high 9
llss 9 " no: shift AC/MQ up 9 (LINK fills MQ low bits)
lac o777 " get mask for low 9
jmp .+2
1:0777000
and junk i
omq
dac junk i
isz dchar
jmp dchar i
1:0777000 " get mask for high 9
and junk i " and dest word w/ mask
omq " or MQ in
dac junk i " deposit in dest word
isz dchar " increment return to skip dest addr
jmp dchar i " return
" gets designated character from input
" (reads block from disk if needed)
" does not increment j
jget:0
1:lac j
jms cbetween; add jmin; add jmax
jmp jmore
1:lac j " get input char addr [here also from jmore]
jms cbetween; add jmin; add jmax " in current block?
jmp jmore " no: not in memory, read block
cma
add jmin
cma
add jbot
jms lchar
jms class; add ignore
cma " get j-jmin
add jbot " make buffer address
jms lchar " fetch character from buffer
jms class; add ignore " char in "ignore" mask?
"** 13-120-147.pdf page 15
jmp jget i
lac j
add o400000
dac j
jmp 1b
jmp jget i " no: return character
lac j " yes: get source char addr
add o400000 " increment
dac j " save
jmp 1b " try again (may have crossed block boundary)
" read more input - filthy code, enough to make disk &
" terminal input work. Theae only deliver full count
" except at eof or 1 word
jmore:
and o377700
dac jmin
add ljsiz
dac 9f+t
lac jmax
jms cbetween; add jmin; add 9f+t
lac jmin
dac jmax
dac 1f
and o377700 " get char offset for start of block
dac jmin " save as first
add ljsiz " add buf size
dac 9f+t " save in t0
lac jmax " get current end addr
jms cbetween; add jmin; add 9f+t " in range jmin<=jmax<t0?
lac jmin " not in range: get jmin
dac jmax " save as new jmax
dac 1f " and for seek
cma
add jmin
cma
add jbot
dac 2f
lac input
sys seek
add jmin " 1's complement add!
cma " get jmin-jmax
add jbot " make buffer address
dac 2f " save as read dest
lac input " get input fd
sys seek " seek fd
1:0;0
-1
dac 2f i
lac input
sys read
-1 " get 0777777
dac 2f i " save in first word of read buffer
lac input " get input fd
sys read " read (ptr, count follow)
2:0;jsiz
sna
lac d1
add jmax
dac jmax
jmp jget+1
sna " get anything?
lac d1 " zero: get 1 instead (will fetch 0777)
add jmax " add to block base
dac jmax " save as max char
jmp jget+1 " try jget again
t=t+1
" gets next character from input
" called only from "rx" instruction
getj:0
lac j
jms jget
dac junk
lac j
lac j " input char addr
jms jget " get character
dac junk " save
lac j " increment character addr
add o400000
dac j
lac junk
lac junk " return character
jmp getj i
" compare two strings - assume both left justified
" called only from "find"
" takes one addr in AC, other following jms
" skips on match(?)
comp:0
dac 9f+t
lac comp i
dac 9f+t+1
isz comp
1:lac 9f+t i
sad 9f+t+1 i
dac 9f+t " save first argument pointer
lac comp i " fetch word after jms
dac 9f+t+1 " save second argument pointer
isz comp " skip argument word
1:lac 9f+t i " top of loop: fetch word from arg1
sad 9f+t+1 i " compare to arg2
"** 13-120-147.pdf page 16
jmp 3f
jmp 3f " identical: check for EOS
and 9f+t+1 i "do both start with eof?
spa
2:isz comp
spa " no: return without skip
2:isz comp " yes, give skip return
jmp comp i
3:and o600600 "is there an eof?
sza
jmp 2b
isz 9f+t
isz 9f+t+1
jmp 1b
sza " NO
jmp 2b " YES: saw EOS w/ matching words: skip return
isz 9f+t " no EOS, increment ptr 1
isz 9f+t+1 " increment ptr 2
jmp 1b " loop.
t=t+1 "address of string 1
t=t+1 "address of string 2
obuild:0
lmq
lac owrite
add obot
dac 2f
lacq
1:jms move
2:0
cma
obuild:0 " copy string to output
lmq " save char addr in AC in MQ
lac owrite " get obuf index
add obot " get obuf addr
dac 2f " save as move dest
lacq " get char addr back
1:jms move " move
2:0 " move dest
cma
add obot
cma
dac owrite
jms cbetween; add d0; add omax
skp
jmp obuild i
jms cbetween; add d0; add omax " obuf full?
skp " yes
jmp obuild i " no: return
lac lochunk
jms oflush
@@ -176,88 +187,92 @@ oflush:0
" outputs octal string from sesignated value
octal:
isz ii
lac ii i
dac 2f
lac 1f
jms twoktab
octal: " BUILTIN
isz ii " increment instruction pointer
lac ii i " fetch instruction word
dac 2f " save as geoctal argument??
lac 1f " fetch "gf geoctal x" instr
jms twoktab " make two word ktab entry and goon
lac 2f i
1:gf geoctal x
2:0
2:0 " copy of inst word after octal invocation
" (ptr to word to output????)
"** 13-120-147.pdf page 17
geoctal:
lac ii
dac 8
lac 8 i
jms putoct
jmp ggoon
geoctal: " native code invoked by "gf" inst in ktab
lac ii " get instruction pointer
dac 8 " save in auto-pre-increment reg 8
lac 8 i " fetch second ktab word
jms putoct " output as octal
jmp ggoon " success
" converts word in ac into ocatl on output stream
putoct:0
dac 9f+t
lac 7f
dac 9f+t " save output value
lac 7f " output "0"
jms obuild
dzm 9f+t+2
dzm 9f+t+2 " clear non-zero digit flag
-6
dac 9f+t+1
dac 9f+t+1 " init digit count to -6
1:lac 9f+t
cll
lrs 15
add o60
dac 8f+1
lls 18
dac 9f+t
1:lac 9f+t " get value
cll " clear link
lrs 15 " get high 3 bits right justified
add o60 " convert to ASCII digit
dac 8f+1 " save in output buffer
lls 18 " left justify remaining bits
dac 9f+t " save back in value
lac 9f+t+2 "have nonzero digits been seen?
sza
jmp 2f
jmp 2f " yes: go output
lac 8f+1 "no,is this nonzero?
sad o60
jmp 3f "no
2:lac 8f
2:lac 8f " output non-zero digit
jms obuild
law
dac 9f+t+2
3:isz 9f+t+1
jmp 1b
jmp putoct i
law " get 760000
dac 9f+t+2 " save as non-zero digit seen flag
3:isz 9f+t+1 " increment digit count
jmp 1b " non-zero: keep going
jmp putoct i " count now zero: return
t=t+1 "value to convert
t=t+1 "digit count
t=t+1 "nonzero digit flag
7: .+1; 060777
8:0400000 .+1;0;end
7: .+1; 060777 " "0" + EOS
8:0400000 .+1;0;end " digit, two 0777 EOS bytes
eof:
eof: " BUILTIN (succeed at EOF)
lac j
dac jsav
dac jsav " save j
jms jget
sad o777
jmp goon
jmp backup
sad o777 " at EOF?
jmp goon " yes, succeed
jmp backup " no, restore j from jsav, and fail
"
" called with jms class; add chrtabptr
" skip on return if char in AC in referened character table
class:0
dac junk1
dac junk1 " save input char
lrss 7
sza
jmp 2f
lls 3
xct class i
isz class
dac junk
sza " high (0200) bit of input set?
jmp 2f " yes, fail
lls 3 " get word number (16 bits per word)
xct class i " execute "add table" instr after "jms class"
isz class " skip the add on return
dac junk " save word pointer
"** 13-120-147.pdf page 18
cla
llss 4
add l.llss
llss 4 " get low four of character (bit number)
add l.llss " make into lls instr
dac 1f
lac junk i
1:llss
spa
2:isz class
lac junk1
lac junk i " get word from mask
1:llss " shift up by bit number (into sign bit)
spa " bit set?
2:isz class " yes: give skip return
lac junk1 " restore character
jmp class i

167
src/cmd/t4.s
View File

@@ -1,112 +1,115 @@
"** 13-120-147.pdf page 19
" put symbuf symbol into table
table:
lac equwrite
dac equ
table: " BUILTIN
lac equwrite " get equtab write index
dac equ " save as last found
jms between; add d0; add equmax
jms halt
add delta
dac equwrite
lac equ
add equbot
tad m1
dac 8
lac symwrite
dac 8 i
add symbot
dac 2f
lac mdelta
1:dzm 8 i
tad d1
spa
jmp 1b
lac sbbot
jms move
jms halt " overflow
add delta " increment
dac equwrite " save as next to write
lac equ " get our entry index
add equbot " get our entry address
tad m1 " decrement for pre-auto-increment
dac 8 " save in auto-increment reg
lac symwrite " get name index into symtab
dac 8 i " save in equtab
add symbot " get symtab addr
dac 2f " save as move dest
lac mdelta " get negative equtab entry word count
1:dzm 8 i " zero equtab word
tad d1 " increment count
spa " positive?
jmp 1b " no, loop and zero another
lac sbbot " yes, get symbuf base
jms move " copy string into symtab (string table)
2:0
add o400000
add o400000 " increment char addr
cma
add symbot
cma
add o400000
and o17777
dac symwrite
dac symwrite " save new symtab write pointer
jms between; add d0; add symmax
jms halt
jmp goon
jms halt " symtab overflow
jmp goon " success
" find occurrence of symbuf symbol in equtab
prev:
lac equ
jmp find+1
find:
lac equwrite
dac 9f+t
lac o777
jms sbput
lac sbbot
dac 2f
1:lac 9f+t
tad mdelta
dac 9f+t
spa
jmp nuts
add equbot
dac junk
lac junk i
add symbot
jms comp
2:0
jmp 1b
lac 9f+t
dac equ
prev: " BUILTIN
lac equ " last entry found/created
jmp find+1 " start search
find: " BUILTIN
lac equwrite " get end index to equ table
dac 9f+t " save
lac o777 " get EOS
jms sbput " append to sbbuf
lac sbbot " get sbbuf base
dac 2f " stash as "comp" argument 2 (loop invariant)
1:lac 9f+t " get equbuf index
tad mdelta " decrement (by two)
dac 9f+t " save
spa " still positive?
jmp nuts " no: return failure
add equbot " turn into equbuf pointer
dac junk " save as temp
lac junk i " get symtab entry offset
add symbot " get symtab entry address
jms comp " compare
2:0 " compare arg2 here
jmp 1b " non-skip return: continue
lac 9f+t " skipped: get offset
dac equ " save as last found
"** 13-120-147.pdf page 20
jmp goon
jmp goon " success!
t=t+1 "next equtab location to test
sbput:0
lmq
lac sbwrite
add sbbot
dac 1f
lacq
jms dchar
sbput:0 " put character in AC into symbuf (sbbuf)
lmq " save character in MQ
lac sbwrite " get sbbut write index
add sbbot " add to start of sbbuf
dac 1f " save as dchar dest
lacq " get char back
jms dchar " save
1:0
lac sbwrite
add o400000
dac sbwrite
lac sbwrite " get sbbuf write index
add o400000 " increment
dac sbwrite " save back
jms cbetween; add d0; add sbmax
jms halt
jms halt " sbbuf overflow
jmp sbput i
getname:
lac equ
add equbot
dac 9f+t
lac 1f
jms twoktab; lac 9f+t i
getname: " BUILTIN
lac equ " get last entry index
add equbot " get equtab addr (addr of pointer to string)
dac 9f+t " save in temp
lac 1f " get "gf" instruction
jms twoktab; lac 9f+t i " make 2-work ktab entry (does not return)
1:gf .+1 x
lac ii
dac 8
lac 8 i
add symbot
and o17777
jms obuild
jmp ggoon
1:gf .+1 x " jump to native code & exit
lac ii " get instruction pointer
dac 8 " save in auto-pre-increment reg 8
lac 8 i " fetch next word (symtab index)
add symbot " make pointer into symtab
and o17777 " get just address
jms obuild " send to output
jmp ggoon " success
t=t+1 "equtable entry
" puts double word entries in ktab and gives
"pointer to first as result
" takes first word (addr for gk instr) in AC
" and indirect load instr after "jms twoktab"
" Called (as final action) by builtins (symoct,octal,getname)
" DOES NOT RETURN!!!
twoktab:0
jms kput
jms kput " save AC in ktab
lac l.gk
add k
dac nframe i
add k " make gk intruction, pointing to new entry
dac nframe i " push onto nframe
isz nframe
xct twoktab i
jms kput
jmp goon
xct twoktab i " execute lac i instruction after "jms twoktab"
jms kput " save in ktab as second word
jmp goon " success

76
src/cmd/t5.s
View File

@@ -1,75 +1,75 @@
"** 13-120-147.pdf page 21
char:
char: " BUILTIN: match one char from bitset or fail.
lac j
dac jsav
isz ii
jms ctest
jmp backup
jmp backup " not in bitset: restore j from jsav, fail
jmp goon
string:
string: " BUILTIN: match zero or more chars from bitset
isz ii
jms ctest
jmp goon
jmp goon " not in bitset, quit (but do not fail)
jmp string+1
ctest:0
jms jget
jms class; add ii i
jmp ctest i
jms sbput
lac j
jms class; add ii i " bitset check w/ table ptr *ii
jmp ctest i " char not in bitset, return w/o skip
jms sbput " matched: add to symbuf
lac j " increment j (char ptr)
add o400000
dac j
isz ctest
isz ctest " give skip return
jmp ctest i
mark:
jms jget
mark: " BUILTIN: clear symbuf
jms jget " consume ignored characters
dzm sbwrite
jmp goon
parsedo:
parsedo: " BUILTIN: invoke rule
isz ii
jms advance; jmp 3f
jms advance; jmp 1f
jms aget
jms advance; jmp 3f " on retreat restore k
jms advance; jmp 1f " on retreat switch to generation
jms aget " get new instruction pointer
dac ii
jmp rinterp
1:lac frame
1:lac frame " on retreat (second advance call)
add refrsz
dac ii
sad nframe
jmp retreat
dac gflag
dac ii " set instruction pointer to "nframe"
sad nframe " was anything pushed onto nframe??
jmp retreat " no: retreat again.
dac gflag " yes: set gflag (don't bundle on retreat)
lac gefrsz
dac dffrmsz
jms advance; jmp 2f
jmp ginterp
dac dffrmsz " change (advance) frame size to generate size
jms advance; jmp 2f " on retreat switch back to recognition mode
jmp ginterp " interpret generate instructions!
2:lac refrsz
dac dffrmsz
2:lac refrsz " on retreat from generate mode
dac dffrmsz " switch back to recognition sized frames
add frame
dac nframe
dzm gflag
jmp retreat
dac nframe " reset nframe pointer
dzm gflag " clear gflag (resume bundling on retreat)
jmp retreat " retreat (again)!!
3:jms s0get; add d.k
dac k
3:jms s0get; add d.k " on retreat (first advance call)
dac k " restore k from current frame
jmp goon
bundle:
jms bundlep
bundle: " BUILTIN: bundle results
jms bundlep " get bundle of results (if more than one)
"** 13-120-147.pdf page 22
dac 9f+t
sna
jmp goon
jms nframe0
dac nframe
lac 9f+t
dac nframe i
sna " got any?
jmp goon " nope. success.
jms nframe0 " look for original nframe
dac nframe " restore
lac 9f+t " get bundle result ptr (in ktab if multi-word)
dac nframe i " push @nframe
isz nframe
jmp goon
t=t+1

218
src/cmd/t6.s
View File

@@ -1,63 +1,63 @@
"** 13-120-147.pdf page 23
rerm:
jms aget
jmp 1f
rers:
jms aget
add frame
1:dac holdlv
lac holdlv i
jmp 2f
rerv:
jms aget
lls 6
lrs 6
2:dac nframe i
isz nframe
jmp goon
rerm: " recognition "rm" instruction
jms aget " get address portion (abs addr)
jmp 1f " join "rs"to fetch
rers: " recognition "rs" instruction
jms aget " get address portion (positive frame offset)
add frame " add frame pointer
1:dac holdlv " save as "hold lvalue"
lac holdlv i " fetch addressed word
jmp 2f " go push
rerv: " recognition "rv" instruction
jms aget " get address portion
lls 6 " discard high six bits
lrs 6 " replac with six copies of LINK bit
2:dac nframe i " save @nstack
isz nframe " increment
jmp goon " success
rero:
jms decnf
dac rand1
jms aget
and o77
add obranch
dac 2f
cma
tad unary
spa
jmp 1f
jms decnf
dac rand2
1:lac rand1
2:xct
jmp result
rero: " recognition "ro" (opr) instruction
jms decnf " pop top of nstack
dac rand1 " save as (op)rand 1
jms aget " get address portion of instruction
and o77 " get low six bits for sub-opcode
add obranch " make xct into o(pr)branch table
dac 2f " save
cma " negate (minus one)
tad unary " add unary base xct
spa " positive?
jmp 1f " no: was unary, skip second arg fetch
jms decnf " yes: binary op, pop second arg from nstack
dac rand2 " save as second (ope)rand
1:lac rand1 " get first (ope)rand in AC
2:xct " execute instruction from obranch table
jmp result " if noop, join result processing
obranch:
xct .+1
opr ;op=0400000+1
jmp rorel ;le=op;op=op+1
jmp rorel ;ne=op;op=op+1
jmp rorel ;lt=op;op=op+1
jmp rorel ;ge=op;op=op+1
jmp rorel ;eq=op;op=op+1
jmp rorel ;gt=op;op=op+1
tad rand2 ;ad=op;op=op+1
jms sub ;sb=op;op=op+1
and rand2 ;an=op;op=op+1
jmp roor ;or=op;op=op+1
xor rand2 ;xo=op;op=op+1
jmp rosr ;sr=op;op=op+1
jmp rosl ;sl=op;op=op+1
jmp romn ;mn=op;op=op+1
jmp romx ;mx=op;op=op+1
lac rand2 ;as=op;op=op+1
opr ;op=0400000+1 " (no)op
jmp rorel ;le=op;op=op+1 " relop <=
jmp rorel ;ne=op;op=op+1 " relop !=
jmp rorel ;lt=op;op=op+1 " relop <
jmp rorel ;ge=op;op=op+1 " relop >=
jmp rorel ;eq=op;op=op+1 " relop ==
jmp rorel ;gt=op;op=op+1 " relop >
tad rand2 ;ad=op;op=op+1 " binop +
jms sub ;sb=op;op=op+1 " binop -
and rand2 ;an=op;op=op+1 " binop &
jmp roor ;or=op;op=op+1 " binop |
xor rand2 ;xo=op;op=op+1 " binop ^ (xor)
jmp rosr ;sr=op;op=op+1 " binop <<
jmp rosl ;sl=op;op=op+1 " binop >>
jmp romn ;mn=op;op=op+1 " binop min??
jmp romx ;mx=op;op=op+1 " binop max??
lac rand2 ;as=op;op=op+1 " binop ??? (always returns rh operand)
opr ;pl=op;op=op+1
jmp romi ;mi=op;op=op+1
cma ;cm=op;op=op+1
jmp roindir;indir=op;op=op+1
lac holdlv ;addr=op;op=op+1
opr ;pl=op;op=op+1 " unary + (noop)
jmp romi ;mi=op;op=op+1 " unary - (negate)
cma ;cm=op;op=op+1 " unary ~ (complement)
jmp roindir;indir=op;op=op+1 " unary indirect (fetch *holdlv)
lac holdlv ;addr=op;op=op+1 " unary addr (return last holdlv)
unary:xct obranch+1+pl
rorel: "<= 001
@@ -78,6 +78,8 @@ rorel: "<= 001
cma
jmp result
" return rand1 minus rand2
" used by rorel, rosub
sub:0
cma
tad rand2
@@ -85,79 +87,79 @@ sub:0
jmp sub i
roor:
lmq
lac rand2
omq
lmq " save rand1 in MQ
lac rand2 " get rand2 in AC
omq " or AC and MQ
jmp result
rosr:
lac rand2
add l.lrs
cll
lac rand2 " get rh operand
add l.lrs " make long right shift (fills with LINK)
cll " clear link
jmp 1f
rosl:
lac rand2
add l.lls
clq
1:dac .+2
lac rand1
0
jmp result
lac rand2 " get rh operand
add l.lls " make long left shift (fills from MQ)
clq " clear MQ
1:dac .+2 " save shift instruction
lac rand1 " get left hand operand
0 " perform shift
jmp result " join result processing
romn:
jms sub
cma
jms sub " get rand1-rand2
cma " complement (rand2-rand1-1)
jmp .+2
romx:
jms sub
ral
lac rand1
szl
lac rand2
jmp result
jms sub " get rand1-rand2
ral " rotate left (sign bit into LINK)
lac rand1 " get first operand
szl " link clear?
lac rand2 " no, get second operand instead
jmp result " return result
romi:
cma
tad d1
romi: " unary minus
cma " complement
tad d1 " add one
jmp result
roindir:
dac holdlv
lac holdlv i
dac holdlv " save as "hold lvalue"
lac holdlv i " fetch value
"** 13-120-147.pdf page 25
jmp result
jmp result " return result
result:
dac junk
dac nframe i
result: " ro result processing
dac junk " save in temp
dac nframe i " store at *nframe++
isz nframe
lac ii i
and stbit
sna
jmp exprtest
lac junk
dac holdlv i
lac ii i
and fibit
sza
jms decnf
lac ii i " fetch original instruction
and stbit " get st(ore?) bit
sna " set?
jmp exprtest " no
lac junk " yes: get result
dac holdlv i " store at *holdlv
lac ii i " fetch original instruction
and fibit " fi(nal?) bit set?
sza " no, skip
jms decnf " yes: discard stacked result
jmp goon " succeed
exprtest: " here if st(ore?) bit not set
lac ii i " fetch instruction
and fibit " get fi(nal?) bit
sna " set?
jmp goon " no: succeed
jms decnf " yes: poped stacked result
lac nframe i " (redundant?????)
sza " was result zero?
-1 " no: get all ones
cma " complement (zero -> -1, -1 -> zero)
dac fflag " save as failure flag
jmp goon
exprtest:
lac ii i
and fibit
sna
jmp goon
jms decnf
lac nframe i
sza
-1
cma
dac fflag
jmp goon
decnf:0
decnf:0 " decrement nframe, return stacked value
-1
tad nframe
dac nframe

90
src/cmd/t7.s
View File

@@ -1,8 +1,8 @@
"** 13-120-147.pdf page 26
9:.=.+t
end = -1
end = -1 " end of string (two 0777 bytes)
" recognition / generation opcodes:
no = 0000000
rx = 0040000; gx = rx
rc = 0100000
@@ -16,23 +16,23 @@ rm = 0440000
rs = 0500000
rv = 0540000
" literal words
ljmp:jmp
l.llss:llss
l.lrs:lrs
l.lls:lls
l.ra:ra
l.rb:rb
l.rw:rw
l.gk:gk
l.gcx:gc x
x = 020000
st = 0100
fi = 0200
opmask:0740000
exitmask: x
l.ra:ra " used for comparison
l.rb:rb " used for comparison
l.rw:rw " used for comparison
l.gk:gk " used to create instr in twoktab
l.gcx:gc x " NOT USED?
x = 020000 " exit bit (on all recog/gen instrs)
st = 0100 " store(?) bit on recog op (ro) instrs
fi = 0200 " final(?) bit on recog op (ro) instrs
opmask:0740000 " opcode mask
exitmask: x " exit bit mask
" number lits:
m1:0-1
d0:o0:0
d1:o1:1
@@ -43,13 +43,18 @@ d5:o5:5
d6:o6:6
d7:o7:7
d8:o10:8
asciisp:040
asciinl:012
nl:012777
onenl:nl
bugr:.+1;<rn>;<rx>;<rc>;<rt>;<rf>;<rw>;<ra>;<rb>
asciisp:040 " ascii space (NOT USED)
asciinl:012 " ascii newline (NOT USED)
nl:012777 " newline + EOS
onenl:nl " pointer to newline+EOS
bugr:.+1;<rn>;<rx>;<rc>;<rt>;<rf>;<rw>;<ra>;<rb> " ptr to rec. op names
<ro>;<rm>;<rs>;<rv>
bugg:.+1;<gn>;<gx>;<gz>;<gc>;<gf>;<gk>;<gp>;<gq>
bugg:.+1;<gn>;<gx>;<gz>;<gc>;<gf>;<gk>;<gp>;<gq> " ptr to gen. op names
" NOTE! ginterp ignores high bit of
" opcode (to allow as char indicator
" bit for gx instruction), but bug
" routine does not, so table should
" include two more entries???
o17:017
o60:060
@@ -66,6 +71,7 @@ o17777:017777
o757777:0757777
o600600:0600600
" variables
junk:0
junk1:0
@@ -100,27 +106,29 @@ sbbot:sbbuf
fflag:0
gflag:0
ignore:.+1;0400000;0;0;0;0;0;0;4
frame:rstack
nframe:rstack+6
ignore:.+1;0400000;0;0;0;0;0;0;4 " pointer to ignored character set
" default ignore set (NUL and DEL)
" set stored using first (high) 16 of each wd.
frame:rstack " frame pointer
nframe:rstack+6 " next frame pointer
env = ignore
d.ii = d2
d.env = d3
d.blkmod = d3
d.j = d4
d.k = d5
dffrmsz:6
framsiz:4
refrsz = d6
gefrsz = d4
ii: start
k:0
d.ii = d2 " frame offset for instruction pointer
d.env = d3 " frame offset for env/ignore
d.blkmod = d3 " SYMBOL NOT USED
d.j = d4 " frame offset for saved j
d.k = d5 " frame offset for saved k
dffrmsz:6 " current frame size (one of [rg]efrsz)
framsiz:4 " LOCATION NOT USED
refrsz = d6 " recognition frame size
gefrsz = d4 " generation frame size
ii: start " interpreter instruction pointer
k:0 " saved data (ktab) pointer
rsiz = 500
rmax: rsiz
rbot:rstack
rtop:rstack+rsiz
rsiz = 500 " stack size
rmax: rsiz " stack size as variable
rbot:rstack " pointer to first stack entry
rtop:rstack+rsiz " pointer to last stack entry
owrite:0
obot:obuf
osiz=64
owrite:0 " index into obuf
obot:obuf " pointer to first word of output buffer
osiz=64 " output buffer size