MG**8ASM COM@))CTC ASMZdՆ**DDT COM&v))FACT TC **g@GUESSNUMTC s**b HELLO TC u**V PPS TC +J**``fTC ASMeR.**TC COM~.L>**``TREE TC /3**\^TREE TR  VB**@|@|PF TC 6**+ BBOT99 TC 蔐**|@8PIECES TC 2N**}} 1*" COPYRIGHT(C) 1978, DIGITAL RESEARCH á 4êü /L9ASMPRNHEX!4w_#~ ʸ A:4~~# ¼ > \ ?ʻ w# !ͼ ? !ͼ !)ͼ !ͼ :5͡ :6:6͡ :7͡ :\ ʻ 24!dͮ 25ͮ 27ͮ 26!8 ( ʃ !Y 1  :7ʞ !z 8  !"2D2X2#! 8 !ͼ z{* ! !"!8 w#  +6# *#"~!ͼ G:6QxJQS*!w#"! 1 !"!Y~~# …¡z!ͼ wʹ* ! w#" ! 8 !" ! zz_O4:  :6y:! G~#x=2> > ! >x6 #='G! ~ p( O*}O>4?:7w:#ĸ*"!͸* }w>ͪg( ʆ1 Y :7ʗ8 z !<ͼ CP/M ASSEMBLER - VER 1.4 NO SOURCE FILE PRESENT NO DIRECTORY SPACE SOURCE FILE NAME ERROR SOURCE FILE READ ERROR OUTPUT FILE WRITE ERROR CANNOT CLOSE FILES END OF ASSEMBLY G:7xʘ!#~ʄl͸Ä**!O {zʊ͸*"!!#^4!$wͯͯWƐ'@'ê>:ͪ!#^Ww*!{͚|͚}͚͚{!$~#͚͚> ͪ> ͪ@2 0 0:x0_<2! wI2 2> 2 >2ɯ22 !~@_6^4#: w~$w: 0 q: A: A͋q: a{_2  2 ͞ !ɯ2I:  ;*:  ͭͷ ͭ͋>9q>9: '!2 >9 7:! 6 >2>2: 2 Qͭ:Ğ! :lj<͖<j<|<: OʊQ>ÖH >2 2 û: B­>ôD> ¸!52 !"!N#~#A07O! ~*!) " :  '<ͭ'<>V$>O$à\ÞØ`rÍÖ![w#w#b!"!F#v2[G*##~w*##~<*}q!~ڬ6![^![^#fk"͎͘!G#*####*^#Vû!^*"*{zA"*![N![ N#Fr+sq#p/>G=#w#w3#w#w!JSYMBOL TABLE OVERFLOW G*##~w*##~͎*_###s#r^#V`à 4 Wm ()*+,-/ABCDEHLMDBDIDSDWEIIFINORSPACIADCADDADIANAANDANICMACMCCMPCPIDAADADDCRDCXENDEQUHLTINRINXJMPLDALXIMODMOVMVINOPNOTORAORGORIOUTPOPPSWRALRARRETRLCRRCRSTSBBSBISETSHLSHRSTASTCSUBSUIXORXRAXRICALLENDMLDAXLHLDPCHLPUSHSHLDSPHLSTAXXCHGXTHLENDIFMACROTITLE  PF FP! ( 2/?'  v:P@< !  PP27 ( *"  NZZ NCC POPEP M x_BH!œ#¶ ¦{KÈCÈ<:JCR:  !6 s!#  ɯ<:O=_Z!F!V#fjQ̓E!^#Vo&)~#FxGyѯ<àn8!~ڢͅ6~44O! s#r!~ ڿ6ͅ^4!mw!wp!~ͅ!55N! N#fio&)^#fkz'{ͅ>ɯo>g"k!m6ů{_zW5>)D*kOxGd !m?FDM!xGyOڂÃ)sn55)=â|g}o=î--#zg{ozg{ozg{oÓ:: ;,!ɯ22=2l!"]!~H5_!m~0:ą:  *":  :‰:̅ԅ!^#=ʅVq”*qͦ1& O:lµ̅>2ly:_!w~!s!m~ùy !~=w_!m~ ͅͰ>2lyPLnR>UX:l̅2l͓*>E2C!" """ :ʼ:*1 |R|ͦ0FIL: R  R* } *" :¿::¿üX!C^#fk[@ :Œ:=ʌG!ʆF#H vÛc*| EH ͺ,^1 ͦ *""1 EH DH ͺ,1 ͦ :  1:  " > 2 :|: |Ë  |*" ͩ !6="1 :  1}1:n:>BʋSSͦSSxS 1:  1"" ͦ 1 |R >O U!" 1 1!|_!^#fk $8AP`ixH ñññ81Ľ y0îH ñGîG  ñH ñ(Ľ yîH ñîîĽ y0îîH ñG 1: :,; c*| } 8OĽ y0G G t :):,.>C :|: Jü;r :R: ʼʋ!ʼR!ʼʋ>SR{ozg!~4ʧͦ !6 ! **̈́**̈́\iͩ !w#H USE FACTOR !* "z{*"* "I !" :1 R O*UR X* G:xl :  *̩ : l x͖ *#"EH DH 0:~ ! ^4! w͆ Æ *! 6z͖ {͖ 4>R>V>D >P >L >N; CTC.ASM - lrb - 10/21/2007 p equ psw entry equ 05h rdcon equ 1 wrcon equ 2 prbuff equ 9 chcon equ 11 seldsk equ 14 openf equ 15 closef equ 16 deletf equ 19 rdrec equ 20 wrrec equ 21 creatf equ 22 inqdsk equ 25 setdma equ 26 ; reof equ 1 ;read end-of-file signal ; fn equ 1 ;EFCB layout ft equ 9 ex equ 12 rct equ 15 nr equ 32 status equ 33 driveno equ 34 nxbyte equ 35 buffer equ 36 ; ;used by start: tcorg equ 600h mstack equ tcorg+46h bpr equ tcorg+42h inst equ tcorg+0d08h move equ tcorg+0c4bh hlneg equ tcorg+0dc0h progend equ tcorg+060h tfcb equ 05ch tbuff equ 080h ; ;used by USERMC mceset equ tcorg+2bh toptoi equ tcorg+2eh pushk equ tcorg+31h pzero equ tcorg+1c5h ; ;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ;::::::::::: tiny - c ::::::::::::::::::::::::::::::::::: ;::::::::::: cp/m installation :::::::::::::::::::::::: ;::::::::::: by t. a. gibson, 1978 :::::::::::::::::: ;::::::::::: copyright, 1978, tiny-c associates ::: ;::::::::::: all rights reserved :::::::::::::::: ;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ; org 100h jmp start jmp inch jmp aout jmp chrdy jmp fopen jmp rdblok jmp wrblok jmp fclose jmp usermc ; ;transforms unit in BC to efcb in DE unit mov d,b ;DE <- BC mov e,c mov a,e ;test for unit 1 dcr a ora d rnz lxi d,efcb ;use built in efcb ret ; ;restores BC, DE, HL and returns bdhret pop b dhret pop d pop h ret ; ;assures proper disk is logged on. (DE) is efcb. asudsk push h!push d!push b lxi h,driveno ;retrieve needed drive dad d mov a,m push p mvi c,inqdsk call fdos mov b,a ;current drive -> B pop p ;needed drive -> A cmp b ;if same do nothing jz bdhret mov e,a ;logon device (A) mvi d,0 mvi c,seldsk call fdos jmp bdhret ; ;assure correct DMA for buffer at (DE)+buffer. asudma push h!push d!push b xchg mvi c,setdma call fdos jmp bdhret ; ;restore default DMA buffer cpmbuff push h! push d! push b lxi d,80 mvi c,setdma call fdos jmp bdhret ; ;load buffer, (DE) is EFCB ldbuff push h! push d ! push b call asudsk call asudma mvi c,rdrec call fdos jmp bdhret ; ;write the buffer. (DE) is EFCB wrbuff push h! push d! push b call asudma ;must send it out call asudsk mvi c,wrrec call fdos jmp bdhret ; ;examines 1st 2 bytes of a drive:fn.ft string. ;(HL) points to the string. If a drive is specified, the ;drive is set up in the EFCB pointed to by (DE). ;Otherwise drive a is set up. drive push h! push d! push b inx h ;is there a colon in 2nd byte. mov a,m cpi ':' jnz dr2 dcx h ;get drive byte. Must be A,B,C or D, mov a,m sui 'A' jm dr99 cpi 4 jm dr3 sui 20h ; or a,b,c or d. jm dr3 cpi 4 jm dr3 dr99 mvi a,254 ;illegal drive signal ora a jmp bdhret dr2 mvi c,inqdsk ;default is current drive call fdos lxi h,driveno dad d mov m,a jmp bdhret dr3 lxi h,driveno ;driveno in A into EFCB. dad d mov m,a xra a ;success signal pop b! pop d! pop h ;restore environment. inx h! inx h ;bump string pointer past colon. ret ; ;safe entry into CP/M. fdos push h! push d! push b call entry jmp bdhret ; ;puts fn.ft into EFCB. (HL) points to string ended with ;null byte. (DE) points to EFCB. fnft push h! push d! push b xra a ;0 into ET field stax d inx d mvi b,8 ;length of FN field call fomov ;fn into FN jz ftdflt ;if 0 then end of string was reached. fdot mov a,m ;scan for . or null inx h cpi '.' jz ftype ora a jnz fdot ftdflt lxi h,dft ftype mvi b,3 ;mov ft into FT call fomov fex xra a ;0 EX thru RC stax d! inx d stax d! inx d stax d! inx d stax d! inx d jmp bdhret dft db 'TC ' ; ;moves a string to a field. (HL) points to string. (DE) ;points to field of length (B). Stops on . or null or ;field full. Pads field with blanks if needed. Returns ;last byte examined in A and Z set iff its null. fomov mov a,m ora a jz fpad cpi '.' jz fpad cpi '*' ;* => pad with ?'s jz qpad cpi 61h ;test for lower case alpha jc fm2 cpi 7bh ; 'z'+1 jnc fm2 ani 0dfh ;force upper case fm2 stax d inx d inx h dcr b jnz fomov ora a ;set or reset Z ret ;DE points past moved field ;HL points to next byte to examine. fpad push p ;save char that caused stop mvi a,' ' ;blanks into remainder of field fp2 stax d inx d dcr b jnz fp2 pop p ;restore character that caused stop ora a ret qpad push p mvi a,'?' jmp fp2 ; ;prints (A) in hex, and EFCB prefcb push psw push h! push d! push b call ahexout mvi a,' ' call aout lxi h,driveno ;drive letter into A dad d mov a,m adi 'A' call aout ;send drive letter mvi a,':' call aout ;send colon mvi c,8 ;length of filename lxi h,fn ;send filename dad d call prntnch mvi a,'.' ;send period call aout mvi c,3 ;send filetype lxi h,ft dad d call prntnch mvi a,' ' ;send blank call aout lxi h,ex ;send extent number dad d mov a,m call ahexout mvi a,' ' ;send blank call aout lxi h,rc ;send record count dad d mov a,m call ahexout mvi a,' ' call aout lxi h,nr ;send next record number dad d mov a,m call ahexout mvi a,' ' call aout lxi h,status ;send status dad d mov a,m call ahexout mvi a,' ' call aout lxi h,nxbyte ;send next byte of buffer dad d mov a,m call ahexout mvi a,' ' call aout ;send blank at end pop psw jmp bdhret ; ;opens a file for tiny-c, as specified in the ;Owner's Manual 6.1.2. DE (filesize) is ignored. ;All other parameters are used. fopen push p ;r/w flag call cpmbuff ;assure default buffer call unit ;set up pointer to EFCB in DE. call drive ;drive into EFCB jz f2 pop p ;improper drive. Clear stack. call ps ;print filename and bad drive message. lxi d,baddr ferr call pcs ;bad drive message xra a ;signal an error inr a ret baddr db 'improper drive$' f2 call fnft ;fn.ft into EFCB jz f3 pop p ;bad filename call ps ;clear stack, print filename and bad lxi d,badname ; filename message. jmp ferr badname db 'bad filename$' f3 lxi h,nr ;0 into NR and NXBYTE dad d xra a mov m,a lxi h,nxbyte dad d mov m,a pop p ;restore r/w flag, and put lxi h,status ; into status dad d mov m,a cpi 1 ;what kind of open jz ropen cpi 2 jz wopen call prefcb ;bad r/w flag, print EFCB and message lxi d,badrw jmp ferr badrw db 'rw must be 1 or 2$' ropen call asudsk ;assure correct disk mvi c,openf ;do a cpm open call fdos cpi 255 ;test for no file jnz openok call prefcb ;print EFCB and no-file message lxi d,nofile jmp ferr nofile db 'cant find file$' openok xra a ;signal open ok ret wopen call asudsk ;assure correct disk mvi c,deletf ;delete old file, if any call fdos mvi c,creatf call fdos cpi 255 ;test if disk is full jnz openok call prefcb ;print EFCB and full message lxi d,dirful jmp ferr dirful db 'directory full$' ; ;reads a block. HL points to memory area to read into. ; BC is a unit. If status of EFCB is not 1, returns an ; eof signal, and does not read. Otherwise reads one block ; into memory. If physical eof was reached, an eof signal is ; returned. Otherwise scans the read block for ^Z, and ; returns length of block in DE. Returns 0 in A for ok, ; -1 for eof, 1 for error. Leaves BC, HL unchanged. rdblok push b push h call unit ;efcb into DE lxi h,status ;test status dad d mov a,m cpi 1 jnz rdeof pop h push h call ldbuff ;read the record ora a jnz rdpeof ;possible eof lxi d,0 ;scan for ^Z mvi b,1ah ;^Z into A mvi c,128 ;scan limit rdscan mov a,m ;get byte cmp b ;is it ^Z jz rdout inr e ;add to length inx h ;to get next byte dcr c jnz rdscan rdout pop h ;restore B and H pop b xra a ;signal ok ret rdpeof cpi reof ;didn't read, see why. jnz rderr rdeof pop h ;eof exit, restore B and H pop b xra a ;signal eof dcr a ret rderr call prefcb ;print error code and efcb lxi d,rermsg jmp ferr rermsg db 'read error$' ; ;write a block. Unit in BC. HL..DE bracket a block of ; memory <= 128 bytes. If status in EFCB is not 2, signal ; an error. If block < 128 put an ^Z at (DE)+1. Then ; write the block. Return 0 in A for ok, 1 otherwise. wrblok mov a,e ;check length sub l cpi 127 ;E-L==127 implies 128 bytes in block jz wr2 xchg ;short block, put ^Z at (DE)+1 inx h mvi m,1ah xchg wr2 call unit ;efcb into DE push h ;save write address lxi h,status dad d ;test status mov a,m cpi 2 pop h ;restore write address jnz wrerr ;error if status not 2 call wrbuff ;write the block ora a ;zero signals no problem rz wrerr call prefcb ;print error code and efcb lxi d,wermsg jmp ferr wermsg db 'write error$' ;close a file, BC is the unit. fclose call unit ;EFCB into DE call cpmbuff ;assure default buffer lxi h,status ;status into A dad d mov a,m ;test status cpi 2 jnz zstat mvi c,closef ;writing, must close the file call fdos cpi 255 jz fcerr zstat xra a ;0 into status mov m,a ret fcerr call prefcb lxi d,fermsg jmp ferr fermsg db 'close error$' ; ;prints (A) restoring all registers aout push h! push d! push b! push p mvi c,wrcon mov e,a cpi 0DH jnz aout2 call fdos ;after also send mvi e,0AH mvi c,wrcon aout2 call fdos pop p jmp bdhret ; ;prints (A) in hex ahexout push p rrc! rrc! rrc! rrc call hexout pop p ;and fall into hexout ;prints one hex digit from (A) hexout push p ani 15 adi 90h daa aci 40h daa call aout pop p ret ; ;prints tiny-c string (null terminated) ps mov a,m ora a rz call aout inx h jmp ps ; ;prints (C) chars starting at (HL) prntnch mov a,m call aout dcr c inx h jnz prntnch ret ; ;prints cp/m style string, ($ terminated) pcs mvi c,prbuff jmp fdos ; ;Tests for char ready from the terminal, as specified ;in the Owner's Manual, Sec. 6.1.1. HOLD is a software ;buffer shared by chardy and inch, and HOLDF is a flag ;indicating whether or not a char is in HOLD. chrdy mvi c,chcon ;check the console status call fdos ani 1 ;mask of least signif bit jz tryhold mvi c,rdcon ;read from the console call fdos ani 07fh ;mask out hi bit sta hold xra a ;set holdf to -1 dcr a sta holdf tryhold lda holdf ;test hold flag ora a rz ;no char ready lda hold ;got one in hold ora a rnz mvi a,1 ;null byte, return a 1 ora a ret ; inch lda holdf ;try hold first ora a jz tryport xra a ;have one in hold sta holdf ;zero the flag lda hold ;return the held char cpi 0DH rnz mvi a,0AH ;echo a line feed when read call aout mvi a,0DH ret tryport call chrdy ;hold is empty, so wait for human jz tryport ; to type something. jmp inch ;He did it, so use inch to read the character. holdf db 0 hold db 0 ; ;It all starts here. Cold start if no filename given. ; Otherwise load the named file, and hot start it. A ; default filetype TC is provided. start lda tfcb+1 cpi ' ' jz tcorg ;cold start lhld mstack ;set SP sphl lxi b,-10 ;initialize tiny-c lhld bpr xchg lxi h,inst call move lhld bpr lxi d,9 dad d call hlneg shld progend lxi h,tbuff ;put null at end of string. mov a,m ;get length inx h ;beginning of string push h add l mov l,a ;hl -> end of string mvi m,0 pop h ;begin of string inx h ;skip over single blank lxi b,1 ;unit 1 mvi a,1 ;rw set to read call fopen jnz tcorg ;cold start on error lhld progend ;where to read st2 call hlneg lxi b,1 call rdblok jnz stout dad d mvi m,0 call hlneg shld progend jmp st2 stout push p ;save last read result lxi b,1 call fclose pop p cpi 0ffh ;test for end of file jnz tcorg ;if not end of file, then error, hence cold start jmp tcorg+6 ;hot start ; efcb ds 36 ;for unit 1 ; ;User Machine Calls -- defined in CP/M supplement. usermc mov a,l cpi 1 jz mc1001 cpi 2 jz mc1002 cpi 3 jz mc1003 jmp mceset ; mc1001 call toptoi ; FDOS ( fnum, arg ) push d ;arg -> stack call toptoi ;fnum -> C mov c,e pop d ;arg -> DE push b ;save fnum for later call entry mov e,a ;result -> DE mvi d,0 pop h ;fnum -> L mov a,l cpi 27 ;only function 27 returns 2 bytes jnz pushk mov d,b ;hi byte for 27 jmp pushk ; mc1002 call toptoi ;sefcb(string,efcb) push d call toptoi xchg ;string -> HL pop d ;efcb -> DE call drive jnz pushk ;illegal drive pushed addr of efcb call fnft jmp pzero ; mc1003 call toptoi ;efcb -> DE xra a call prefcb jmp pzero =COPYRIGHT (C) 1978, DIGITAL RESEARCH DDT VERS 1.4$10 !~=W!xe ~#Xbxʇ {z~#o}o҃i.*|g> >کÝ!p+q*DM͡:͆ ͆:_2:`!!:*& N͆!4!6ÃO$+q+p+qy͏ , $  ͌ 9!z6 # L!zw͌j# X:z 0 ͘=N#Fy}80*z{¯#z+++ ¥ z#½# · 9!`͠ y9!rͷ y=!z{w# % w!P͠ y͓}*w#"͌ @.@<!Eͷ~P !ͷ’P͌Q!ͷªP}QxQ!ͷ͓G@Q! ͷ y͓Gþ!ͷ ͓Q!ͷ͓Q͌Q!.ͷ6y#G͙Qà!2ͷQ͓͌Q!>ͷq eg͙Q:zJEËC–EQyQxQRQ** {zҷ*~#" <AOGƐ'@'OxƐ'@'ON# z8O!B N#N ¾SP.* |} !9":q!"28!"9:] !ç 1͍ !" >- Ͱ Aڥ ҥ _!7^#V~  \p Z t ů2[\͍͢ ҥ ͊ =¥ ` " ͍ ҥ ͊ ʻ` " =ʻ` "=¥ ý> 2͊ ` "W=` =¥ *W}o"Y  *W"[( Ϳ ~ #? }"W*[Ϳ 0 *W}#|#*W? ͊ ¥ ` ` ` {zA|¥ W}d ͊ ` ` ` DMʡڏ"=ʡͲ=ʡYPͲ1**!I~4#~#F#x~#s#r#w>͊ ¥ ` `  ( Ϳ ᯕo>g( 2|2\  !]w# ʥ .&  0 6 #& .K !e K w# ʥ : U 6 #K 6AW w#] !e~H#~E#~X*}|{ "!{ ͊ !ʦ =¥ ` kʥ j \͢@ w# ͅ ú n ʥ : W _ O { `i"@ w# ͅ ¥ n S n S GтWx ͢!i ~T #H  *( Ϳ *(  NEXT PC͊ =¥ `  ( Ϳ ~ Ϳ Ͱ ʵ .͍ =¥ ` |¥ }w#~ ÿ >2F͊ ! =¥ ` }ʥ +"G> Å >  !  # å ¥   Ϳ Ͱ ͊ =¥ ` xS |¥ }ҥ gA>M Ag}M M c |¥ }!w s#r:[ʎ _!~ʠ ![4á \͢  2[y 7 >?  _͢!a"]> _͢a_!`~> 5*]~#"] 0 7   > >  ͢| } : >. *Y}o| , 0 å ^#V#!S ))))o J k s#r#!P4 !P6# ,¨ >2Pë g  g  g  ¥ Pʥ ! XN!~  ! _^! ^#V~ x% >= 7 !~ ( !   #x ` F Ϳ F Ϳ ͍ Ҁ *" !6é +"Y*~ #? ک Ϳ ʥ ^#V( é ~ CZMEIABDHSP!"G"+"!91*~!I~6 =G#^#V#~x "#"!N#FW" *D>7Å*G|H+"G H:FBÅ> Å >* *͍ \" ( *"W !)~##{nZ*F#h!Cs!^#V   ##::^#V#þ*^#V>%#x'8_#*;#ø##>%><7"T6*}^!T42 G Ͱ *hMͽG:ͮ+GGW +GU!ͩ>̀+! @!!BH @@ABH B! "BHI$$BI$BI $ HI D$HD$$ H B!$D$"$B$DA!ABI$H B$I $HI$H$! $I $I$$A !A@$I$"!$H$I$I "! $A$  HHAA"I @$BH! $!D$H$ I$$DH@H"B$HDDH@$""A $@ D$BB H A$$BAB"DH I$I "D H@ @@" @D"II!$I A"UUUI$$ D$$/* /* recursive factorial routine. /* fact int x [ if (x <= 1) return 1 else return x*fact(x-1) ] /* /* driver. /* test int x [ ps "factorial of" pn x;ps " is" pn fact(x) ] /* guess a number between 1 and 100. /* /* t. a. Gibson 11/29/76. /* guessnum [ int guess, number char answer answer = 'y' while (answer == 'y') [ number = random (1,100) pl "Guess a number between 1 and 100." pl"";ps "What is your guess? ";guess = gn while (guess != number) [ if (guess < number) ps "Too low." if (guess > number) ps "Too high." pl "";ps "What is your guess? ";guess = gn ] /* end while loop. ps "RIGHT!!";pl"";ps "Again (y/n)? " answer = gc ] /* end of answer loop. ] /* end guessnum. /* /* random number generator. /* int last, seed random int low, high [ int range if (last == 0) last=seed=99 range = high - low + 1 last = last * seed if (last < 0) last = -last return low + (last/7)%range ] /* hello.tc hello [ pl"hello, tiny-c!" ] /* pps.tc - 10/24/2007 - lrb putchar char c [if(c==0)c='"' return MC c,1 ] getchar [return MC 2 ] chrdy[return MC 12] pft char f(0),t(0)[MC f,t,13] gs char b(0) [int l while((b(l)=MC(2))!=13)[ if(b(l)==21)[l=0;pl">"] else if(b(l)==127)[if(l>0)l=l-1;] else if(b(l)==18)[MC(13,1);pft b,b+l-1] else l=l+1 ] b(l)=0 return l ] ps char b(0)[ int k(0);k(0)=1 pft(b,b-1+scann(b,b+30000,0,k)) ] pl char b(0) [MC 13,1 ps b ] alpha char a [ if((a>='a')*(a<='z'))return 1 if((a>='A')*(a<='Z'))return 1 ] num char b(5) int v(0) [int k v(0)=0 while(k<5) [if((b(k)<'0')+(b(k)>'9'))return k v(0)=10*v(0)+b(k)-'0' k=k+1 ] return k ] atoi char b(0) int v(0) [int k,s char c s=1 c=b(0) while((c==' ')+(c=='-')+(c=='+')) [if(c=='-')s=-1 c=b(k=k+1) ] k=k+num(b+k,v) v(0)=s*v(0) return k ] pn int n [ MC ' ',1 MC n,14 ] gn [char b(20) int v(0) while(1) [gs b if(atoi b,v)return v(0) ps"number required " ] ] ceqn char a(0),b(0) int n [int k k=-1 while((k=k+1)l+1) [pl"Too big" return -2 ] ] ] writefile char n(0),b(0),e(0) int u [int k,t,l MC(2,n,e-b+1,u,3) while(b<=e) [ l=e-b if(l>127)l=127 k=MC(b,b+l,u,5) if(k<0)return k if(k>0)return -k t=t+l+1 b=b+l+1 ] k=MC(u,6) if(k<0)return k if(k>0)return -k return t ] fopen int m;char n(0);int s,u[return MC m,n,s,u,3] fread char a(0);int u[return MC a,u,4] fwrite char f(0),t(0); int u[return MC f,t,u,5] fclose int u[MC u,6] fdos int f,a[return MC f,a,1001] sefcb char f(0),e(0)[return MC f,e,1002] prefcb char e(0)[MC e,1003] endlibrary int er(0),cu,lo,pe,lp int ll,la char ft(40),tt(40) int fl,tl char ln(120),pr(7000) main [char c int v(1) lp=7000 pr(0)=13 while(1) [ps">" ll=gs(ln) if(ll==0)[ln(0)='+';ln(1)=0] c=ln(0) if(c=='.') [if(num(ln+1,v))go(v) else if((ln(2)==0)+(alpha(ln(2))==0)) [c=ln(1) if(c=='p')pt else if(c=='d')dl else if(c=='l')oi else if(c=='c')ch else if(c=='/')fa else if(c=='r')gi else if(c=='w')gu else if(c=='x')return else [ps"???";pl""] ] else if(ceqn(ln+1,"dir",3))[ if(ln(4)==0)dir"*" else dir ln+5 ] else st ] else if(c=='-')up else if(c=='+')do else in ] ] pi int n [int f,l,v(0) v(0)=n f=fc lo=lo+v(0)-1 l=cu+scann(pr+cu,pr+pe,13,v) cu=l lo=lo-v(0) MC pr+f,pr+l,13 ] fc [int k if((k=cu)==0)return 0 while(pr(k=k-1)!=13)if(k<0)break return k+1 ] lc [int k k=cu-1 while(pr(k=k+1)!=13)if(k>=pe)break return k ] nl [if((cu=lc()+1)>pe) [cu=pe return 0 ] return lo=lo+1 ] bl [if((cu=fc()-1)<0)cu=0 else lo=lo-1 ] pt[ int v(0) if(ln(2))num(ln+3,v) else v(0)=1 pi(v(0)) ] dl [int f,l,v(1) if(cu==0) [ps"cannot delete line 0";pl"" return ] if(ln(2)==0)v(0)=1 else num(ln+3,v) la=la-v(0) f=fc l=cu+scann(pr+cu,pr+pe,13,v) la=la+v(0) lo=lo-1 cu=f-1 if(llp) [ps"won't fit";pl"" return ] if(nl)movebl(pr+cu,pr+pe,ll) else[cu=cu+1;lo=lo+1] pe=pe+ll movebl(ln,ln+ll-1,pr-ln+cu) pr(cu+ll-1)=13 la=la+1 ] wh [int f,l,u,b pn lo;ps" --- err ";pn er(0);pl"" u=cu f=fc b=u-f l=lc f=f-1 while((f=f+1)=0)putchar(' ') putchar '<';pl"" ] do [int v(1) if(ln(1)==0)v(0)=1 else num(ln+1,v) v(0)=v(0)+lo go(v) ] up [int v(1) if(ln(1)==0)v(0)=1 else num(ln+1,v) if((v(0)=lo-v(0))<0)v(0)=0 go(v) ] go int l(1) [lo=l(0) l(0)=l(0)+1 cu=scann(pr,pr+pe,13,l) lo=lo-l(0) pi(1) ] fa [pn lo;pn la;pn pe;pn lp-pe;pl""] st [while(ll<=120) [ln(ll)=' ' ll=ll+1 ] MC(er,ln+1,pr+pe,pr,11) if(cu<0)cu=0;if(cu>pe)cu=pe lo=countch(pr,pr+cu-1,13) pl"";pl"" if(er(0)) if(er(0)==99)[ps"stopped";pl""] else wh ] gi [int k k=readfile(ln+3,pr+pe+1,pr+lp,1) if(k<0)return pe=pe+k la=countch(pr+1,pr+pe,13) pn k;pl"";fa ] gu [fa if(ll>3) pn writefile(ln+3,pr+1,pr+pe,1) else ps"write what" pl"" ] dir char f(0) [ char e(36),d int k if(sefcb(f,e))[ ps"???" return ] fdos(14,e(34)) d=17 while(1)[ k=fdos(d,e) if(k==255)return k=81+32*(k%4) pft k,k+10 pl"" d=18 ] ] ; LRB 10-17,21,23,24-2007 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; COPYRIGHT 1977, TINY-C ASSOCIATES ;;;;;;;;;;;;;;;;;; ;;;;;; ALL RIGHTS RESERVED ;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TCORG ORG 600H ; ORG ($+100H)/100H*100H ;go to round address LCFIX EQU 20H ;maps literals to lower case ;error codes STATERR EQU 1 CURSERR EQU 2 SYMERR EQU 3 RPARERR EQU 5 RANGERR EQU 6 CLASERR EQU 7 SYNXERR EQU 9 LVALERR EQU 14 PUSHERR EQU 16 TMFUERR EQU 17 TMVRERR EQU 18 TMVLERR EQU 19 LINKERR EQU 20 ARGSERR EQU 21 LBRCERR EQU 22 MCERR EQU 24 SYMERRA EQU 26 KILL EQU 99 ;recognition length of symbols VLEN EQU 8 ;where tc exits to. TCEXIT EQU 0000H ;end-of-line character ASCRET EQU 0DH ; ;entry points JMP COLD JMP WARM JMP HOT ;tailoring vector ECHO DB 0 ;zero suppresses char echo INCH JMP 0103h OUTCH JMP 0106h CHRDY JMP 0109h FOPEN JMP 010Ch FREAD JMP 010Fh FWRITE JMP 0112h FCLOSE JMP 0115h USERMC JMP 0118h PRBEGIN NOP NOP RET STBEGIN NOP NOP RET PRDONE NOP NOP RET ;MC tools XMCESET JMP MCESET XTOPTOI JMP TOPTOI XPUSHK JMP PUSHK MCARGS DB 0 ;escape character ESCAPE DB 1BH ;space allocation EFREE EQU 0CD00H BSTACK DW BFREE ESTACK DW -BFREE-80H+5 BFUN DW BFREE+80H EFUN DW -BFREE-100H+6 BVAR DW BFREE+100H EVAR DW -BFREE-100H-SPACE/8+VLEN+6 BPR DW BFREE+100H+SPACE/8 EPR DW -EFREE+300H MSTACK DW EFREE ;standard cells ERR DW 0 ERRAT DW 0 LEAVE DB 0 BRAKE DB 0 TOP DW 0 NXTVAR DW 0 CURFUN DW 0 CURGLBL DW 0 FNAME DW 0 LNAME DW 0 STCURS DW 0 CURSOR DW 0 PRUSED DW 0 PROGEND DW 0 ;stored negative APPLVL DB 0 ; ;literals BALPHS EQU $ ;beginning of alphabetics XIF DB LCFIX + 'i' DB LCFIX + 'f' DB 0 XELS DB LCFIX + 'e' DB LCFIX + 'l' DB LCFIX + 's' DB LCFIX + 'e' DB 0 XINT DB LCFIX + 'i' DB LCFIX + 'n' DB LCFIX + 't' DB 0 XCHAR DB LCFIX + 'c' DB LCFIX + 'h' DB LCFIX + 'a' DB LCFIX + 'r' DB 0 XWHI DB LCFIX + 'w' DB LCFIX + 'h' DB LCFIX + 'i' DB LCFIX + 'l' DB LCFIX + 'e' DB 0 XRET DB LCFIX + 'r' DB LCFIX + 'e' DB LCFIX + 't' DB LCFIX + 'u' DB LCFIX + 'r' DB LCFIX + 'n' DB 0 XBRK DB LCFIX + 'b' DB LCFIX + 'r' DB LCFIX + 'e' DB LCFIX + 'a' DB LCFIX + 'k' DB 0 XENDL DB LCFIX + 'e' DB LCFIX + 'n' DB LCFIX + 'd' DB LCFIX + 'l' DB LCFIX + 'i' DB LCFIX + 'b' DB LCFIX + 'r' DB LCFIX + 'a' DB LCFIX + 'r' DB LCFIX + 'y' DB 0 XR DB LCFIX + 'r' ;loader 'read' command XG DB LCFIX + 'g' ;'go' command DB 0FFH ;end of alphabetics LB DB '[' DB 0 RB DB ']' DB 0 LPAR DB '(' DB 0 RPAR DB ')' DB 0 COMMA DB ',' DB 0 NEWLINE DB ASCRET DB 0 CMNT DB '/' XSTAR DB '*' DB 0 SEMI DB ';' DB 0 XPCNT DB '%' DB 0 XSLASH DB '/' DB 0 XPLUS DB '+' DB 0 XMINUS DB '-' DB 0 LT DB '<' DB 0 GT DB '>' DB 0 NOTEQ DB '!' DB '=' DB 0 EQEQ DB '=' XEQ DB '=' DB 0 GE DB '>' DB '=' DB 0 LE DB '<' DB '=' DB 0 XNL DB ASCRET DB 0 ;EQ performs an assignment of top into top-1. Top-1 ; must be an lvalue. EQ CALL TOPTOI ;value into DE PUSH D ;stuff to be assigned CALL POPST ;where to assign ORA A JZ EQ2 ;if class>0 set size=2 MVI C,2 EQ2 MOV A,B ;must be lvalue CPI 'L' JNZ EQERR XCHG ;where -> HL POP D ;stuff -> DE MOV M,E ;assign lo byte DCR C ;size-- JZ PUSHK ;call/ret, put result on stack INX H MOV M,D ;hi byte JMP PUSHK ;call/ret, put result on stack EQERR CALL ESET DB LVALERR POP D JMP PUSHK ;skip the assign part ; ;-(BC) -> BC DNEG MOV A,C CMA MOV C,A MOV A,B CMA MOV B,A INX B RET ; ;difference between two top values -> DE, setting Z, CY TOPDIF CALL POPTWO ;hence fall into DSUB. ; ; (DE) - (BC) -> DE DSUB MOV A,E SUB C MOV E,A MOV A,D SBB B MOV D,A ORA E ;Z now set, CY clear MOV A,D RLC ;sign is now in CY RET ; ; (BC) + (DE) -> DE DADD MOV A,C ADD E MOV E,A MOV A,B ADC D MOV D,A ORA E ;Z now set. CY cleared. MOV A,D RLC ;Sign is now in CY, Z not hurt. RET ; ; (BC) * (DE) -> DE DMPY LXI H,0 DM2 MOV A,C ;test lo bit of BC RRC JNC DM3 DAD D ;add multiplier DM3 CALL BCRS ;shift BC right JNZ DM4 ;return if BC is 0 XCHG ;answer -> DE RET DM4 CALL DELS ;shift multiplier left, return JNZ DM2 ; if zero. XCHG RET ; ; shift BC right, setting Z if 0. BCRS XRA A ;zero CY flag MOV A,B RAR MOV B,A MOV A,C RAR ;picks up carry left by hi byte MOV C,A ORA B RET ; shift DE left. Sets z iff (DE)==0. DELS XRA A ;zero CY flag ; rotate DE left, CY -> lo bit RDEL MOV A,E ;lo byte first RAL MOV E,A MOV A,D RAL ;picks up carry left by lo byte MOV D,A ORA E RET ; ; (DE) % (BC) -> DE, quotient in HL. DREM MOV A,D ;sign of result -> stack XRA B PUSH PSW MOV A,D ;make factors positive ORA A CM DENEG MOV A,B ORA A CM DNEG MVI A,16 ;shift count -> stack PUSH PSW XCHG ;numerator -> HL LXI D,0 ;partial remainder -> DE DR2 CALL HLLS ;divide loop. Long left shift CALL RDEL ; DEHL. JZ DR3 CALL DCMP ;test BC <= DE JM DR3 MOV A,L ;set lo bit of L, and subtract ORI 1 ; divisor from partial MOV L,A ; remainder CALL DSUB DR3 POP PSW ;decrement shift count DCR A JZ DR4 PUSH PSW JMP DR2 DR4 POP PSW ;put sign on quotient and rem RP CALL DENEG XCHG CALL DENEG XCHG RET ; ; (DE) / (BC) -> DE DDIV CALL DREM XCHG RET ; ; -(DE) -> DE DENEG MOV A,D CMA MOV D,A MOV A,E CMA MOV E,A INX D RET ; ;double compare (DE) - (BC) changing neither, but ; setting s, cy ; Note that z is not set reliably. DCMP MOV A,E SUB C MOV A,D SBB B RET ; ;HL left shift HLLS DAD H RET ; ;@@@@@@@@ stack tools @@@@@@@@@@ ; ;TOPTOI pops top of stack into DE, converting lvalue ; to actual if necessary. TOPTOI CALL POPST ;class in A, lvalue in B, STA TPCLASS ; size in C, stuff in DE MOV A,B CPI 'A' JZ TT2 XCHG ;fetch data MOV E,M INX H MOV D,M TT2 DCR C ;if size 1 and class 0 return RNZ ; lo byte, with sign propgated LDA TPCLASS ; thru hi byte. ORA A RNZ MOV A,E RLC ;propogate sign into D. SBB A MOV D,A RET TPCLASS DB 0 ; ;pops two from stack, top -> bc, next -> de. POPTWO CALL TOPTOI PUSH D CALL TOPTOI POP B RET ; ;pops the stack into A, B, C, DE. New top in HL. POPST LHLD TOP MOV A,M ;class INX H MOV B,M ;lvalue INX H MOV C,M ;size INX H MOV E,M ;stuff, lo-byte INX H MOV D,M ;stuff, hi-byte PUSH B LXI B,-9 DAD B ;decrement top by 5. POP B SHLD TOP RET ; ;pushes constant 1. PONE LXI D,1 JMP PUSHK ;pushes constant 0. PZERO LXI D,0 ;pushes constant in DE PUSHK XRA A ;class 0 MVI B,'A' ;actual MVI C,2 ;2 byte size ;pushes class (A), lvalue (B), size (C), stuff (DE) ; onto stack. PUSHST LHLD TOP ;add 5 to top. PUSH D LXI D,5 DAD D SHLD TOP XCHG LHLD ESTACK DAD D XCHG ;top -> HL POP D ;restore stuff JC PERR MOV M,A INX H MOV M,B INX H MOV M,C INX H MOV M,E INX H MOV M,D RET PERR CALL ESET DB PUSHERR RET ; ; @@@@@@@@ ESET sets ERR unless one is already set @@@@ ESET LDA ERR XTHL ORA A JZ ES2 INX H XTHL RET ES2 MOV A,M INX H XTHL STA ERR LHLD CURSOR SHLD ERRAT RET ; ;store 0's from (DE) thru (HL) inclusive ZERO MVI B,0 ;store (B) from (DE) thru (HL) inclusive BZAP MOV A,L SUB E MOV A,H SBB D RC MOV M,B DCX H JMP BZAP ; ;print string starting at (HL), terminated by null byte PS MOV A,M ORA A RZ CALL OUTCH INX H JMP PS ; ;@@@@@@@@@ SCAN TOOLS @@@@@@@@@@@@ ; ;LIT is used to match literals. It advances the cursor ; over blanks, then attempts a match with the literal. ; DE points to the literal, which is terminated by a ; null byte. On match, the cursor is advanced ; beyond the matched text, and NZ is set. On no match ; the cursor is not advanced (except over the initial ; blanks), and Z is set. LIT is called often, so some ; attention to speed is given, mainly by using inline ; code for blanks and string matching. LIT LHLD CURSOR MVI A,' ' ;trim blanks LIT2 CMP M JNZ LIT3 INX H JMP LIT2 LIT3 SHLD CURSOR ;capture cursor, in case no mch LIT4 LDAX D ;char from literal ORA A JZ MATCH ;null signals end of literal CMP M ;char from program INX D INX H JZ LIT4 XRA A ;no match, return Zero ORA A RET MATCH SHLD CURSOR ;capture new cursor CMA ;return Not Zero ORA A RET ; ;advances cursor over blanks. Puts cursor in HL. BLANKS LHLD CURSOR MVI A,' ' LOOP CMP M JNZ BLOUT INX H JMP LOOP BLOUT SHLD CURSOR RET ; ;skips over balanced l-r delimiters, (assuming the ;first l delimiter is already matched.) Tests that ;cursor stays within program limits, and sets ERR and ;doesn't advance cursor on violation. SKIP MVI D,1 ;counter SK2 MOV A,M CMP B JZ SKL ;match left delimiter CMP C JNZ SKNEXT DCR D ;match right delimiter JNZ SKNEXT INX H ;all done, bump over last SHLD CURSOR ; matched. STC CMC ;CY off on success RET SKL INR D SKNEXT INX H ;bump HL, test for overflow XCHG ;cursor -> DE PUSH H ;make H safe LHLD PROGEND ;stored negative, so add DAD D POP H XCHG ;now all reg's restored JNC SK2 CALL ESET DB CURSERR STC ;CY set on error RET ; ;tests if (A) is alphanumeric. Plus on yes. ALNUM CPI '0' RM CPI '9'+1 JM YESA ;tests if (A) is alpha. Plus on yes. ALPHA CPI 'A' RM ;not alpha CPI 'Z'+1 JM YESA CPI LCFIX + 'a' RM CPI LCFIX + 'z'+1 JM YESA CMA ;not alpha, this sets Minus. ORA A RET YESA XRA A ;set Plus. RET ; ;matches a variable or function name. Sets FNAME, ; LNAME to first and last chars of the name. Returns ; Not Zero on match, Zero on no match. SYMNAME CALL BLANKS SHLD FNAME MOV A,M CALL ALPHA JM SY3 SY2 INX H ;is a symbol, find its end. MOV A,M CALL ALNUM JP SY2 SHLD CURSOR ;just beyond symbol DCX H SHLD LNAME ;symbol end RET SY3 XRA A ;no symbol, return Z RET ; ;matches 3 kinds of constants, setting FNAME, LNAME as ; in SYMNAME. Sets A to 0 on no match, 1,2,or 3 on mch CONST CALL BLANKS MOV A,M ;first char CPI '+' ;test for number JZ CN2 CPI '-' JZ CN2 CPI '0' JM CN3 CPI '9'+1 JP CN3 CN2 SHLD FNAME ;number, cursor to fname CN4 INX H ;find end MOV A,M CPI '0' JM CN5 CPI '9'+1 JM CN4 ;is a digit, keep going CN5 SHLD CURSOR ;not a digit DCX H SHLD LNAME MVI A,1 ;type 1 constant (integer) RET CN3 CPI '"' ;test for quoted string JNZ CN6 INX H ;quote found SHLD FNAME ;first char of string (quote CN7 MOV A,M ; excluded ORA A ;ended by either null or " JZ CN8 SBI '"' JZ CN8 INX H XCHG ;cursor check LHLD PROGEND DAD D XCHG JNC CN7 JMP CNERR ;cursor overflow CN8 MOV M,A ;end quote found, replace with DCX H ; a null. SHLD LNAME ;last char of string MVI A,2 ;constant of type 2 (char str) ORA A INX H INX H SHLD CURSOR RET CN6 CPI 27H ;test for prime JNZ CN9 INX H SHLD FNAME CN12 MOV A,M ;scan for matching prime CPI 27H JZ CN11 INX H XCHG ;cursor check LHLD PROGEND DAD D XCHG JNC CN12 JMP CNERR CN11 MVI A,3 ;found matching prime ORA A INX H SHLD CURSOR RET CN9 XRA A ;no match RET CNERR CALL ESET DB CURSERR RET ; ;skips over remarks and/or end-of-lines in any order. REM LXI D,NEWLINE CALL LIT JZ RE2 RE3 MOV A,M ;skip linefeeds CPI 0AH JNZ REM INX H SHLD CURSOR JMP REM RE2 LXI D,CMNT CALL LIT RZ MVI B,1 ;comment found, skip its text MVI C,ASCRET CALL SKIP RC ;error check JMP RE3 ; ;HL points to start of digit string. Converts to intger ; leaving result in DE. Uses all digits, even if DE ; overflows. First nondigit stops scan. ATON XCHG ;pointer into DE LXI H,0 ;answer developed here AN2 LDAX D ;next ascii SUI 48 JC AN3 ;test for digit CPI 10 JNC AN3 MOV B,H ;digit, set HL=10*HL+A MOV C,L DAD H DAD H DAD B DAD H MOV C,A MVI B,0 DAD B INX D ;bump pointer JMP AN2 AN3 XCHG ;answer -> DE RET ; ;HL points to beginning of ascii integer, possibly ; signed. Converts to integer and leaves value in DE. AISGN DB 0 ;nonzero for - ATOI XRA A STA AISGN AI6 MOV A,M ;skip blanks CPI ' ' JNZ AI2 INX H JMP AI6 AI2 CPI '-' ;test sign JNZ AI3 STA AISGN ;is - INX H AI3 CPI '+' JNZ AI4 INX H AI4 MOV A,M ;skip more blanks CPI ' ' JNZ AI5 INX H JMP AI4 AI5 CALL ATON ;does the digits LDA AISGN ;magnitude in DE ORA A RZ JMP DENEG ;computes negative and returns ; ;@@@@@@@@@ SYMBOL TOOLS @@@@@@@@@@@ ; ;allocate reference in FUNB for variables of a function NEWFUN LHLD CURFUN LXI D,6 ;bump CURFUN by 6 DAD D SHLD CURFUN XCHG ;test too many active functions LHLD EFUN DAD D XCHG JNC NF2 CALL ESET DB TMFUERR RET NF2 LDA NXTVAR ;init first and last var MOV M,A ;fv lo byte SUI 6+VLEN MOV C,A ;lv lo byte -> C for now LDA NXTVAR+1 INX H MOV M,A ;fv hi byte SBI 0 ;picks up possible carry INX H MOV M,C ;lv lo byte INX H MOV M,A ;lv hi byte LDA PRUSED ;now set up backup pointer INX H MOV M,A ;bu lo byte LDA PRUSED+1 INX H MOV M,A ;bu hi bytv RET ;all done ; ;deallocate variables of last function. FUNDONE LHLD CURFUN MOV A,M STA NXTVAR ;lo byte INX H MOV A,M STA NXTVAR+1 INX H INX H INX H MOV A,M STA PRUSED INX H MOV A,M STA PRUSED+1 LXI D,-11 DAD D ;subtract 5 for above INX's, SHLD CURFUN ; plus 5 more to pop FUNB. RET ; ;allocate a variable. Class in A, size in B, len in DE, ; passed value in HL. CLASS DB 0 ;temps used by newvar OBSIZE DB 0 PASSED DW 0 LEN DW 0 FVAL DW 0 KF DW 0 ; NEWVAR STA CLASS MOV A,B STA OBSIZE SHLD PASSED XCHG SHLD LEN LHLD NXTVAR CALL CANON ;put canonical form of name ; into (NXTVAR). Leaves HL ; pointing to last byte of NAME of VARB. INX H ;-> CLASS in VARB. LDA CLASS MOV M,A INX H ;-> OBJSIZE in VARB. LDA OBSIZE MOV M,A INX H ;-> LEN in VARB (2 bytes). LDA LEN MOV M,A INX H LDA LEN+1 MOV M,A INX H SHLD FVAL ;address where fval will be put LDA CLASS ORA A ;if class is 0, or not a passed JZ NR2 ; arg, then get value space. LHLD PASSED MOV A,L ORA H JNZ NR3 NR2 LHLD PRUSED ;get value space INX H ; starting at PRUSED + 1 SHLD KF ;Put in KF for later use. XCHG LHLD FVAL MOV M,E INX H MOV M,D ;fval part of varb set to LHLD LEN ; prused+1. Now bump prused XCHG ; by obsize*len. LHLD PRUSED LDA OBSIZE DAD D DCR A JZ NR7 DAD D NR7 SHLD PRUSED XCHG ;test if allocation exceeds LHLD EPR ; limits of prog space. DAD D XCHG JNC NR4 CALL ESET ;RAM exceeded DB TMVLERR RET NR4 LHLD KF ;zero the allocated space XCHG LHLD PRUSED CALL ZERO JMP NR5 ;end of space allocation NR3 LHLD FVAL ;Value is passed and is a LDA PASSED ; class > 0. Put value in fval MOV M,A ; part of VARB. Dont allocate INX H ; space. LDA PASSED+1 MOV M,A JMP NR6 NR5 LDA CLASS ;if passed & class is 0 move ORA A ; the passed value into the JNZ NR6 ; allocated space. LHLD PASSED MOV A,H ORA L JZ NR6 XCHG ;passed -> DE LHLD KF MOV M,E ;lo byte of passed value INX H MOV M,D ;hi byte, or junk if only one ; byte passed. Who cares. NR6 LHLD CURFUN ;in FUNB set lvar part to this INX H ; variable. INX H LDA NXTVAR MOV M,A INX H LDA NXTVAR+1 MOV M,A LHLD NXTVAR ;increment NXTVAR LXI D,6+VLEN ; by 6 + vlen DAD D SHLD NXTVAR XCHG ;test if too many variables LHLD EVAR DAD D XCHG LHLD FVAL RNC ;normal return, FVAL in HL. CALL ESET ;VARB exceeded. DB TMVRERR RET ; ;ADDRVAL looks up a symbol pointed to by FNAME,LNAME. ; Returns address in HL, class in A, size in B, and ; length in DE. Sets err if symbol cannot be found. ; Searches 3 areas: ; area 0 locals ; 1 globals ; 2 library symbols NAME DS VLEN ;holds canonical form of name PVAR DW 0 AREA DB 0 SFUN DW 0 LAST DW 0 ; ADDRVAL LHLD CURFUN SHLD SFUN ;search locals first LXI H,NAME CALL CANON XRA A STA AREA ;area 0 AD8 LHLD SFUN ;variable search area MOV E,M INX H MOV D,M ;fvar of search area -> DE INX H MOV C,M INX H MOV B,M ;lvar -> BC XCHG SHLD PVAR ;currently searched variable MOV H,B MOV L,C SHLD LAST ;last to search in this area LHLD PVAR ;begin search loop AD2 LDA LAST ;test for end of loop SUB L LDA LAST+1 SBB H JC AD3 MVI C,VLEN ;number of chars to match LXI D,NAME ;match string address AD4 LDAX D ;(HL already as table entry) CMP M JNZ AD5 ;no match DCR C INX D INX H JNZ AD4 ;next char MOV A,M ;MATCH. HL points to class. INX H MOV B,M ;obsize INX H MOV E,M INX H MOV D,M ;length INX H ORA A ;if class > 0 & class < 'E' JZ AD9 ; then return address of fval CPI 'E' ; part of VARB, which is alrdy RNZ ; in HL. AD9 PUSH D ;otherwise return contents of MOV E,M ; fval part of VARB. INX H MOV D,M XCHG POP D RET AD5 LHLD PVAR ;go to next variable LXI D,VLEN+6 DAD D SHLD PVAR JMP AD2 AD3 LDA AREA ;go to next area ORA A JNZ AD6 LHLD CURGLBL ;second search area, globals AD7 SHLD SFUN INR A STA AREA JMP AD8 AD6 CPI 2 JP ADERR LHLD BFUN ;third area is library, which JMP AD7 ; is at beginning of FUNB. ADERR CALL ESET DB SYMERRA RET ; ;canonicalizes symbol from FNAME to LNAME inclusive, ; putting form with VLEN chars in (HL). OUTNAME DW 0 CANON SHLD OUTNAME MVI A,VLEN ;zero output field MVI B,0 MOV C,B ;zero C for later CA2 MOV M,B DCR A JZ CA3 INX H JMP CA2 CA3 PUSH H ;save pointer to last byte LHLD FNAME ;compute symbols actual length LDA LNAME SUB L INR A CPI VLEN JM CA6 MVI A,VLEN ;A now has number of chars to MOV C,A ; be moved, and C is nonzero CA6 XCHG ; iff act len > VLEN. MOV B,A LHLD OUTNAME ;FNAME -> DE, OUTNAME -> HL CA4 LDAX D ;copy loop MOV M,A DCR B JZ CA5 INX D INX H JMP CA4 CA5 POP H ;pointer to last byte XRA A ORA C ;test if short name RZ XCHG ;long name, put last char in LHLD LNAME ; the canon form. MOV A,M ;last char of name XCHG MOV M,A ;into last pos of outname RET ;ASGN is the expression evaluator,so called because ; the highest form of an expression is an assignment. ; An asgn is a reln or an lvalue = asgn. Note that ; reln can match an lvalue. ;Returns non-zero if valid expression, 0 if invalid. ASGN CALL RELN ;stacked as lvalue if that's ; what it is. LXI D,XEQ ; test for = CALL LIT JZ A2 CALL ASGN LDA ERR ;check for error ORA A CZ EQ ;perform assignment A2 LDA ERR ;return 0 (i.e. no match) if ORA A ; there was an error JZ A3 XRA A RET A3 DCR A ;no error so return non-zero A RET ; ;a RELN is an expr or a comparison of exprs RELN CALL EXPR LXI D,LE ; <= CALL LIT JZ R2 CALL EXPR ;right side CALL TOPDIF ;sets Z,C flags. C set as JZ PONE ; though it were S. Must be JC PONE ; zero or negative for true. JMP PZERO ;These jumps all call/rets. R2 LXI D,GE ; >= CALL LIT JZ R3 CALL EXPR CALL TOPDIF JZ PONE JNC PONE JMP PZERO R3 LXI D,EQEQ ; == CALL LIT JZ R4 CALL EXPR CALL TOPDIF JZ PONE JMP PZERO R4 LXI D,NOTEQ CALL LIT JZ R5 CALL EXPR CALL TOPDIF JNZ PONE JMP PZERO R5 LXI D,GT ; > CALL LIT JZ R6 CALL EXPR CALL TOPDIF JZ PZERO JC PZERO JMP PONE R6 LXI D,LT ; < CALL LIT RZ ; no relational operator CALL EXPR CALL TOPDIF JC PONE JMP PZERO ; ;an EXPR is a term or sum (diff) of terms. EXPR LXI D,XMINUS ; unary - CALL LIT JZ EX2 CALL TERM CALL TOPTOI ;push negative of top back onto MOV A,E CMA MOV E,A MOV A,D CMA MOV D,A INX D CALL PUSHK JMP EX3 EX2 LXI D,XPLUS ;optional unary + CALL LIT CALL TERM ;first term is now stacked. Check for error so far. EX3 LDA ERR ORA A RNZ LXI D,XPLUS ; + CALL LIT JZ EX4 CALL TERM CALL POPTWO ;top two values on stack are ; actualized and put into ; (BC) and (DE). CALL DADD ; (BC)+(DE)->(DE) CALL PUSHK ; sum onto stack. JMP EX3 ;back for more terms EX4 LXI D,XMINUS ; - CALL LIT RZ ;no more terms CALL TERM CALL POPTWO CALL DSUB CALL PUSHK JMP EX3 ;back for more terms. ; ;a term is a factor or a product of factors. TERM CALL FACTOR TE2 LDA ERR ;check for error so far ORA A RNZ LXI D,XSTAR ; * CALL LIT JZ TE3 CALL FACTOR CALL POPTWO CALL DMPY CALL PUSHK JMP TE2 ;back for more factors. TE3 CALL REM ;make sure no /* LXI D,XSLASH ; / CALL LIT JZ TE4 CALL FACTOR CALL POPTWO CALL DDIV CALL PUSHK JMP TE2 TE4 LXI D,XPCNT ; % CALL LIT RZ ;no more factors. CALL FACTOR CALL POPTWO CALL DREM CALL PUSHK JMP TE2 ; ;a FACTOR is a ( asgn ), or a constant, or a variable ; reference, or a function reference. FACTOR LXI D,LPAR ; ( CALL LIT JZ FA2 CALL ASGN LXI D,RPAR ; ) CALL LIT RNZ CALL ESET ;right paren error DB RPARERR RET FA2 CALL CONST ;recognizes 3 types of constant JZ FA5 ; setting A accordingly. CPI 1 JNZ FA3 LHLD FNAME ;type 1: integer. FNAME points CALL ATOI ; to beginning. ATOI converts JMP PUSHK ; it, leaving value in (DE). FA3 CPI 2 JNZ FA4 MVI A,1 ;type 2: char string. Push MVI B,'A' ; class=1, lval='A', size=1, MVI C,1 ; and stuff=address of LHLD FNAME ; beginning of string. XCHG JMP PUSHST FA4 XRA A ;type 3: char constant. Push MVI B,'A' ; class=0, lval='A', size=1, MVI C,1 ; and stuff=actual character. LHLD FNAME MOV E,M JMP PUSHST FA5 CALL SYMNAME ;not a constant, try symbol. JZ FA6 LHLD FNAME ;symbol. Test for special INX H ; symbol MC. First is symbol LDA LNAME ; length exactly 2. CMP L JNZ FA7 LDA LNAME+1 CMP H JNZ FA7 MOV A,M ;length is 2, and (HL)=FNAME. CPI 'C' JNZ FA7 DCX H MOV A,M CPI 'M' JNZ FA7 LXI H,0 JMP ENTER ;causes machine call. FA7 CALL ADDRVAL ;not MC, look up symbol. SHLD FWHERE STA CLASS MOV A,B ;save results of lookup. STA OBSIZE XCHG SHLD LEN MOV A,D ;where is now in DE ORA E JZ FA8 LDA CLASS CPI 'E' ;class E => function entry JZ FA9 LXI D,LPAR ;variable. Test for subscript. CALL LIT JZ FA10 LDA CLASS ;subscripted, class must be > 0 DCR A STA CLASS ;class of element is one less JP FA11 ; than class of array. CALL ESET DB CLASERR RET FA11 LHLD FWHERE ;replace where by two bytes MOV E,M ; referenced by where. INX H MOV D,M PUSH D ;save where, len, class, LHLD LEN ; obsize. PUSH H LHLD CLASS ;(also gets obsize) PUSH H CALL ASGN ;evaluate subscript POP H SHLD CLASS ;restore everything POP H SHLD LEN POP H SHLD FWHERE RZ ;assign error LXI D,RPAR ;skip ) CALL LIT CALL TOPTOI ;subscript value -> DE XCHG SHLD SUBSCR XCHG LHLD LEN MOV A,L DCR A ORA H ;for LEN = 1 skip subscript JZ FA12 ; check. LDA CLASS ORA A JNZ FA12 ;skip for pointers, too. ORA D JM SUBERR ;cant be negative MOV B,H ;len -> BC MOV C,L CALL DSUB JC FA12 ;subscr-len must be negative SUBERR CALL ESET DB RANGERR FA12 LHLD SUBSCR XCHG ;where =+ subscr * obsize LHLD FWHERE LDA OBSIZE FA13 DCR A JM FA14 DAD D JMP FA13 FA14 SHLD FWHERE FA10 LDA OBSIZE ;push class, 'L', obsize, MOV C,A ; stuff=where. LDA CLASS MVI B,'L' LHLD FWHERE XCHG JMP PUSHST ;call/ret FA9 LHLD FWHERE JMP ENTER ;call/ret FA8 CALL ESET ;symbol error DB SYMERR RET FA6 CALL ESET ;cannot recognize factor DB SYNXERR RET ; ;locals used by ASGN, etc. FWHERE DW 0 SUBSCR DW 0 ;SKIPST skips over a (possibly compound) statement, ; including whole nested sets of if-then-elses. ; Assumes balanced [], even within comments. SKIPST CALL REM LXI D,LB ;test for [ CALL LIT JZ SS2 MVI B,'[' MVI C,']' CALL SKIP JMP REM ;and done SS2 LXI D,XIF ;test for if or while CALL LIT JNZ SS6 LXI D,XWHI CALL LIT JZ SS3 SS6 LXI D,LPAR CALL LIT MVI B,'(' MVI C,')' CALL SKIP ;skip over (condition) part CALL SKIPST ;skip then part LXI D,XELS ;test for ELSE CALL LIT CNZ SKIPST ;skip else part JMP REM ;and done SS3 LHLD CURSOR ;simple statement, move cursor SS4 MOV A,M ; past next ; or return. CPI ASCRET JZ SS8 CPI ';' JZ SS5 INX H XCHG ;test cursor overflow LHLD PROGEND DAD D XCHG JNC SS4 JMP REM ;and done SS5 INX H SS8 SHLD CURSOR JMP REM ;and done ; ;VALLOC parses one variable behind INT or CHAR and ; makes allocation and symbol entry. TYPE DB 0 ;'C' or 'I' VPASSED DW 0 ;0 for global or local, two ; byte value if param to fnction ; It turns out a 0 valued parameter gets the same ; treatment as a local. VCLASS DB 0 ;defined in globals section. ALEN DW 0 ;elements in an array. ; VALLOC STA TYPE SHLD VPASSED CALL SYMNAME ;sets FNAME, LNAME around symbl JZ V2 ;error if no symbol. XRA A STA VCLASS ;assume class 0 (not an array) LXI D,LPAR CALL LIT JZ V3 LHLD FNAME ;array, evaluate subscript PUSH H ; expression. Must push FNAME, LHLD LNAME ; LNAME, and class, because PUSH H ; subscripts may invoke LDA VCLASS ; functions which themselves INR A ; allocate variables. PUSH PSW CALL ASGN POP PSW ;restore pushed stuff. STA VCLASS POP H SHLD LNAME POP H SHLD FNAME LDA ERR ;test for error in ASGN ORA A RNZ LXI D,RPAR CALL LIT ;skip ) CALL TOPTOI ;value of subscript + 1 into INX D ; LEN XCHG SHLD ALEN JMP V5 V3 LXI H,1 ;non-subscripted variable SHLD ALEN ; has ALEN 1. V5 LDA TYPE ;object size is 1 of 'C', 2 for MVI B,1 ; 'I' CPI 'C' JZ V7 INR B ;obsize in B V7 LDA VCLASS ;class in A LHLD ALEN ;len in DE. XCHG LHLD VPASSED ;passed in HL JMP NEWVAR ;call/ret, NEWVAR allocates the ; variable V2 CALL ESET DB SYMERR RET ; ;@@@@@@@@@@ tiny - c interpreter @@@@@@@@@@@@ ; ;ST interprets a possibly compound statement ; ST CALL QUIT ;test if program should quit. LDA ERR ORA A RNZ CALL REM ;pass over remarks and/or ; end of line CALL STBEGIN ;bugout for blips, statistics, ; ; etc, user provided. ST2 LHLD CURSOR ;capture cursor SHLD STCURS CALL DECL ;test for declaration JNZ REM LXI D,LB ;test for left bracket CALL LIT JZ TIF CALL REM CMPND LDA ERR ;compound statement. Execute MOV B,A ; each of its inner stmnts. LDA LEAVE ; Exit on error, leave, break, ORA B ; or ] literal. MOV B,A LDA BRAKE ORA B RNZ LXI D,RB ; ] CALL LIT JNZ REM ;and done CALL ST ;recursive call to ST JMP CMPND ;then do next statement. TIF LXI D,XIF ;test for IF CALL LIT JZ TWHI LXI D,LPAR ;skip ( CALL LIT CALL ASGN ;evaluate condition RZ ;return on error LXI D,RPAR ;skip ) CALL LIT CALL TOPTOI ;condition value MOV A,D ORA E JZ IF2 CALL ST ;true, execute conditional LXI D,XELS ;skip else clause if there CALL LIT CNZ SKIPST RET IF2 CALL SKIPST ;false, skip conditional LXI D,XELS ;execute else clause if there CALL LIT CNZ ST RET TWHI LXI D,XWHI ;test for WHILE CALL LIT JZ TSEM LXI D,LPAR ;skip ( CALL LIT CALL ASGN ;condition RZ ;return on error LXI D,RPAR ;skip ) CALL LIT CALL TOPTOI ;condition value MOV A,D ORA E JZ WH2 LHLD STCURS ;true, save STCURS and CURSOR PUSH H LHLD CURSOR PUSH H CALL ST ;execute object of while POP H ;saved cursor into OBJT SHLD OBJT POP H ; and stcurs into AGIN SHLD AGIN LDA BRAKE ;if a BREAK statement caused ORA A ; this return, then set CURSOR JZ WH3 ; to object of the while and LHLD OBJT ; skip over it, and restore SHLD CURSOR ; break. The WHILE is alllll CALL SKIPST ; done. XRA A STA BRAKE RET WH3 LHLD AGIN ;Otherwise, set cursor back to SHLD CURSOR ; beginning of while statement RET ; and return, causing WHILE to ; to be done again. WH2 CALL SKIPST ;If condition is false, skip RET ; the object, and done. TSEM LXI D,SEMI ;test for null statement CALL LIT JNZ REM ;and done TRET LXI D,XRET ;test for RETURN statement CALL LIT JZ TBRK LXI D,SEMI ;if ; or remark push a 0. CALL LIT JNZ TR2 LXI D,XNL CALL LIT JNZ TR2 CALL ASGN ;otherwise push return value JMP TR4 TR2 CALL PZERO TR4 MVI A,1 ;set leave flag STA LEAVE RET TBRK LXI D,XBRK ;test for BREAK CALL LIT JZ TASG MVI A,1 ;set break flag STA BRAKE RET TASG CALL ASGN ;if none of above, must be an JZ STER ; expression, or an error. CALL TOPTOI ;if an expression, discard its ; value. LXI D,SEMI ;skip optional ; CALL LIT JMP REM ;and done STER CALL ESET DB STATERR ;statement error RET OBJT DW 0 ;points to object of while AGIN DW 0 ;points to beginning of while ; ;DECL tests for and interprets declarations DECL LXI D,XCHAR CALL LIT ;test for CHAR JZ TINT CH2 MVI A,'C' LXI H,0 CALL VALLOC LXI D,COMMA CALL LIT JNZ CH2 ;get all vars CH3 LXI D,SEMI ;skip optional ; CALL LIT MVI A,07FH ;set flag to Not Zero ORA A RET TINT LXI D,XINT CALL LIT RZ ;flag is zero IN2 MVI A,'I' LXI H,0 CALL VALLOC LXI D,COMMA CALL LIT JNZ IN2 JMP CH3 ; ;catches interrupts (ESC key) at appl level. QUIT LDA APPLVL ORA A RZ CALL CHRDY RZ MOV B,A ;char keyed in -> B LDA ESCAPE CMP B RNZ CALL INCH ;discard the ESC CALL ESET ;signal the escape DB KILL RET ; ;evaluates arguments of a function. Sets cursor to ; beginning of function's text. Parses its argument ; declarations, giving them values of the parameters. ; executes the function. Determines cause of exit, and ; pushes default 0 return value if needed. Restores ; cursor. NARGS DB 0 ;number of args WHERE DW 0 ;0 for MC, otherwise address of ; function. ARG DW 0 ;pointer into stack to first ; arg. ENTER SHLD WHERE XRA A STA NARGS LHLD TOP LXI D,5 DAD D SHLD ARG LXI D,LPAR ;skip optional ( CALL LIT LXI D,RPAR ;test for no args, several ways CALL LIT JNZ ARGSDNE LHLD CURSOR MOV A,M CPI ']' JZ ARGSDNE CPI ';' JZ ARGSDNE CPI ASCRET JZ ARGSDNE CPI '/' JZ ARGSDNE EN2 LDA ERR ;eval args, first test for err ORA A RNZ LHLD ARG ;save locals PUSH H LHLD WHERE PUSH H LHLD NARGS PUSH H CALL ASGN ;evaluate POP H ;restore locals MOV A,L POP H SHLD WHERE POP H SHLD ARG INR A ;increment NARGS STA NARGS LXI D,COMMA CALL LIT ;comma means more args JNZ EN2 LXI D,RPAR ;optional ) CALL LIT ARGSDNE LDA ERR ORA A RNZ LHLD WHERE ;test for MC MOV A,H ORA L JNZ EN3 LDA NARGS CALL MC RET EN3 LHLD CURSOR ;save current cursor PUSH H LHLD STCURS PUSH H LHLD WHERE ;set cursor to start of fctn SHLD CURSOR CALL NEWFUN ;new layer of value space EN4 CALL REM ;parse arg decls and pass value LXI D,XINT ;works just like DECL, except CALL LIT ; uses SETARG instead of JZ EN5 ; VALLOC. EN6 LHLD ARG MVI B,'I' CALL SETARG LHLD ARG ;bump ARG pointer to next LXI D,5 ; stack layer DAD D SHLD ARG LXI D,COMMA CALL LIT JNZ EN6 LXI D,SEMI CALL LIT JMP EN4 EN5 LXI D,XCHAR CALL LIT JZ EN7 EN8 LHLD ARG MVI B,'C' CALL SETARG LHLD ARG LXI D,5 DAD D SHLD ARG LXI D,COMMA CALL LIT JNZ EN8 LXI D,SEMI CALL LIT JMP EN4 EN7 LHLD TOP ;test correct number of args LXI D,5 DAD D LDA ARG ;should be TOP+5 CMP L JZ EN9 POP D ;set up old cursor for POP H ; the error call SHLD CURSOR PUSH H PUSH D CALL ESET DB ARGSERR EN9 LXI H,NARGS ;pop all args off stack DCR M JM EN11 CALL POPST JMP EN9 EN11 LDA ERR ;if no errors, execute function ORA A CZ ST LDA LEAVE ;push 0 if default leave ORA A CZ PZERO XRA A ;zero LEAVE STA LEAVE POP H ;restore cvrsor SHLD STCURS POP H SHLD CURSOR CALL FUNDONE ;pop layer of value space RET ; ;HL points into stack to an arg. B (used by VALLOC) is ; type. SETARG gets actual value of arg, calls VALLOC ; to allocate local space, which also puts arg value ; into allocated space. SETARG PUSH B MOV B,M ;class INX H MOV A,M ;lvalue INX H MOV C,M ;size INX H MOV E,M ;stuff INX H MOV D,M CPI 'A' ;test for actual JZ SE2 XCHG ;address of datum -> HL MOV E,M INX H MOV D,M SE2 MOV A,C ;if size==1 & class==0 DCR A ORA B JNZ SE3 MOV A,E ; then propogate sign RLC SBB A MOV D,A SE3 POP B ;type -> A MOV A,B XCHG ;passed value -> HL JMP VALLOC ;call/ret, valloc does the rest ; ;scans program and allocates all externals in next fctn ; layer. An "endlibrary" line causes a new fctn layer ; to be opened. LINK CALL NEWFUN LI2 LDA ERR ;check no error ORA A RNZ LHLD CURSOR INX H INX H XCHG LHLD PROGEND DAD D XCHG RC CALL REM ;more text to process, skip LXI D,LB ; remarks. CALL LIT ;test for compound statement. JZ LIDCL MVI B,'[' ;skip compound st. MVI C,']' CALL SKIP JMP LI2 LIDCL CALL DECL ;test for declaration, and JNZ LI2 ; allocate it LXI D,XENDL ;test for endlibrary statement. CALL LIT JZ LISYM CALL NEWFUN JMP LI2 LISYM CALL SYMNAME ;test for symbol JZ LIERR MVI A,'E' ;allocate a variable with MVI B,2 ; class E, size 2, len 1, MVI E,1 ; passed value = cursor. (This MVI D,0 ; is a function entry.) LHLD CURSOR CALL NEWVAR LHLD CURSOR ;advance cursor to beginning of MVI A,'[' ; program body. LI3 CMP M JZ LI4 INX H XCHG LHLD PROGEND DAD D XCHG JNC LI3 CALL ESET DB LBRCERR RET LI4 SHLD CURSOR ;skip body CALL SKIPST JMP LI2 LIERR CALL ESET DB LINKERR RET ; ;move -(bc) bytes from (hl) to (de) MOVE MOV A,M STAX D INX D INX H INR C JNZ MOVE INR B JNZ MOVE RET ;it all starts here!!!!! ;cold start erases system level tc programs, and enters ; the loader. Used to load a tailered or different ; system program. ;warm start does not erase sys level progs, but enters ; the loader so more can be loaded. ;hot start assumes all the loading is done, and immed ; starts up the loaded sys level tc prog. ;Unfortunately, there is no hot start that preserves ; application programs. COLD LHLD MSTACK ;initialize 8080 stack, if need MOV A,H ORA L JZ CL2 SPHL CL2 LXI B,-10 ;copy initial statement LHLD BPR ; PR XCHG LXI H,INST ; into PR CALL MOVE LHLD BPR LXI D,9 DAD D CALL HLNEG SHLD PROGEND CALL LOGO WARM CALL LOADER HOT CALL LOGO LHLD PROGEND CALL HLNEG SHLD PRUSED LHLD BPR SHLD CURSOR LHLD BFUN LXI D,6 DAD D SHLD CURGLBL LXI D,-12 DAD D SHLD CURFUN LHLD BVAR SHLD NXTVAR LHLD BSTACK LXI D,-5 DAD D SHLD TOP XRA A MOV H,A MOV L,A STA ERR SHLD ERRAT STA LEAVE STA BRAKE CALL LINK CALL NEWFUN LHLD BPR SHLD CURSOR CALL PRBEGIN CALL ST ;this executes the system progm CALL PRDONE LXI H,DONEMSG CALL PS LDA ERR ORA A JZ NOERR LHLD ERR XCHG CALL PN MVI A,' ' ; and a space, CALL OUTCH LHLD ERRAT XCHG CALL PN NOERR MVI A,0DH CALL OUTCH JMP WARM DONEMSG DB 0DH DB 0DH DB 'D' DB 'O' DB 'N' DB 'E' DB ' ' DB 0 INST DB '[' DB LCFIX + 'm' DB LCFIX + 'a' DB LCFIX + 'i' DB LCFIX + 'n' DB '(' DB ')' DB ';' DB ']' DB 0 ; LOADER LXI H,BUFF MVI A,'>' CALL OUTCH CALL OUTCH CALL OUTCH D2 CALL INCH MOV B,A LDA ECHO ORA A MOV A,B CNZ OUTCH MOV M,A CPI 7FH ;delete char JZ D3 CPI 0DH ;return JZ DOIT INX H JMP D2 D3 LXI D,-BUFF-1 PUSH H DAD D POP H JNC D2 DCX H JMP D2 DOIT MVI M,0 ;null at command's end LDA BUFF+1 ;ignore period in buff. MOV B,A LDA XR ;the letter r CMP B JZ LOAD MVI A,LCFIX+'x' ; .x is the exit command CMP B JZ TCEXIT LDA XG ;the letter g CMP B RZ ;leaves editor MVI A,'?' ;unrecognized command CALL OUTCH CALL OUTCH CALL OUTCH MVI A,0DH CALL OUTCH JMP LOADER LOAD LXI H,BUFF+3 ;file name LXI D,1 ;read option LXI B,1 ;unit MVI A,1 ;open to read CALL FOPEN JNZ LOADER LHLD PROGEND ;where to load (stored neg) L2 CALL HLNEG LXI B,1 ;unit CALL FREAD ;read one block JNZ L5 ;err or end of file DAD D ;# bytes read in DE MVI M,0 ;just beyond last byte read CALL HLNEG SHLD PROGEND ;points to null byte at end JMP L2 L5 LXI B,1 ;close unit 1 CALL FCLOSE JMP LOADER BUFF DS 40 ; ;Negate HL HLNEG MOV A,H CMA MOV H,A MOV A,L CMA MOV L,A INX H RET ; ;print (DE) as signed integer PN LXI H,BUFF CALL ITOA MVI M,0 ;put null at end LXI H,BUFF JMP PS ;and done ; ;convert (DE) to ascii signed integer ITOA MOV A,D ;test for minus ORA A JP NTOA CALL DENEG ;make positive MVI M,'-' ;output minus INX H ;now fall into NTOA ;convert (DE) to ascii unsigned integer NTOA MOV A,D ORA E ;must be at least one digit, so JNZ NT2 ; test for 0. MVI M,'0' INX H RET NT2 XRA A ;put mark on stack PUSH PSW NT3 LXI B,10 PUSH H CALL DDIV MOV A,L ;remainder -> A POP H ADI '0' PUSH PSW ;ascii digit -> stack MOV A,D ;done if quotient is zero ORA E JNZ NT3 NT4 POP PSW ;top of stack is digit or mark. RZ ;done if mark. MOV M,A ;otherwise digit -> buffer. INX H JMP NT4 ; ;prints the copyright message on the terminal. LOGO LXI H,CPMSG JMP PS CPMSG DB 0CH DB '*' DB '*' DB '*' DB ' ' DB ' ' DB 'T' DB 'I' DB 'N' DB 'Y' DB '-' DB 'C' DB ' ' DB ' ' DB ' ' DB 'V' DB 'E' DB 'R' DB 'S' DB 'I' DB 'O' DB 'N' DB ' ' DB '1' DB '.' DB '0' DB ' ' DB ' ' DB '*' DB '*' DB '*' DB 0DH DB 0AH DB 'C' DB 'O' DB 'P' DB 'Y' DB 'R' DB 'I' DB 'G' DB 'H' DB 'T' DB ' ' DB '1' DB '9' DB '7' DB '7' DB ',' DB ' ' DB 'T' DB ' ' DB 'A' DB ' ' DB 'G' DB 'I' DB 'B' DB 'S' DB 'O' DB 'N' DB 0DH DB 0AH DB 0 ;move the block (DE)...(HL) inclusive (BC) bytes. If ; (BC) is positive, the block is moved up in RAM, ; highest byte first, lowest byte last. If (BC) is ; negative, the block is moved down in RAM, lowest ; byte first. Thus large blocks can be safely moved ; up or down short distances. MOVEBL MOV A,B ORA A JM MOVEDN ORA C RZ MOVEUP SHLD FROMPTR ;hi end of block is fromptr DAD B ;to pointer -> DE XCHG LDA FROMPTR ; - length -> BC CMA ADD L ; - length = MOV C,A ; current HL - fromptr +1 LDA FROMPTR+1 CMA ADC H MOV B,A LHLD FROMPTR MU2 MOV A,M STAX D DCX H DCX D INR C JNZ MU2 INR B JNZ MU2 RET MOVEDN XCHG ;lo end of block is from ptr SHLD FROMPTR DAD B ;to pointer -> HL LDA FROMPTR ; - length -> BC SUB E MOV C,A LDA FROMPTR+1 SBB D MOV B,A DCX B XCHG ;to ptr -> DE LHLD FROMPTR ;from ptr -> HL JMP MOVE FROMPTR DW 0 ; ;scan for the Nth occurance of a character in a block, ; or the end of the block, whichever comes first. The ; block is (DE)..(HL) inclusive. N is (BC) and can be ; 0 to 65k. (A) is the character. On completion, (DE) ; points to the Nth occurance, or to the last byte of ; the block. (BC) is N minus the number of (A) found, ; e.g. 0 if N (A)'s were found. HL is undisturbed. SCANN PUSH PSW ;ch -> stack XCHG ;reverse first and last SC2 MOV A,C ORA B ;test if done JZ SC9 MOV A,E SUB L MOV A,D SBB H JC SC9 POP PSW PUSH PSW CMP M JNZ SC3 DCX B SC3 INX H JMP SC2 SC9 DCX H XCHG POP PSW RET ; ;count the occurances of a character in a block. (A) is ; the character. The block is (DE)..(HL) inclusive. ; The count is returned in (BC). (A) and (DE) are ; unchanged. (HL) is clobbered. COUNTCH LXI B,0 PUSH PSW ;ch -> stack CC2 MOV A,L ;test for end SUB E MOV A,H SBB D JC CC9 POP PSW PUSH PSW CMP M DCX H JNZ CC2 INX B ;count this one JMP CC2 CC9 POP PSW RET ;Machine Call routine to interface to 8080 coded ; routines. Standard routines used by the system ; are coded here, numbers 1 to 11. 12 to 999 are ; reserved. 1000 and up are available to users. MC STA MCARGS ;for checking, CALL TOPTOI ; for MC's that need it. LXI H,-1000 ;test for user MC DAD D JC USERMC MOV A,E ;fctn num -> A CPI 1 JZ MC1 CPI 2 JZ MC2 CPI 3 JZ MC3 CPI 4 JZ MC4 CPI 5 JZ MC5 CPI 6 JZ MC6 CPI 7 JZ MC7 CPI 8 JZ MC8 CPI 9 JZ MC9 CPI 10 JZ MC10 CPI 11 JZ MC11 CPI 12 JZ MC12 CPI 13 JZ MC13 CPI 14 JZ MC14 MCESET CALL ESET DB MCERR RET ; ;put a character to screen MC1 CALL TOPTOI ;char -> A CALL PUSHK ;push it back MOV A,E JMP OUTCH ; ;get a char from keyboard MC2 CALL INCH ;char -> DE MOV B,A ;test for ESC in appl level LDA APPLVL ORA A JZ USEIT LDA ESCAPE CMP B JNZ USEIT CALL ESET DB KILL USEIT LDA ECHO ;test if echo required ORA A MOV A,B CNZ OUTCH MOV E,A XRA A MOV D,A JMP PUSHK ;put char onto stack ; ;file open (r/w, name, fsize, unit) MC3 CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI ;r/w -> A MOV A,E ORA D POP H ;name pointer -> HL POP D ;file size -> DE POP B ;unit -> BC CALL FOPEN LXI D,0 MOV E,A ;push result code JMP PUSHK ; ; read block( where, unit) MC4 CALL TOPTOI PUSH D CALL TOPTOI XCHG ;where -> HL POP B ;unit -> BC CALL FREAD JZ MC4P ;if result code is 0 DE has LXI D,-1 ; byte count to be pushed. MOV E,A ; Otherwise A is an err or eof MC4P JMP PUSHK ; code to be returned negative ; ;write block ( first byte, last byte, unit). Block may ; be any size from 1 to 256. MC5 CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI XCHG ;first -> HL POP D ;last -> DE POP B ;unit -> BC CALL FWRITE LXI D,0 ;push result code MOV E,A JMP PUSHK ; ;close file ( unit ) MC6 CALL TOPTOI MOV C,E ;unit -> BC MOV B,D CALL FCLOSE JMP PZERO ;return a 0 ; ;move a block up or down. Args are first,last,K. If K ; negative, block is moved down |k| bytes, if positive ; then up K bytes. MC7 CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI ;first -> DE POP H ;last POP B ;K CALL MOVEBL JMP PZERO ;return a 0 ; ;count # instances of character CH in a block. Args are ; first,last,CH. MC8 CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI ;first -> DE POP H ;last POP B ;ch -> A MOV A,C CALL COUNTCH MOV E,C ;count -> DE MOV D,B JMP PUSHK ; ;scan for nth occurance of CH in a block. Args are ; first,last,CH,cnt address. Return pointer to nth ; occurance,if it exists, otherwise to last. Also ; cnt is reduced by one for every CH found. MC9 CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI PUSH D CALL TOPTOI ;first -> DE POP H ;last POP B ;ch -> A MOV A,C XTHL MOV C,M ;cnt -> BC INX H MOV B,M DCX H XTHL ;addr of cnt still on stack PUSH D ;first on stack, too CALL SCANN POP H ;make ptr (DE) relative to MOV A,E ; first SUB L MOV E,A MOV A,D SBB H MOV D,A POP H ;BC -> cnt MOV M,C INX H MOV M,B JMP PUSHK ;return pointer to last byte ; ; examined. ; ;trap to moniter 4.0 for debugging. MC10 DB 0FFH ;RST 7 RET ; ;enters an application program, setting up a new ; globals variable level, redefining progend, links ; the program, executes if no error occured, upon ; completion captures a few facts (err, and either ; cursor or errat) and restores old globals level, ; progend, zeros err, pushes a zero as the value of ; this function, and resumes the calling program. MC11 LHLD CURSOR PUSH H LHLD PROGEND PUSH H LHLD PRUSED PUSH H LHLD CURGLBL PUSH H CALL TOPTOI ;appl pr address XCHG PUSH H SHLD CURSOR CALL TOPTOI ;end of appl addr XCHG SHLD PRUSED CALL HLNEG SHLD PROGEND CALL LINK LHLD CURFUN SHLD CURGLBL CALL TOPTOI ;start statement address XCHG SHLD CURSOR CALL NEWFUN CALL TOPTOI ;facts address PUSH D LXI H,APPLVL ;increment appl level INR M PUSH H LDA ERR ;if no err so far, do it!! ORA A JNZ DONE CALL PRBEGIN CALL ST CALL PRDONE DONE POP H ;its done, decrement appl level DCR M CALL FUNDONE ;discard appl locals CALL FUNDONE ; and globals LHLD CURSOR ;set up facts LDA ERR ORA A JZ MCEN2 LHLD ERRAT MCEN2 XCHG ;returned currsor -> DE POP H ;facts -> HL POP B ;appl pr address -> BC MOV A,E ;make returned cursor relative SUB C ; to appl address MOV E,A MOV A,D SBB B MOV D,A LDA ERR MOV M,A ;err -> facts XRA A INX H MOV M,A ;err hi byte -> facts INX H MOV M,E ;cursor -> facts INX H MOV M,D POP H ;curglobal SHLD CURGLBL POP H SHLD PRUSED POP H ;progend SHLD PROGEND POP H ;cursor SHLD CURSOR XRA A ;zero the error STA ERR JMP PZERO ;value of MC11 ; ;test if keyboard char ready, return copy if so,else 0. MC12 CALL CHRDY MVI D,0 MOV E,A JMP PUSHK ; ;print RAM, from and to addresses are given ; nulls are mapped to quotes MC13 CALL TOPTOI PUSH D CALL TOPTOI XCHG ;from -> HL POP D ;to -> DE LOOP13 MOV A,E ;test if done SUB L MOV A,D SBB H JC PZERO ;done MOV A,M CPI 0AH JZ EC13A ;line feed handled by OUTCH detecting preceding 0DH ORA A JNZ EC13 MVI A,'"' EC13 CALL OUTCH EC13A INX H JMP LOOP13 ; ;print a signed integer MC14 CALL TOPTOI PUSH D CALL PN POP D JMP PUSHK ; ;end of the standard interpreter TCEND EQU $ BFREE EQU (TCEND+0FFH)/100H*100H ;next free page SPACE EQU EFREE-BFREE ß.xî{OPY{=+!"~G%_%%P%)H%H)%#~:ª+~A >%!"w%!"w##%ů~#.!%TC ~ . *,a{#> #>?#H> .!"~A.>:.!i>..! i> .! ~H> .!~H> .! ~H> .!!~H> .!#~H> .%T̈́_s:ʸ2: > .> xʸß:] *F*B!K*B "`!~#o6#>ͮ*`{6"`¾SP.* |} }b}ʒ+..K_}1P1..̈́1.2E# ¡ # ¬# ·@ʴʥzʖ=ʐ=|zJz?4)z zuÛÞ  ?ÃN.6ifelseintcharwhilereturnbreakendlibraryrg[](), /*;%/+-<>!===>=<= ̓ͩxLs #ry/Ox/G͠{_zWzy_xWz!y( ɯxGyOɯ{_zWzztx>́)[|[}o=dEtt1z/W{/_{z)ͩ2xAʓ^#V :{W̓̓*N~#F#N#^#V "NA*N"N*8w#p#q#s#r:H#~#2H*\"J}|p+ ~ #*\> ,#$"\=#/"\/*\> P#H"\~jkk#"\7?#*`V70:A[a{/ɯC"V~ͅ#~}"\+"XɯC~+-0:"V#~0:"\+"X>" #"V~ " #*`> w+"X>##"\'< #"V~'4 #*`! > >#"\ɯY ~ C #"\C  TL !0ڈ ҈ DM)) )O o 2 ~ ™ #Ï -¢ 2 #+¨ #~ ² #è k : t*R"R*< :PwO:Q#w#q#w:^#w:_#w*R~2P#~2Q###~2^#~2_"R2 x2 " " *Px #: w#: w#: w#: w#" : W * }“ *^#" * s#r* *^: =u "^*D҆ * *^ â * : w#: wø : ¸ * |ʸ * s#r*R##:Pw#:Qw*P"P*@* ¥ ` *R" ! x 2 * ^#V#N#F" `i" * : : R  E #$ ~#F#^#V#> E^#V* "  : f *T" <2 q *:\ "v >Hp=ʉ #À *V:X< >OG*v wʪ #ß ᯱ*X~w  Ͷ :H:H =_  _ ʿڿ _ ʿҿ _ ʿ4 _ ¿L _ ÿ_ ڿ{ ͷ ̓{/_z/WÄ ͷ :Hʡ ͷ ͠Ä ͷ ͠Ä  :H  ͠ú C   ͠oú  ͠1ú  Ͷ ͹R 4 *V͋ F >A*VA*V^͚0*V#:X} :Y} ~C} +~M} !Ý "52 x2 " z+: E%: =2 *5^#V* * Ͷ " " "5̓"7* }=:  DM*7*5: = "5: O: L*5*5Ý C O[]TC cat}()T9f9C *\~ ʙ;ʘ#*`ҀC #"\C 2"͚2*V*X:<Ͷ 2"X"V:H̓"!":C:** ́:HC %*\"ZBC VC :HG:LG:MC 9cʑͶ ̓zʄf99ftͶ ̓z*Z*\">"@:M*>"\92M*@"\9C zͶ >2L'>2MͶ 9̓C of>C!ͥK>k>I!ͥm\:bG:5 c"2*N"*\~]; /:H***Ͷ }""<2:H*|:*\*Z*"\ͽ C k[*I*"7+oʈ*C*"d+*N:ʡ"\!5ͩá:H:L2L"Z"\ F#~#N#^#VA^#Vy={Wxåͽ :H*\##*`C []TB.ͽ ͚c>E*\ *\>[Z#*`G"\9~# hh*F|~*B!%h*B "`1/1*`"^*B"\*:"T"R*>"P*6"Ngo2H"J2L2Mͽ *B"\"(!:H*H> *J> Û DONE [main();]!>>    G: x wX e#=:=+=6:G:ʐ>x:>?   > /!>/*`¼6"`ä/|/g}/o#!6!zt6-#z60#ɯ o}0zw#*!7 *** TINY-C VERSION 1.0 *** COPYRIGHT 1977, T A GIBSON x" :/O:/G*~+ " :O:G *hy{z #ø+}|+24̓!{DNrʐʦʾ    ʯ ʸ̓{  G:bd:5dc: x _W̓̓̓̓{_̓̓ʣ_̓̓̓_̓KB̓̓̓u̓̓̓yYP̓̓̓̓yN#F+Ͷ{_zWq#p*\*`*^*T̓"\̓"^"`*R"T̓"\ͽ ̓!b4:Ho"(5 *\:Hʄ*J{_zW:Hw#w#s#r"T"^"`"\2H_̓̓{z~ >" #̓! ( 2/?'  v:P@< !  PP27 ( *"  NZZ NCC POPEP M x_BH!œ#¶ ¦{KÈCÈ<:JCR:  !6 s! this holdsa new 16th record! up to 16 64 bytes records ...was able to save and then restore 3 records ... seems we can even save / restore 6ok, now we have 6 make that 8nine teneleventwelvethirteenfourteennestxt to last ...zee berry berry last ... for now ...tree16.tr# /* * * * * * * * * * * * * * * * * * * * * * /* BINARY TREE DEMO /* /* tree.tc - Copyright (c) 2/23/1979 /* Les Hancock /* /* { Ref: Knuth 2.3.1, 6.2.2 } /* /* implemented 10/24,25/2007 - Lee Bradley /* * * * * * * * * * * * * * * * * * * * * * int mxp, mxc, n, root int lf, rt, text, nu int base(1), av(16 - 1) char tr((16 * 64) - 1) co char st1(0), st2(0) int n [ int ctr while (n - ctr) [ if (st1(ctr) < st2(ctr)) return -1 if (st1(ctr) > st2(ctr)) return +1 ctr = ctr + 1 ] return nu ] delete [ int ptr(0), k, pp(0), pr(0), res, np, cl char st(mxc - 3) pl "-> Del <-" while (n) [ pl "" k = getst(st) if (k == nu) return res = sniff(st, ptr, k, pp, pr) if (res) pl "Not found." else [ np = rub (ptr(0)) cl = mxc + 1 while (cl = cl - 1) [ tr(sb(ptr(0), cl)) = nu ] if (pp(0)) [ tr(sb(pp(0), ((pr(0) + 3) / 2))) = np ] else root = np push ptr(0) pl "Record" pn ptr(0) ps " deleted." ] ] pl "";pl "Empty";pl "" init ] menu [ char ch init pl "" pl "DEMO: BINARY TREE" pl "" while ((ch = getch()) != 'x') [ if (ch == 'i') insert else if (ch == 'd') delete else if (ch == 's') search else if (ch == 'l') list else if (ch == 'w') write else if (ch == 'r') read else if (ch == 'h') help ] ] format int nm [ int spaces pn nm if (nm < 10) spaces = 8 else if (nm < 100) spaces = 7 else if (nm < 1000) spaces = 6 while (spaces = spaces - 1) ps " " ] getch [ pl "Routine (h for help) : " return getchar ] getname char fname(13) [ int k k = gs(fname) if (k > 14) [ pl "Name too long." return 1 ] return nu ] getst char st(0) [ int k pl "" ps "Enter string: " k = gs(st) while (k > (mxc - 2)) [ pl "String exceeds max length of " pn mxc - 2 ps " re-enter." pl "" k = gs(st) ] return k ] help [ char yn pl "" pl "e(x)it (i)nsert (d)elete (s)earch (l)ist (w)rite (r)ead (h)elp" pl "Want more help? " if ((yn=getchar())=='y') printmenu ] init [ nu = 0 root = 1 lf = 1 rt = 2 text = 3 mxp = 16 mxc = 64 av = base + (2 * 2) tr = base + (2 * 2) + (2 * mxp) n = mxp + 1 while (n = n - 1) av(n - 1) = n ] insert [ int k, ptr(0), res, dummy(0), np char st(mxc - 3) pl "-> Insertion <-" while (n < mxp) [ pl "" k = getst(st) if (k == nu) return res = sniff(st, ptr, k, dummy, dummy) if (res == nu) pl "Record exists." else [ np = pop if (np != root) [ tr(sb(ptr(0), ((res + 3) / 2))) = np ] move (st, tr + sb(np,text)) pl "Key =" pn np ] ] pl "" pl "Table full." pl "" ] list [ int index(0), ptr(0), stack(mxp - 1) pl "" if (n) [ pl "Key Text" pl "" index(0) = -1 ptr(0) = root traverse(index, ptr, stack) pl "" ] else [ pl "Nothing to list." pl "" ] ] pop [ int nextptr nextptr = av(n) n = n + 1 return nextptr ] push int oldptr [ n = n - 1 av(n) = oldptr return n ] read [ pl "" pl "-> Read <-" pl "" char fname(13) pl "Input file: " if (getname(fname)) return readfile(fname, base, tr + sb(mxp, mxc), 1) n = base(0) root = base(1) ] rub int ptr [ int r, s, t t = ptr if (tr(sb(t, rt)) == nu) return tr(sb(t, lf)) if (tr(sb(t, lf)) == nu) return tr(sb(t, rt)) r = tr(sb(t, rt)) if (tr(sb(r, lf)) == nu) [ tr(sb(r, lf)) = tr(sb(t, lf)) return r ] s = tr(sb(r, lf)) while (tr(sb(s, lf))) [ r = s s = tr(sb(r, lf)) ] tr(sb(s, lf)) = tr(sb(t, lf)) tr(sb(r, lf)) = tr(sb(s, rt)) tr(sb(s, rt)) = tr(sb(t, rt)) return s ] search [ int res, k, ptr(0), dummy(0) char st(mxc - 3) pl "-> Search <-" while (1) [ pl "" k = getst(st) if (k == nu) return res = sniff(st, ptr, k, dummy, dummy) if (res) pl "Not found." else [ pl "Found at " pn ptr(0) ps " : " ps tr + sb(ptr(0), text) ] ] ] sniff char st(0) int ptr(0), k, pp(0), pr(0) [ int temp, res pp(0) = nu pr(0) = nu ptr(0) = root while (1) [ res = co(st, (tr + sb(ptr(0), text)), k) if (res == nu) return res temp = tr(sb(ptr(0), ((res + 3) /2))) if (temp == nu) return res pp(0) = ptr(0) pr(0) = res ptr(0) = temp ] ] sb int row, col [ return (col - 1) + (mxc * (row - 1)) ] traverse int index(0), ptr(0), stack(mxp - 1) [ index(0) = index(0) + 1 stack(index(0)) = ptr(0) if (tr(sb(ptr(0), lf))) [ ptr(0) = tr(sb(ptr(0),lf)) traverse(index, ptr, stack) ] pl "" format(ptr(0)) ps tr + sb(ptr(0), text) if (tr(sb (ptr(0), rt))) [ ptr(0) = tr(sb(ptr(0), rt)) traverse(index, ptr, stack) ] if (index(0) == 0) return index(0) = index(0) - 1 ptr(0) = stack(index(0)) ] write [ char fname(13) pl "-> Write <-" pl "" pl "Output file: " if (getname(fname)) return base(0) = n base(1) = root writefile (fname, base, tr + sb(mxp, mxc), 1) ] printmenu [ pl "" pl "Routines i, d, and s" pl "prompt for strings," pl "which mustn't exceed" pn mxc - 2 ps " characters." pl "" pl "Routine i inserts new" pl "strings into the tree," pl "refusing any that are" pl "already there." pl "" pl "Routine d deletes records" pl "which begin with" pl "the string entered." pl "" pl "Routine s searches the tree for a match to" pl "the text you enter." pl "" pl "To quit any of those routines, do a carriage" pl "return without entering any text." pl "" pl "At present the tree's contents cannot exceed" pn mxp pl "records." pl "" ]  /* pf.tc - 10/26-29/2007 - implemented lrb char shore(9),health(9),canoe,move(4),ngoing,afloat int hfactor(6),sinkrate,paddle(9) /* Conducts the game. pf [ setup while(stillplaying()) [ whosgoing trip shoreacts ] wrapup ] /* Sets up initial conditions. setup [ hfactor(0)=10 hfactor(1)=9 hfactor(2)=hfactor(3)=8 hfactor(4)=7 paddle(1)=paddle(2)=12 paddle(3)=paddle(4)=9 paddle(5)=7 paddle(6)=5 paddle(7)=paddle(8)=paddle(9)=4 sinkrate=25 ps"seed? " seed=last=gn ] /* Game is still going if any player on shore is alive. stillplaying [ int p while((p=p+1)<=9) if((shore(p)==0)*(health(p)<5)) return 1 ] /* Conducts dialog, determining which players make next trip. whosgoing [ char j,p,i char dup pl"";pl"move " while(1) [ j=getchar if(j=='.') [ /* Trip command. i=0 /* At least one paddler required. while((i=i+1)<=ngoing) if(health(move(i))<5)return ps" nobody to paddle " ] else if(j=='-') [ /* Unload command. ngoing=0 ps" canoe emptied"; pl"" ] else if(j=='s') [ /* Print board. status ps"move " ] else if((j>='1')*(j<='9')) [ /* Put player in canoe. p=j-'0' dup=0 i=0 while((i=i+1)<=ngoing) if(p==move(i)) dup=1 if(dup) ps" already in boat " else if(shore(p)!=canoe) ps" on other shore " else if(ngoing>=4) ps" canoe full " else move(ngoing=ngoing+1)=p ] ] ] /* status prints the board. status [ char k(0),p pl"";pl"" ps "near shore far shore" pl"";pl"" while((p=p+1)<=9) [ if(shore(p)) ps " " pn p;ps " ";pname p;ps" " if(health(p)) [ k="minor att major att minor unattmajor unattdead " k=k+11*(health(p)-1) pft k,k+10 ] pl"" ] if(canoe)ps " " ps " canoe" pl" " if(canoe)ps " " char i while((i=i+1)<=ngoing)pn move(i) pl"" ] /* Conducts a trip across the river. trip [ char i int speed,dist,full afloat=1 while((i=i+1)<=ngoing) speed=speed+paddle(move(i))*hfactor(health(move(i))) speed=speed/(4*ngoing) /* Yards per unit of time. while((dist=dist+speed)<100) [ full=full+sinkrate if(afloat*(full>100)) [ pl"The boat is swamped ..." capsize break ] if(afloat) [ pl"Canoe has";pn 100-dist;ps" yards to go, and is" pn full;ps"% full" if(random(1,4)==1)onefish ] ] i=0 /* The far shore is reached. while((i=i+1)<=ngoing) shore(move(i))=1-shore(move(i)) canoe=1-canoe /* Swap shores of players in canoe, and canoe. ngoing=0 /* Everybody out. pl"trip to " if(canoe)ps"far";else ps"near" ps" shore is complete." ] /* A fish jumped in the boat. This is what happens. onefish [ char p pl"A piranha fish has jumped into the boat. He is swimming" pl"around. He is looking at the toe of the " pname(p=move(random(1,ngoing))) ps"." if(health(p)>4) pl"Oh, well. He's dead anyway ..." else if(p>6) [ pl"The missionary is calm. He is staring back at the" pl"fish. The fish just jumped back into the river." ] else if(p<3) [ pl"The cannibal has speared the fish." if(random(0,1)) [ pl"Unfortunately he made a hole in the" pl"boat, increasing its sink rate 10%." sinkrate=sinkrate+sinkrate/10 ] ] else if(p<5) [ pl"The hunter has panicked. He is rocking tbe boat ..." capsize ] else if(p==5) [ if(random(0,1)) [ pl"The doctor is quick. He shoots the fish full of" pl"a drug." ] else [ pl"The doctor has panicked. He is rocking the boooooat!" capsize ] ] else [ pl"The nurse has panicked. She is rocking the boat." pl"Everybody is yelling at her. Yell - yell - yell." if(random(0,1)) pl"She is calm now, and sits down." else [ pl"She falls out of the boat. She is swimming." swim 6 ] ] ] /* Player p swims to shore. swim char p [ if(health(p)>4) [ pl"Player";pn p;ps" floats ashore." ] else if(random(0,1)) [ pl"Player";pn p;ps" makes it." ] else [ pl"BYTE!! BYTE!! Player";pn p if(random(0,2)) [ if(health(p)==2) health(p)=4 else if(health(p)<2) health(p)=3 ] else if(health(p)<4) health(p)=4 if(health(p)==3) ps" fortunately escapes with minor wounds." else ps " major wounds acquired." ] ] /* The canoe is capsized. capsize [ char p pl"CAPSIZE!! Everybody swim FAST!! The fish are coming .." while((p=p+1)<=ngoing) swim move(p) afloat=0 ] /* When on shore, some players get mended. shoreacts [ char p while((p=p+1)<=9) [ if(shore(p)==shore(5)) [ /* Doctor with at most minor wounds can attend all if(health(5)<4) if(health(5)!=2) /* wounds. if((health(p)==3)+(health(p)==4)) [ health(p)=health(p)-2 pl"";pn p;ps " attended by doctor." ] ] if(shore(p)==shore(6)) [ if(health(6)<4) if(health(6)!=2) if(health(p)==3) [ health(p)=1 pl"";pn p;ps" attended by nurse." ] else if(health(p)==4) /* And also major wounds w/ the doctor's advice. if(shore(5)==shore(6)) if(health(5)<5) [ health(p)=2 pl"";pn p;ps" attended by nurse" ] ] if(health(p)==0) [] /* All done if healthy. else if(random(0,2)) [] /* All done for .67 of sick. else if(health(p)<3) [ /* But some get sicker. if(random(0,2)==0) [ if((health(p)=health(p)+1)==3) health(p)=5 pl"";pn p;ps" is much worse" if(health(p)==5) ps", in fact dead." ] ] else if(health(p)<5) [ health(p)=health(p)+1 pl"";pn p;ps" is much worse" if(health(p)==5) ps", in fact dead." ] ] ] /* Computes score. wrapup [ int s,h,p s=1000 /* Perfect score. while((p=p+1)<=9) [ h=health(p) if(h==5) s=s-100 if(h==4) s=s-30 if(h==3) s=s-15 if(h==2) s=s-10 if(h==1) s=s-5 ] pl"";pl"" status ps"Your score is";pn s ] /* Prints the player's name pname char p [ if(p<3) ps "cannibal" else if(p<5) ps "hunter" else if(p<6) ps "doctor" else if(p<7) ps "nurse" else ps "missionary" ] /* random number generator int last, seed random int low, high [ int range if(last==0) last=seed=99 range=high-low+1 if (last>=16384) last=last-1 /* to get around tc arithmetic bug last=last*seed if(last<0) last= 0-last return low + (last/7) % range ]  /* bot99.tc - lrb - Halloween 2007 /* translated from the Mouse program 99bot.mse /* currently can only do at most 10 verses due to stack restrictions /* 11/2/2007 int d /* global delay variable bot99 [ int s pl"Enter delay value [1,200] " d=gn pl"" while(s=howmany) if((11-s>0)*(s>0)) verse(s) ] howmany [ int s pl"How many verses? (10 max 0 to quit) " s=gn pl"" return s ] verse int s [ /* play a verse if(s) [ numleft(s);bot(s);wall;ps",";pl"" numleft(s);bot(s);ps".";pl"" fall;pl"" numleft(s-1);bot(s-1);wall;ps".";pl"";pl"" delay verse(s-1) /* recursive call ] ] bot int s [ ps" piece";if(s!=1) ps"s";ps" of pumpkin pie" ] wall [ps" on the shelf"] fall [ ps"If one of those pieces of pumpkin pie should happen to fall ..." ] numleft int s [ /* print pieces count in English int u,w,v u=s;w=0 if(s>9) [ /* we have 10 (or more) bottles w=s/10 /* holds tens digit v=s%10 /* holds ones digit if(w==1) [ /* number is between 10 and 19 if(v==0) [ ps"Ten" return ] if(v==1) [ ps"Eleven" return ] if(v==2) [ ps"Twelve" return ] if(v==3) [ ps"Thirteen" return ] if(v==4) [ ps"Fourteen" return ] if(v==5) [ ps"Fifteen" return ] if(v==6) [ ps"Sixteen" return ] if(v==7) [ ps"Seventeen" return ] if(v==8) [ ps"Eighteen" return ] if(v==9) [ ps"Nineteen" return ] ] if(w==9) ps"Nine" if(w==8) ps"Eigh" if(w==7) ps"Seven" if(w==6) ps"Six" if(w==5) ps"Fif" if(w==4) ps"For" if(w==3) ps"Thir" if(w==2) ps"Twen" ps"ty" if(v==0) return ps"-";u=v /* prepare for second part of number ] if(u==9) [ /* w is 0,2,3 ... 9 if you get here if(w) ps"n" /* 29 prints as Twenty-nine but else ps"N" /* 9 prints as Nine ps"ine" return ] if(u==8) [ if(w) ps"e" else ps"E" ps"ight" return ] if(u==7) [ if(w) ps"s" else ps"S" ps"even" return ] if(u==6) [ if(w) ps"s" else ps"S" ps"ix" return ] if(u==5) [ if(w) ps"f" else ps"F" ps"ive" return ] if(u==4) [ if(w) ps"f" else ps"F" ps"our" return ] if(u==3) [ if(w) ps"t" else ps"T" ps"hree" return ] if(u==2) [ if(w) ps"t" else ps"T" ps"wo" return ] if(u==1) [ if(w) ps"o" else ps"O" ps"ne" return ] if(u==0) [ ps"No" return ] ] /* pause a while ... uses global variable d delay [ int w,v w=d while(w) [ v=d while(v) v=v-1 w=w-1 ] ]  /* pieces.tc - lrb - Halloween 2007 /* based on a "99 bottles of beer on the wall" program in Mouse (99bot.mse) /* made "sequential recursive" - November 1 int d /* global delay variable /* main program pieces [ int s pl"Enter a delay value [1,200] " d=gn pl"Enter a number [1,99] " s=gn;s=s+9 pl"" while(((s=s-9)>0)*(s<100)) [ if (s>9) verse(s,9) else verse(s,s) ] ] /* display a verse /* t becomes a displayed count /* u is never greater than some maximum recursive depth (here it's 9) verse int t,u [ if(u) [ number(t);piece(t);shelf;ps",";pl"" number(t);piece(t);ps".";pl"" fall;pl"" number(t-1);piece(t-1);shelf;ps".";pl"";pl"" delay verse(t-1,u-1) /* recursive call ] ] piece int s [ ps" piece";if(s!=1) ps"s";ps" of pumpkin pie" ] shelf [ps" on the shelf"] fall [ ps"If one of those pieces of pumpkin pie should happen to fall ..." ] /* print count in English number int s [ int u,w,v u=s;w=0 if(s>9) [ /* we have 10 (or more) w=s/10 /* holds tens digit v=s%10 /* holds ones digit if(w==1) [ /* number is between 10 and 19 if(v==0) [ ps"Ten" return ] if(v==1) [ ps"Eleven" return ] if(v==2) [ ps"Twelve" return ] if(v==3) [ ps"Thirteen" return ] if(v==4) [ ps"Fourteen" return ] if(v==5) [ ps"Fifteen" return ] if(v==6) [ ps"Sixteen" return ] if(v==7) [ ps"Seventeen" return ] if(v==8) [ ps"Eighteen" return ] if(v==9) [ ps"Nineteen" return ] ] if(w==9) ps"Nine" if(w==8) ps"Eigh" if(w==7) ps"Seven" if(w==6) ps"Six" if(w==5) ps"Fif" if(w==4) ps"For" if(w==3) ps"Thir" if(w==2) ps"Twen" ps"ty" if(v==0) return ps"-";u=v /* prepare for second part of number ] if(u==9) [ /* w is 0,2,3 ... 9 if you get here if(w) ps"n" /* 29 prints as Twenty-nine but else ps"N" /* 9 prints as Nine ps"ine" return ] if(u==8) [ if(w) ps"e" else ps"E" ps"ight" return ] if(u==7) [ if(w) ps"s" else ps"S" ps"even" return ] if(u==6) [ if(w) ps"s" else ps"S" ps"ix" return ] if(u==5) [ if(w) ps"f" else ps"F" ps"ive" return ] if(u==4) [ if(w) ps"f" else ps"F" ps"our" return ] if(u==3) [ if(w) ps"t" else ps"T" ps"hree" return ] if(u==2) [ if(w) ps"t" else ps"T" ps"wo" return ] if(u==1) [ if(w) ps"o" else ps"O" ps"ne" return ] if(u==0) [ ps"No" return ] ] /* pause a while ... uses global variable d delay [ int w,v w=d while(w) [ v=d while(v) v=v-1 w=w-1 ] ]