d .title KERNEL for SAO VAX/VMS STOIC ; ***************************************************************** ,; * * ; * This is a module of SAO VAX/VMS STOIC * ; * * X; * It was created by * ; * Roger Hauck * ; * Smithsonian Institution * ; * Astrophysical Observatory * ; * Cambridge, Massachusetts 02138 * L; * (617)495-7151 (FTS 830-7151) * ; * * ; * Modifications by Jonathan Mark * x; * 1981-1982 * ; * * @; * This module may be reproduced * ; * provided that this title page is retained. * ; * * l; ***************************************************************** dROGER=1 .enabl dbg,tbk , .dsabl gbl  .extrn lib$signal,lib$stop,lib$sig_to_ret,ss$_resignal  .extrn sssize,ssbyte,tyiosize X .extrn rmsdata,ssdata,tyiodata,tyiodata  .extrn fablen,rablen,xablen  .extrn proto_fab,proto_rab,proto_xab,channel_prot  .extrn ttname0,ttchan0,_name  .extrn console,consize L $rabdef  $fabdef  $rmsdef x ; Symbols for export to UTINIT module @  .extrn ttio_ttio,ttioglob,ss_kernel ;points to other vocabularies  .extrn crtl_crtl l .extrn dict_start,k_start ;beginning of dictionary  .extrn k_end,dict_end,dat_fin 4 .extrn string_to_float ;floating point conversion routine  .mcall $rab  ` .global syserr ;make error checker available ( .extrn dat_start .macro jsbext parm T .extrn parm jsb parm  .endm H .macro newpage title .page  .sbttl title t .endm  <;random conventions ;true is represented by any odd word ;and false by any even word, h;so blbs is branch true  0; global register assigments ; r11 - users table pointer ; r10 - paramater stack pointer \; r9 - loop stack pointer ; r8 - dictionary pointer $; r7 - floating point stack pointer   P .psect kernel  ; assembly parameters |p_stack_size=2 ;number of pages in p-stack l_stack_size=1 ;number of pages in loop stack Dv_stack_size=1 ;number of pages in vocab stack fp_stack_size=1 pmtlen=6 ;length of prompt pline_buf_size=132. comp_buf_length=^x400 8  newpage  .macro .errstop ?p1 d blbs r0,p1  pushl r0 , calls #1,g^lib$stop p1:  .endm X ;----..if  .macro ..if  blbc (r10)+,. ;branch on .FALSE.  .=.-1 ;pointer to target L .save .=.+1  .endm x ;----notif: i.e. NOT IF @ .macro ..notif  blbs (r10)+,. ;branch on .TRUE.  .=.-1 l .save .=.+1 4! .endm ! !;----..else `" .macro ..else ?p1 " brb . ;displacement to be supplied (#p1=. # .restore # .byte p1-.-1 ;insert previous diplacement T$.=p1-1 $ .save %.=.+1 % .endm % H&;----then: THEN & .macro ..then ?p1 'p1=. t' .restore ' .byte p1-.-1 <(.=p1 ( .endm ) h);----begin: BEGIN ) .macro ..begin 0* .save * .endm * \+;----end: logical value, END +; transfers to matched BEGIN if value is .FALSE. $, .macro ..end , blbs -(r10),. ,p1: P- .restore -p2=.-p1-1 ..=p1-1 |. .byte p2 . .endm D/ /;----succeed: SUCCEED 0; pushes .TRUE. onto the parameter stack p0 .macro ..succeed 0 movl #1,-(r10) 81 .endm 1 2;----fail: FAIL, 0 d2; pushes .FALSE. onto parameter stack 2 .macro ..fail ,3 clrl -(r10) 3 .endm 3 X4 newpage 4 5.macro string strng 5loc=. 5 .blkw 1 L6 .ascii strng 6len=.-loc-2 7.=loc x7 .word len 7 .blkb len @8.endm 8 9 l9;----HEADER: (this macro makes a STOIC word header and links it) 9;stores link,name,lookup atribute 4: .macro header macname, name=<>,lookup_atr=jump_to_me,- : branch=kernel : kplace=. ;remember current location `; .save ; .psect dictionary ;go to dictionary psect (< .long branch-dict_start-^x8000 ;link onto last word of branch < branch=.-4 ;set branch to point to here < .long globlink-dict_start-^x8000 ;link onto global pointer T= globlink=.-4 ;and set it = .nchr nchr,^!name! >.if le,nchr > .ascic /macname/ >.endc H?.if gt,nchr ? .ascic /name/ ;store the name and count @.endc t@ .byte lookup_atr @ .blkw 1 ;space for the code length word TV .word length V .nchr len,^"str" Wsname: .word len W .ascii "str" W. = sname HX .blkw 1 X .blkb length Y.endm tY Y;macro to assemble code to initialize a user table location with (r11),w^dest(r11) ;do move \ .restore ;return to where we were \.endm \] ];macro to give one block in the data area the address of another $^ ^.macro addr_to_addr addr,dest ^ .save P_ .psect setup _ moval l^(r11),l^(r11) ` .restore |`.endm ` Da; Macros A_TO_UT and A_TO_A obsolete previous two; they do the same a; thing but compile the code at the current place in the PSECT b pb.macro a_to_ut addr,dest b moval l^(r11),w^dest(r11) 8c.endm c d.macro a_to_a addr,dest dd moval l^(r11),l^(r11) d.endm ,e e newpage e .psect kernel Xf f .entry start,^m g g; Allocate stacks and buffers, leave pointers on control stack g Lh movl #p_stack_size,r0 ;get space for p-stack h jsb isolate_block ;assign it i pushl r2 ;remember where it starts xi movl #l_stack_size,r0 ;same for l-stack i jsb isolate_block @j pushl r2 j movl #fp_stack_size,r0 k jsb isolate_block lk pushl r2 k movl #v_stack_size,r0 ;same for v-stack 4l jsb isolate_block l pushl r2 l movl #2,r0 ;make space for compile buffer `m jsb isolate_block m pushl r1 ;push beginning this time (n n; Make space for FABS and RABS. n To movl #<<<<8*fablen>+<8*rablen>+<2*xablen>-1>/^x200>+1>,r0 o jsb isolate_block ;create the space; get address in r1 p p; Set register 11 to be the base register for the data region. p Hq addl3 #<+^x8000+^x200>,r2,r11 q ;set up r11 to be 8000 past end r ;of non-user data (add 200 to tr ;allow for the moat) r; Initialize FABS/RABS. ,proto_rab,(r3) ;move the initial values 0u addl3 #rab$l_fab,(sp),r0 ;get address of FAB field in RAB u addl3 #rablen,(sp),(r0) ;store FAB address there u decl r6 ;decrement the loop counter \v cmpl #2,r6 ;is the counter less than 2? v bleq 10$ ;if greater than 1, go do the next one $w pushl r3 ;save the current address temporarily w movc3 #xablen,proto_xab,(r3) ;move one XAB w movl (sp)+,r0 ;pop the XAB address into r0 Px addl3 #,(sp),r1 ;get the XAB field address x movl r0,(r1) ;install it y tstl r6 ;look at the loop counter |y bgeq 10$ ;if non-negative, continue y Dz; Make space for the data region. z { clrl r0 p{ subw3 #1,dat_start,r0 ;get number of bytes, less 1 { divl2 #^x200,r0 ;compute number of pages 8| incl r0 ;add 1 | jsb isolate_block } pushl r2 ;store the next unavailable address d} pushl r1 ;remember address of data } ,~; Move the initial data values into the data region. ~ ~ movc3 dat_start,dat_start,(r1) ;load the initial data values X pushl r3 ;beginning of normal data region  ; Initialize by doing a JSB to the code prepared by the macros ; A_TO_A and A_TO_UT. L jsb data_init ; Move data pointers to user table. x ܂ movl (sp)+,.d(r11) ;data pointer @ movl (sp)+,user_data(r11) ;data start movl (sp)+,.m(r11) ;memory pointer  l; Connect RABs to the channel list. Є 4 cvtbl #7,r6 ;set up a loop index 20$: movl (sp)+,@channel_list(r11)[r6] ;move the RAB address decl r6 ;advance the pointer ` bgeq 20$ ;if non-negative, loop back Ć jsb setup_fabs ;specialize the FABS ( ; Install the buffer and stack pointers. T movl (sp)+,comp_buf_0(r11) ;compile buffer movl (sp)+,v_stack_0(r11) ;initial v_stack  movl (sp)+,f_stack_0(r11) movl (sp)+,l_stack_0(r11) ;l-stack movl (sp)+,p_stack_0(r11) ;p-stack H ; Save stack pointer, data address; reset registers.  t movl sp,r_stack_0(r11) ;save so abort can restore ؋ movl fp,frame_0(r11) ;save frame pointer < jsb reset_registers ;setup registers ; Initialize the vocabulary stack with the kernel vocabulary. h ̍ movl v_stack_0(r11),vocab_sp(r11) ;init stack pointer 0 moval b_kernel(r11),-(r10) ;get kernel address jsb v_push ;push on v-stack moval b_kernel(r11),current(r11) ;set up for definitions \ moval b_global(r11),global(r11) ;also global pointer $; Replace the write-only expansion areas at the ends of the ; dictionary and code psects with writable space. P subl2 #8,r10 ;push 8 bytes for return address moval dict_end-1,-(r10) ;save address in last page  addl3 #^x1ff,user_dictionary(r11),-(r10) ;save start address | $deltva_s inadr=(r10) ;perform the call .errstop D $cretva_s inadr=(r10),retadr=8(r10) ;create the space .errstop movl 8(r10),dict_pntr(r11) ;make a pointer to the start p addl2 #8,r10 ;pop 2 entries from stack Ԕ moval k_end-1,-(r10) ;push end address for kernel 8 addl3 #^x1ff,user_code(r11),-(r10) ;push start address $deltva_s inadr=(r10) ;delete the space .errstop d $cretva_s inadr=(r10),retadr=8(r10) ;create it again Ȗ .errstop , movl 8(r10),code_pntr(r11) ;set up pointer addl2 #^x10,r10 ;and pop the stack 4 times X; Crank up the console. movl prompt(r11),-(r10) ;->prompt string bsbw newprompt ;install prompt in rab L moval tyiname,-(r10) ;->"SYS$INPUT" bsbw count  movl u_ifi(r11),-(r10) ;channel # (0) x jsbext _wopen_ncr ;don't get CR attribute for it ܛ movl (r10)+,r0 ;fail if error @ .errstop ; Open console for QIO, i.e. TYI; ; check to see if interactive or batch; initialize TYPE and TYO l; addresses accordingly (if batch, use RMS, else QIO) Н jsbext outinit 4 ;enable ctrl-c interrupt bsbw enab_ctrl_c ` ğ;open message channel ( moval tyoname,-(r10) movl msg_channel(r11),-(r10) jsb open T ;user initialization  jsb @user_init(r11) jmp top_loop ;take off .list ME Hheader I_USER_INIT moval welcome,-(r10)  bsbw cr t bsbw msg ؤ rsbx <.nlist ME .list me tyiname:: string /SYS$INPUT/ htyoname:: string /SYS$OUTPUT/ ̦welcome: string 0 .nlist me top_loop: \; jsb @errchk(r11) ;check the stacks movl comp_buf_0(r11),comp_buf_pntr(r11) ;init compile buf pntr $ clrl check(r11) clrl end_of_cmnd(r11) 1$: clrl end_of_line(r11) ;set up some flags P jsb @readline(r11) ;read a line ;eof check  blbs (r10)+,20$ ;if not end of file | bsbw semif ;down a level on file stack brb 1$ D20$: jsb @compile(r11) ;compile it blbs end_of_cmnd(r11),1$ ;not end of cmnd,read somore p tstl check(r11) ;pending ; or then? ԭ bneq 1$ ;yes read more 8 jsb @execute(r11) ;execute the line brb top_loop ;and go again d ȯdone: ret , i_cond_handler: ;default condition handler .word 0 ;entry mask X movl 4(ap),r0 ;0->signal array movl (r0),r1 ;1<# args movl -4(r0)[r1],error_pc(r11) ;save user pc movl 4(r0),cond_code(r11) ;save condition code movl abort(r11),-4(r0)[r1] ;set restart address to abort L bicl2 #7,4(r0) ;clear severity code cmpl ^x0c(fp),frame_0(r11) ;just one level away?  beql 10$ x $unwind_s depadr=oneadr ;if more, do an unwind ܴ10$: movzwl #ss$_resignal,r0 ;signal resignal @ ret header I_ABORT l bsbw reset_registers ж movl r_stack_0(r11),sp ;re-initialize return stack 4 brw top_loop ;take off wterm ;macro to terminate header `header DATA_INIT ;data initialization stuff ĸ ;Values from SS module ( a_to_ut ssdata,cmddesc ;Values from RKERNEL a_to_ut i_line_buffer,line_buffer T a_to_ut i_line_buffer,line_buffer+8 ;make rest-of-line a_to_ut i_word_buffer,word_buffer  a_to_ut prompt0,prompt a_to_a oc_prot+^x0c,oc_prot a_to_a oc_prot+^x0c+40,oc_prot+4 H a_to_a oc_prot+^x0c+40,oc_prot+8 a_to_ut oc_prot,out_conv_stack  a_to_ut i_time_string,time_string t a_to_a i_time_string+8,i_time_string+4 ؽ ;Values from RMS < a_to_ut channel_prot,channel_list ;Values from TYIO  a_to_ut ttname0,ttname h a_to_ut ttchan0,ttchan ̿ a_to_ut _name,naddr 0 a_to_ut _name,nstore rsbx \header RESET_REGISTERS movl cond_handler(r11),(fp) ;condition handler, $ movl p_stack_0(r11),r10 ;and stack pointers movl l_stack_0(r11),r9 moval k_start+^x8000,r8 ;set up code pointer P movl f_stack_0(r11),r7 rsbx  |;----COMPILE_ERROR: message pointer, COMPILE_ERROR ; types message, returns to console level, aborts Dheader I_COMPILE_ERROR bsbw cr bsbw msg ;error message p moval comp_err_msg,-(r10) bsbw msg 8 movl word_buffer(r11),-(r10) ;word where compilation failed bsbw msg moval comp_err_msg1,-(r10) d bsbw msg bsbw cr , movl line_buffer(r11),-(r10) ;line where compilation failed bsbw msg bsbw cr X bsbw load_reset bsbw i_abort wterm ;terminate header comp_err_msg: string Lcomp_err_msg1: string ;----FATAL: FATAL x; expects message pointer on return stack, ; types message and does abort. @header FATAL movl (sp)+,-(r10)  bsbw msg l jmp @abort(r11) wterm ;macro to terminate header 4 ;----SYSERR: condition code, SYSERR ; signals condition & aborts if condition code is even `.LIST ME header SYSERR (.NLIST ME blbc (r10)+,20$ ;if error rsb T20$: pushl -(r10) calls #1,g^lib$signal  halt ;should never get here wterm ;end the word definition H;----I_DATE_ERROR: date on save file, I_DATE_ERROR ; types date and current date, resets registers header I_DATE_ERROR t moval date_err_msg,-(r10) bsbw msg ;type message < bsbw cr moval cur_date_msg,-(r10)  bsbw msg h movq date(r11),-(r10) bsbw show_time 0 bsbw cr moval save_date_msg,-(r10) bsbw msg \ bsbw show_time bsbw cr $ newpage jmp i_abort wterm ;macro to end header P date_err_msg: string cur_date_msg: string |save_date_msg: string time_kernel: string D ;compile: ;compile a word from the line buffer p;by looking it up and if found dispatching ;through its lookup attribute or calling 8;the literal handler header I_COMPILE blbs end_of_line(r11),comp_pop ;check eol flag d bsbw word ;get a word from linbuf blbc (r10)+,comp_pop ;no more words so return , jsb @lookup(r11) ;lookup the word blbc (r10)+,comp_lit ;not found maybe its a literal addl2 #8,(r10) ;get string address X movb @(r10),r0 ;get count in r0 addl2 r0,(r10) ;advance to end of string incl (r10) ;get attribute address movl (r10),r0 ;save attribute address addl2 #3,(r10) ;get address of code displacement L cvtwl @(r10),(r10) ;get the displacement itself addl2 r8,(r10) ;get the actual address  movzbl (r0),r0 ;convert attribute to longword x jsb @l^lookup_dispatch(r0) ;and dispatch off it brb i_compile @comp_pop: rsb  lcomp_lit: jsb @literal(r11) ;see if the word is a literal 4 blbs (r10)+,i_compile ;yes,on to next word bsbw type ;no, type word moval undef_msg,-(r10) ;this should be changed when ` jsb @compile_error(r11) ;compile_error out wterm ;macro to terminate header (undef_msg: string /undefined/ T newpage ;----digit: DIGIT, success ; looks at present character in present word, ; checks that it represents a valid digit under current radix, ; if so, converts it and adds it to (radix times current magnitude). Hheader DIGIT tstl r0  bleq not_digit t movb (r1),r2 ;2 ;have we got a decimal point? < beql found_dp subl2 #^a/0/,r2 ;bias is "0"  blss not_digit h subl2 #10,r2 ;bias is "9" + 1 blss nume 0 subl2 #<^a/A/-^a/0/-10>,r2 ;bias is "A" blss not_digit subl2 #<^a/Z/-^a/A/+1>,r2 ;bias is "Z" + 1 \ blss alph found_dp: $ tstl u_float(r11) ;is this not the first "."? bneq not_digit ;if it isn't, fail movl #1,u_float(r11) ;otherwise put a 1 in exponent P decl r0 ;and skip the byte incl r1  mnegl #1,-(r10) ;succeed | rsb not_digit: D clrl -(r10) ;fail rsb palph: addl2 #<^a/Z/-^a/A/+1>,r2 ;bias is "A" nume: addl2 #10,r2 ;bias is "0" for numeral 8 ; "A"+10 for alph. ;0 .le. n .le. 35 cmpl r2,u_rad(r11) ;compare to radix d bgeq not_digit mull2 u_rad(r11),u_mag(r11) ;shift left one position , addl2 r2,u_mag(r11) ;add current digit decl r0 ;chop current character from word incl r1 X movl #1,-(r10) ;succeed rsbx ;----ceq: ASCII character, CEQ, success ; compares character to first byte in current string Lheader CEQ cmpb (r10),(r1)  beql 20$ ;if equal x clrl (r10) brb 30$ d20$: movl #1,(r10) 30$: rsbx , ;----icompile: ICOMPILE ; compiles converted integer or floating point literal Xheader ICOMPILE  tstl u_float(r11) ;is there a decimal point?  bneq 20$ ;if so, do floating point  movl u_cbp(r11),r2 ;r2->nenext loc. in compile buf.  movw #^x8fd0,(r2)+ ;compile "MOVL #" L movl (r10)+,(r2)+ ;push number onto compile buffer  movb #^x7a,(r2)+ ;compile "-(r10)"  movl r2,u_cbp(r11) ;restore pointer x rsb 20$: @ tstl (r10)+ ;get rid of the number  movl word_buffer(r11),-(r10) ;push word descriptor address  jsb count ;make str. descriptor on stack l jsb string_to_float ;convert to D_floating  movl u_cbp(r11),r2 ;get compile loc. in r2 4 movw #^x8f70,(r2)+ ;compile "MOVD #"  movq (r7)+,(r2)+ ;move number from f-stack  movb #^x77,(r2)+ ;compile "-(r7)" ` movl r2,u_cbp(r11) ;restore pointer rsbx ( ;----scompile: SCOMPILE ; compiles string literal T header SCOMPILE moval run_sliteral,-(r10) ;run-time literal handler  pushr #^m ;save r0 and r1 through call bsbw i_jump_to_me popr #^m ;restore r0 and r1 H movl u_cbp(r11),r3 ;3->next loc. in compile buf. movw r0,(r3)+ ;length of string  movc r0,(r1),(r3) ;string t movl r3,u_cbp(r11) ;updated compile buffer pointer  rsbx < ;----run_sliteral ; run-time string-literal processor hrun_sliteral:  movl (sp)+,r0 ;string pointer 0 movl r0,-(r10)  movzwl (r0)+,r1 ;1word # movl #^a/"/,-(r10) ;push double quote T$ bsbw ceq ;compare to first character $ ..if % decl r0 ;lop off trailing double quote % ..succeed % ..else H& movl #^a/'/,-(r10) ;push single quote & bsbw ceq ;compare to first character ' ..then t' ..if ' decl r0 ;remove leading quote <( incl r1 ( bsbw scompile ;compile string literal ) addl2 #8,r10 ;drop string pointer h) ..succeed ) ..else 0* ..fail * ..then * rsbx \+ +;----literal: LITERAL, success $,; attempts to compile current word as an integer or string ,header I_LITERAL , bsbw iliteral P- ..if - bsbw icompile ;compile integer or floating literal . ..succeed |. ..else . bsbw sliteral D/ ..then / rsbx 0 newpage p0 op_rsb=^x05 0;execute the compile buffer 81header I_EXECUTE 1 movb #op_rsb,@comp_buf_pntr(r11);put in a return 2 incl comp_buf_pntr(r11) ;push the compile pntr d2 jmp @comp_buf_0(r11) ;and jump into the buffer 2 wterm ;macro to terminate header ,3 3 newpage 3 X4;colon 4;at read time compile a call to int_colon 5;and save a space in the compile buffer for 5;the count of bytes in the definition, that 5;will be filled in by ; L6header COLON,<:>,immediate 6 tstl check(r11) ;check has to be 0 7 bneq syntax_error ;or its a syntax error x7 incl check(r11) ;flag define mode 7 moval int_colon,-(r10) ;compile a call to @8 bsbw i_jump_to_me ;int_colon 8 movl comp_buf_pntr(r11),-(r10) ;save the compile pntr 9 addl2 #2,comp_buf_pntr(r11) ;space for the count l9 rsbx 9 4:;int_colon :;called when s colon was found on input :;copies the compile buffer to the end of the `;;dictionary making a new word ;int_colon: (< movzwl @(sp),-(r10) ;push length for ENTER < movzbl #jump_to_me,-(r10) ;push attribute byte < jsb @enter(r11) ;set up the header T= movl (sp),r0 ;get a pntr to the code = tstw (r0)+ ;step past count > movc3 @(sp),(r0),@code_pntr(r11);copy the code > movl r1,(sp) ;return to after word > movl r3,code_pntr(r11) ;update end of dict H? rsbx ? @; ; t@; terminate a colon definition @; at read time put an rsb in the buffer ,immediate B decl check (r11) hB bneq syntax_error ;check was not 1 so err B movb #op_rsb,@comp_buf_pntr(r11);stick in a rsb 0C incl comp_buf_pntr(r11) C movl (r10),-(r10) ;dup pointer to count C addl2 #2,(r10) ;move to actual code \D subl2 comp_buf_pntr(r11),(r10) ;compute count D mnegl (r10),(r10) $E cvtlw (r10)+,@(r10)+ ;and store it E rsbx E PF;give a syntax error message Fsyntax_error: G moval syntax_msg,-(r10) ;print the msg |G jmp @compile_error(r11) ;and error out G DH; (:) H; deferred colon (do a colon at execute time.) Iheader defer_colon,<(:)>,immediate pI decl check(r11) I bsbw colon 8J rsbx J K; (;) dK; deferred semicolon (do a semicolon at execute time) Kheader defer_semi,<(;)>,immediate ,L bsbw semi_colon L incl check(r11) L rsbx XM M; enter: string, code length, attribute byte, ENTER N; create a new stoic word setting up the name and the N; link Nheader I_ENTER LO movl dict_pntr(r11),r0 ;remember where we are in dictionary O movl @current(r11),(r0)+ ;store dictionary link P movl @global(r11),(r0)+ ;store global link xP subl3 dict_base(r11),dict_pntr(r11),@current(r11);splice in link P subl3 dict_base(r11),dict_pntr(r11),r1 ;get global link @Q addl3 r1,#4,@global(r11) ;and store it Q movl 8(r10),r1 ;r1->name string R cvtwb (r1),(r0)+ ;copy count lR movc3 (r1)+,(r1),(r0) ;copy name R movl r3,r0 ;put end pointer back in r0 4S cvtlb (r10)+,(r0)+ ;load on attribute byte S cvtlw (r10)+,(r0)+ ;load code length S tstl (r10)+ ;remove string pointer `T subl3 r8,code_pntr(r11),r1 ;code displacement in r1 T cvtlw r1,(r0)+ ;install it in the dictionary (U movl r0,dict_pntr(r11) ;fix pointer U rsbx U TVsyntax_msg: V string W newpage W W;----cpush: byte, CPUSH (pushes a byte into the compile buffer) HXheader CPUSH X cvtlb (r10)+,@u_cbp(r11) Y incl u_cbp(r11) tY rsbx Y dd addl3 @current(r11),dict_base(r11),r0 ;0->address of local backlink d addl2 #8,r0 ;0->address of string ,e movzbl (r0)+,r1 ;put length in r1 e addl3 r0,r1,-(r10) ;push address of attribute byte e rsbx Xf f newpage g g;given a string descriptor on the top of g;the stack, lookup searches the branches of the vocabulary Lh;stack and returns either true on top and the address h;of the definition at top-1 or false at top and i;the original string descriptor at top-1 xi iheader I_LOOKUP @j movq (r10)+,r4 ;descriptor of word to be found j pushl r6 ;get a free register k movl vocab_sp(r11),r6 ;get the vocabulary stack pointer lk1$: cmpl r6,v_stack_0(r11) ;is the vstack empty k beql lookup_lose ;if so weve lost 4l movl (r6)+,-(r10) ;otherwise check the branch l bsbb try_branch l blbc (r10)+,1$ ;not found try again `mpush_true: m movl #1,-(r10) ;push a true (n popl r6 n rsb ;found it,pass it back nlookup_lose: To movq r4,-(r10) ;push original string descriptor o clrl -(r10) ;push a false p popl r6 p rsbx p Hq;given a pointer to a dictionary branch at top and a string descriptor q;in r4-r5, search the branch for the string and return r;either true and the address of the word found tr;or false rtry_branch: entry name; skip both links { cvtbl (r1)+,r0 ;ro-r1>entry-name descriptor p{ cmpl r0,r4 ;are strings of equal length? { bneq nomatch ;if not equal 8| cmpc3 r0,(r1),(r5) ;compare the words | bneq nomatch } mnegl #1,-(r10) ;succeed d} rsb } ,~nomatch: clrl -(r10) ~ rsbx ~ newpage X  op_jsb=^x16 op_movl=^xd0 op_moval=^xde op_absolute=^x9f L op_auto_dec=^x7a word_disp=^xc8 ;compile a jump to the address x;and the top of the stack ܂header I_JUMP_TO_ME @ movl comp_buf_pntr(r11),r0 ;get pointer to compile buffer movb #op_jsb,(r0)+ ;put in a jsb  movb #word_disp,(r0)+ ;adr mode of word displacement l subl r8,(r10) ;get offset from dictionary Є cvtlw (r10)+,(r0)+ ;push in word displacement 4 movl r0,comp_buf_pntr(r11) ;restore pointer rsbx `;execute at compile time Ći_immediate: ( jmp @(r10)+ ;jump through the p stack ;directly compile the byte in the definition T;into the compile buffer header I_COMPILE_BYTE  movzbl @(r10)+,@comp_buf_pntr(r11) ;move the byte into incl comp_buf_pntr(r11) ;the buffer and inc the pntr rsbx H ;push the longword following the lookup atr header I_PUSH_THIS_WD t movl comp_buf_pntr(r11),r0 ؋ movb #op_movl,(r0)+ ;compile a movl #foo,-(r10) < movb #op_absolute,(r0)+ ;@# mode movl (r10)+,(r0)+ ;the address of the word  movb #op_auto_dec,(r0)+ ;and a destination of -(r10) h movl r0,comp_buf_pntr(r11) ;restore pointer ̍ rsbx 0 ;use the word following the lookup atr as a displacement with respect ;to r11 and push the resulting address \header I_DISP_TO_R11 movl comp_buf_pntr(r11),r0 ;get pointer $ movb #op_moval,(r0)+ ;inst. is "moval w^foo(r11),-(r10)" movb #^xCB,(r0)+ ;hex CB is word disp. w/r r11 cvtlw @(r10)+,(r0)+ ;push the value P movb #^x7a,(r0)+ ;autodecrement r11 movl r0,comp_buf_pntr(r11) ;restore the pointer  rsbx | ;---- (used in support of inline code facility) Dheader INT_INLINE,^// movl (sp)+,r1 ;r1->count of command string movl comp_buf_pntr(r11),r3 ;r3 is compile buffer pointer p movc3 (r1)+,(r1),(r3) ;move command string Ԕ movl r3,comp_buf_pntr(r11) ;restore pointer 8 jmp (r1) ;rsb wterm ;end the word newpage d Ȗ;error check routine ,i_errchk: rsb ;to be written X newpage .save .psect datinit ;move to data prototype ;buffers & control blocks L svariable i_line_buffer,line_buf_size svariable i_word_buffer,line_buf_size  .long 0 ;make a longword for prompt length xprompt0:: string ^$<^x20><^x0D><^x0A><^x30><^x3E><^x20>$ ܛ @oc_prot: ;prototype output conversion stack .blkl 3 ;start, end, pointer  .blkb 40 ;stack space loneadr: .long 1 ;for condition handler's unwind Н 4.restore ;----PREOPEN: filename, channel, PREOPEN, strptr., len., channel `; (does an XCOUNT on the file name) ğheader PREOPEN ( movl (r10)+,r0 ;save channel number movzbl @(r10),-(r10) ;push count incl 4(r10) ;bump pointer T tstb @4(r10) ;first byte zero? bneq 20$ ;no  incl 4(r10) ;yes, bump pointer again 20$: movl r0,-(r10) ;restore channel # H rsbx ;----SETUP_FABS: initializes FABS with special characteristics theader SETUP_FABS ؤ movl @channel_list(r11),r0 ;get RAB 0 < bisl2 #,rab$l_rop(r0) movl rab$l_fab(r0),r0  moval console,fab$l_fna(r0) h movb #consize,fab$b_fns(r0) ̦ movl #4,r0 0 movl @channel_list(r11)[r0],r0 ;get RAB 4 movl rab$l_fab(r0),r0 moval console,fab$l_fna(r0) \ movb #consize,fab$b_fns(r0) movl #5,r0 ;channel 5 is random-access $ movl @channel_list(r11)[r0],r1 ;get random rab address movb #4,rab$b_ksz(r1) ;key size for RAB is 4 bisb2 #rab$c_key,rab$b_rac(r1) ;set up key record access P movl rab$l_fab(r1),r1 ;get FAB address bisb2 #,fab$b_fac(r1)  movl #6,r0 | movl @channel_list(r11)[r0],r1 movl rab$l_fab(r1),r1 ;get FAB address D bisb2 #,fab$b_fac(r1) movl #7,r0 movl @channel_list(r11)[r0],r1 p movl rab$l_fab(r1),r1 ;get FAB ԭ bisl2 #fab$m_ufo,fab$l_fop(r1) 8 rsbx ;----ERASE: filename, channel, ERASE dheader ERASE ȯ jsbext _erase , rsbx ;----OPEN: filename, channel, OPEN Xheader OPEN bsbw preopen jsbext _open movl (r10)+,r0 .errstop L rsbx ;----MAPOPEN: filename descriptor, MAPOPEN, RMS channel, completion code xheader MAPOPEN ܴ jsbext _mapopen @ rsbx ;----MAPCLOSE: MAPCLOSE, completion code lheader MAPCLOSE ж jsbext _mapclose 4 rsbx ;----.OPEN: filename descriptor, channel, .OPEN, condition code `header .OPEN ĸ jsbext _open ( rsbx ;----.WOPEN: filename ptr., filename len., channel, WOPEN, cond. code Theader .WOPEN jsbext _wopen  rsbx ;----.WOPEN_NCR: filename ptr., filename len., channel, WOPEN_NCR, cond. code H; (opens for writing without CR record attribute) header .WOPEN_NCR  jsbext _wopen_ncr t rsbx ؽ <;----.WOPEN_FTN: ... opens for writing with Fortran rec. attribute header .WOPEN_FTN  jsbext _wopen_ftn h rsbx ̿ 0;----WOPEN: filename, channel, WOPEN header WOPEN bsbw preopen \ bsb .wopen movl (r10)+,r0 $ .errstop rsbx P;----.XLOAD: file name, count, channel, .XLOAD header .XLOAD  jsbext _xload | rsbx D;----XLOAD: file name, XLOAD header XLOAD bsbw count p movl blk_chan(r11),-(r10) ;push channel jsbext _xload 8 rsbx ;----.SAVE: file name, count, channel, .SAVE dheader .SAVE jsbext _save , rsbx ;----SAVE: file name, SAVE Xheader SAVE bsbw count movl blk_chan(r11),-(r10) jsbext _save rsbx L ;----FAB_COUNT: FAB_COUNT, prototype FAB address, FAB length header FAB_COUNT x moval proto_fab,-(r10) movzbl #fablen,-(r10) @ rsbx ;----RAB_COUNT: RAB_COUNT, prototype RAB address, RAB length lheader RAB_COUNT moval proto_rab,-(r10) 4 movzbl #rablen,-(r10) rsbx `;----XAB_COUNT: XAB_COUNT, prototype XAB address, XAB length header XAB_COUNT ( moval proto_xab,-(r10) movzbl #xablen,-(r10) rsbx T ;----channel, FIL_RAT, record attribute byte header FIL_RAT jsbext _fil_rat rsbx H ;----channel, FIL_EBK, number of EOF block header FIL_EBK t jsbext _fil_ebk rsbx < ;----channel, FIL_FFB, number of first free byte in last block header FIL_FFB h jsbext _fil_ffb rsbx 0 ;----channel, FIL_FSZ, size of fixed control area for the file header FIL_FSZ \ jsbext _fil_fsz rsbx $ ;----channel, FIL_MRS header FIL_MRS P jsbext _fil_mrs rsbx  |;----channel, FIL_RFM header FIL_RFM D jsbext _fil_rfm rsbx p;----buffer, length, channel, READ, cond. code header READ 8 jsbext _read rsbx d;----buffer, length, channel, WRITE, cond. code header WRITE , jsbext _write rsbx X;----.APPEND: filename ptr., filename len., channel, APPEND, cond. code header .APPEND jsbext _append rsbx L;----APPEND: filename, channel, APPEND header APPEND  bsbw preopen x bsb .append movl (r10)+,r0 @ .errstop rsbx  l;----ROPEN: filename, channel, ROPEN header ROPEN 4 bsbw preopen jsbext _ropen movl (r10)+,r0 ` .errstop rsbx ( ;----.ROPEN: filename, channel, .ROPEN, completion code header .ROPEN T bsbw preopen jsbext _ropen  rsbx ;----.RCREATE: Hheader .RCREATE bsbw preopen  jsbext _rcreate t rsbx <;----inch: inch, pointer to current input channel header INCH  movl u_ifi(r11),-(r10) h rsbx 0;----NEXTINCH: NEXTINCH ; increments input channel # header NEXTINCH \ movq u_ifi(r11),r0 incl r0 $ cmpl r0,r1 bgtr ni_err ;if table overflow movl r0,u_ifi(r11) P movl r0,-(r10) rsbx ni_err: jsb fatal | string D;----LASTINCH: LASTINCH, inch header LASTINCH decl u_ifi(r11) ;decrement input file # p blss 20$ ;if index underflow brb inch 820$: ret ;normal exit from STOIC wterm ;macro to terminate header d ;----LOAD: file name, LOAD ,header LOAD bsbw nextinch bsbw open X rsbx ;----CLOSE: STOIC channel #, CLOSE header CLOSE .extrn _close L jsb _close movl (r10)+,r0 ;condition code  .errstop x rsbx d; File words with FRAB addresses on stack ,;----FOPEN: file name, access byte, FRAB address, .FOPEN, condition code header .FOPEN  jsbext _fopen X rsbx  ;----FCREATE: file name, access byte, FRAB address, .FCREATE, condition code header .FCREATE  jsbext _fcreate L rsbx  ;----FCLOSE: FRAB address, .FCLOSE, condition code xheader .FCLOSE  jsbext _fclose @ rsbx  ;----FREAD: buffer address, length, FRAB address, .FREAD, condition code lheader .FREAD  jsbext _fread 4 rsbx  ;----FWRITE: buffer address, length, FRAB address, .FWRITE, condition code ` header .FWRITE jsbext _fwrite ( rsbx ;----FGET: buffer address, length, FRAB, .FGET, not-end-of-file, cond. code T header .FGET jsbext _fget  rsbx ;----FPUT: buffer address, length, FRAB, .FPUT, condition code H header .FPUT jsbext _fput  rsbx t ;----;F <header SEMIF,<;F>  jsb inch  jsb close h jsb lastinch  tstl (r10)+ ;drop channel # 0 rsbx  ;----LOAD_reset: LOAD_reset \; cancels all active LOAD's, forcing input from console header LOAD_RESET $ brb 20$ 30$: ;...loop, closing out input files P jsb semif 20$: tstl u_ifi(r11) ;input file index  bgtr 30$ ;if not yet at console level | rsbx  D;----.GET: buffer, len, chan, GET, ret. len, condition code header .GET  jsbext _get p rsbx  8;----GET: buffer, maxlen, chan, GET, ; [ret. len., -1 (if not EOF)] or [0 (if EOF)] header GET d jsb .get  jsb syserr , blbs (r10),20$ ;if not EOF  movl (r10)+,(r10) ;EOF, don't return count 20$: rsbx X ;----GET_STRING: string, chan, GETSTRING header GET_STRING  movq (r10),r2  addl3 s^#2,r3,(r10) ;buffer address L movzwl -2(r3),-(r10) ;buffer length  movl r2,-(r10) ;channel  jsb .get x jsb syserr  movq (r10)+,r0 @ cvtlw r1,@(r10)+ ;return count  movl r0,-(r10) ;eof code  rsbx l ;----.PUT: buffer, maxlen, chan, .PUT, condition code 4!header .PUT ! jsbext _put ! rsbx `" ";----PUT: buffer, maxlen, chan, PUT (#header PUT # jsb .put # jsb syserr T$ rsbx $ %;----RANDOGET: record #, buffer, length, chan., RANDOGET,- %; returned length, condition code % .extrn _randoget H&header RANDOGET & jsb _randoget ' rsbx t' ';----RANDOPUT: record #, buffer, length, RANDOPUT,condition code <(header RANDOPUT ( .extrn _randoput ) jsb _randoput h) rsbx ) 0*newpage *;----READLINE: % READLINE, not(eof) *; reads a line into line buffer from current input device \+header I_READLINE + addl3 prompt(r11),#5,r0 ;get addr of check in prompt $, addb3 #^a/0/,check(r11),(r0) ;put check in prompt msg. , movl line_buffer(R11),-(R10) ;line buffer , jsb inch ;input channel P- jsb get_string - movl line_buffer(r11),-(r10) . bsbw count |. movq (r10)+,rest_of_line(r11);initial count . clrl @word_buffer(R11) ;null current word D/ rsbx / 0;----NEWPROMPT: string pointer, NEWPROMPT p0; install console prompt string 0header NEWPROMPT 81 movl (r10),prompt(r11) ;install in user table 1 jsb count 2 jsbext _prompt ;install in FAB d2 rsbx 2 ,3; start remote listener 3header REMSTART 3 jsbext _remstart X4 jsb syserr 4 rsbx 5 5; type to remote port 5header REMTYPE L6 jsbext _remtype 6 jsb syserr 7 rsbx x7 7newpage @8;----WORD: WORD, pointer to next word, success (fails if no more words) 8header WORD 9 movq rest_of_line(r11),r0 ;descriptor of rest of line l920$: 9;...skip leading blanks, tabs, and form feeds 4: movq r0,r2 ;save current position : skpc #^a/ /,r0,(r1) ;skip blanks : skpc #^x9,r0,(r1) ;skip tabs `; skpc #^xC,r0,(r1) ;skip form feeds ; cmpl r0,r2 ;get any this time? (< bneq 20$ ;yes, try to get more < ;2beginning of word T= =;...leading double quote indicates string literal > skpc #^a/"/,r0,(r1) > cmpl r0,r2 ;was there a leading /"/ > beql 30$ ;no H? locc #^a/"/,r0,(r1) ? skpc #^a/"/,r0,(r1) @ brb 40$ ;resume normal processing t@30$: @;...leading percent sign indicates comment descriptor of rest of line |G movq r0,rest_of_line(r11) G subw2 r0,r2 ;length of word DH bneq 50$ ;if not end of line H clrl -(r10) ;signal failure I rsb pI50$: I 8J;make word a STOIC string, place results on p-stack J movl word_buffer(r11),r4 ;address of word buffer K movw r2,(r4)+ ;length of word dK movl r4,-(r10) K movl r2,-(r10) ;push string descriptor ,L movc3 r2,(r3),(r4) ;move string L movl #1,-(r10) ;push true L rsbx XMnewpage M;----COUNT: string pointer, COUNT, string address, string length Nheader COUNT N movzwl @(r10),-(r10) ;push count N addl2 #2,4(r10) ;bump pointer LO rsbx O P;----TYPE: string address, string length, TYPE xP; outputs string to console P;header TYPE @Q; .extrn _type Q; jmp _type R; rsbx lR R;----TYPE: uses routine in TYPEADDR 4Sheader TYPE S jmp @typeaddr(r11) S wterm `T T;Specialized type routines (RMSTYPE is necessary for batch jobs; either (U;will work interactively but QIOTYPE is cheaper Uheader RMSTYPE U jsbext _rmstype TV rsbx Vheader QIOTYPE W jsbext _type W rsbx W HX;----MSG: string pointer, MSG X; outputs string to console Yheader MSG tY jsb count Y jsb type |y; r0 - magnitude of number y; r1 - 0 (high order part of dividend) Dz; r2 - extracted digit z; r3 - signed number {; r4 - radix p{; r5 - string pointer {jsb space 8| movl u_rad(r11),r4 | movl r9,r5 ;5 movl 4(ap),r6 ;get the address of the arg block subl3 #ctrl_c_temp,r6,r11 ;set up R11 d mnegl #1,ctrl_c_flag(r11) Ȗ movl ctrl_c_handler(r11),r0 ;address of handler , beql 10$ ;if no handler jsb (r0) 10$: X ret header I_CTRL_C_HNDLR ;initial control_c handler ; causes an abort on control_c movl fp,r0 ;get frame pointer L20$: cmpl ^xc(r0),r_stack_0(r11) beql 40$ ;found stoic frame  bgtr 60$ ;if cannot find STOIC frame x movl ^x0c(r0),r0 ;get next frame ܛ brb 20$ ;go try it @40$: ;here on frame found moval i_abort,^x10(r0) ;force abort 60$: l rsbx Н 4;----OCONSTACK: OCONSTACK, pointer to output conversion stack header OCONSTACK movl out_conv_stack(r11),-(r10) ` rsbx ğnewpage (;----CONSTANT: value, name, CONSTANT ; compiles longword constant header CONSTANT T movzbl #4,-(r10) ;word length is 4 movzbl #push_this_word,-(r10) ;set up attribute byte  jsb @enter(r11) movl code_pntr(r11),r0 ;r0 ;----SYSTEM_SERVICES: SYSTEM_SERVICES, $; pointer to system services dictionary branch header SYSTEM_SERVICES .extrn ss_calls P movl ss_calls,-(r10) rsbx  |;-----MOAT: MOAT, address of moat before parameter stack header MOAT D subl3 #^x200,p_stack_0(r11),-(R10) rsbx p;----P_STACK: P_STACK, address of parameter stack ԭ; (also address of moat between P-stack & L-stack) 8header P_STACK movl p_stack_0(r11),-(r10) rsbx d ȯ;----L_STACK: L_STACK, address of loop stack ,; (also address of moat between P-stack & L-stack) header L_STACK movl l_stack_0(r11),-(r10) X rsbx ;----F_STACK: F_STACK, address of floating point stack ; (also address of moat between F-stack and V-stack) header F_STACK L moval f_stack_0(r11),-(r10) rsb  x;----V_STACK: V_STACK, address of vocabulary stack ܴ; (also address of moat after V-stack) @header V_STACK movl v_stack_0(r11),-(r10)  rsbx l ж newpage 4;----B,: byte, B, ; append byte to end of dictionery header BCOMMA, ` movl code_pntr(r11),r0 ;r0->end of dictionary ĸ cvtlb (r10)+,(r0)+ ;append byte to dictionary ( movl r0,code_pntr(r11) ;restore pointer rsbx T;----,: value, , ; append value to end of dictionery header COMMA,<,> movl code_pntr(r11),r0 ;r0->end of dictionary movl (r10)+,(r0)+ ;append to dictionary H movl r0,code_pntr(r11) ;restore pointer rsbx  t;----ISOLATE_BLOCK: accepts number of pages in R0 ؽ; reserves that many pages with a moat before them <; returns first usable address of new region in R1, first ; unusable address in r2 header ISOLATE_BLOCK h jsbext get_block ;get pages ̿ rsbx ;and return 0 newpage \;----BRANCH: pointer to branch header, name, BRANCH ; creates a new vocabulary branch $header BRANCH movl #4,-(r10) ;code length is one longword movzbl #push_vocab,-(r10) ;attribute P jsb @enter(r11) jsb comma ;literal pointing to branch pointer  rsbx | header I_PUSH_VOCAB D jsb i_push_this_wd movl #v_push,-(r10) jsb i_jump_to_me p rsbx 8;----V_PUSH: header V_PUSH movl vocab_sp(r11),r0 ;r0: pops the top off the V-stack Xheader LEFT_ANGLE,^!>! addl2 #4,vocab_sp(r11) rsbx ;----DEFINITIONS: makes current the branch at top of V-stack Lheader DEFINITIONS movl @vocab_sp(r11),current(r11)  rsbx x ;----ASSEMBLER<: pushes pointer to ASSEMBLER branch onto V-stack @header ASSEMBLER_LA,^!ASSEMBLER  h .macro newtab ;start a new table table_offset=0 0 .endm .macro dlrte name,init=0,?p1 ;macro to defin a longword \ ;(address relative to R11) name==table_offset-^x8000 ;table entry, sets name to $ foo=. ;remember this address .long init ;name and initial value to init table_offset=table_offset+4 P .save ;remember where we were  .psect kernel ;and make a stoic word | header p1,name,disp_to_r11 ;that will execute the code .long name ;set up displacement D .restore .endm p .macro dlte name,init=0,?p1 ;macro to defin a longword 8 name==table_offset ;table entry, sets name to foo=. ;remember this address .long init ;name and initial value to init d table_offset=table_offset+4 .save ;remember where we were , .psect kernel ;and make a stoic word header p1,name,push_this_word ;that will push the address X .long foo .restore .endm newpage L .psect datinit ;user table x ut_start:: newtab @ dlrte ADDRESS_STORAGE ;space for mem. management data .long 1 ;leave space for two longwords  table_offset=table_offset+4 ;and adjust offset l .global address_storage ;make it available dlrte COND_HANDLER,i_cond_handler 4 dlrte CTRL_C_TEMP ;terminal channel for control-c .long 1 ;temporary for control-c table_offset=table_offset+4 ` dlrte CTRL_C_FLAG ;flag which is set on control-c dlrte CTRL_C_HANDLER,i_ctrl_c_hndlr ( dlrte P_STACK_0 ;initial p stack pointer dlrte R_STACK_0 ;initial return stack pointer dlrte L_STACK_0 ;initial loop stack pointer T dlrte F_STACK_0 ;initial floating point stack ptr dlrte V_STACK_0 ;initial vocab stack pointer  dlrte FRAME_0 ;initial frame pointer dlrte VOCAB_SP ;vocabulary stack pointer dlrte OUT_CONV_STACK ;output conversion stack H.list me dlrte ASSEMBLER,<^x7fffffff> ;ASSEMBLER dictionary branch  dlrte STOIC,<^x7fffffff> ;STOIC branch t dlrte TTIO,ttio_ttio-dict_start-^x8000 ;TTIO branch dlrte FLOAT,crtl_crtl-dict_start-^x8000 <.nlist me dlrte DISPATCH_ADR,lookup_dispatch ;pntr to dispatch table  dlrte LOOKUP,i_lookup h dlrte COMPILE,i_compile dlrte COMP_BUF_0 0 dlrte COMP_BUF_PNTR ;compile buffer pointer dlrte END_OF_CMND ;compile end of command dlrte END_OF_LINE ;compile end of line \ dlrte CHECK ;if level dlrte EXECUTE,i_execute ;execute word $ dlrte LITERAL,i_literal ;literal handler dlrte ERRCHK,i_errchk ;error checker dlrte READLINE,i_readline P dlrte ABORT,i_abort dlrte ERROR_PC ;pc saved by condition handler  dlrte COND_CODE ;conition code from error handler | dlrte COMPILE_ERROR,i_compile_error dlrte DATE,0 ;revision date for checking of D table_offset=table_offset+4 ;save files (quadword) .long 0 dlrte DATE_ERROR,i_date_error ;address of date error routine p dlrte TIME_STRING dlrte ENTER,i_enter 8 dlrte CODE_PNTR,dictionary ;code pointer dlrte DICT_PNTR,dict_cur ;dictionary pointer dlrte DICT_BASE,dict_start+^x8000 d dlrte USER_DICTIONARY,<<^x200*>+^x200> dlrte USER_CODE,<<^x200*>+^x200> , dlrte DICT_0,dict_start dlrte CODE_0,k_start dlrte DATA_0,dat_start ;data prototype address X dlrte DATA_END,dat_fin dlrte USER_DATA dlrte VARIABLE_LIST ;list for var initialization dlrte B_KERNEL,last_kernel-dict_start-^x8000 ;kernel beginning dlrte B_GLOBAL,last_global-dict_start-^x8000 ;global beginning L dlrte CURRENT ;current dictionary branch dlrte GLOBAL  dlrte PROMPT ;address of prompt string x .blkl 1 ;(2 longwords) table_offset=table_offset+4 d dlrte USER_INIT,i_user_init ;user initializer , dlrte U_IFI ;input fab indexfab number  dlrte U_IFM,3 ;max. fab #  dlrte U_IFT,channel_list ;file access table X dlrte LINE_BUFFER  dlrte REST_OF_LINE  .long 0 ;(this is a quadword entry)  table_offset=table_offset+4  dlrte WORD_BUFFER L dlrte U_SGN ;sign for iliteral  dlrte U_MAG ;magnitude for iliteral  .long xtable_offset=table_offset+4 ;this should be a quadword for fp  dlrte U_FLOAT ;flag for floating point @ dlrte U_RAD,16 ;radix  dlrte .D ;next free data location  dlrte .M ;first unavailable memory loc. l dlrte MSG_CHANNEL,4 ;---RMS stuff--- message chan.  dlrte RANDOCHAN,5 4 dlrte BLK_CHAN,6  dlrte TYOADDR ;address of TYO routine  dlrte TYPEADDR ;address of TYPE routine ` dlrte CHANNEL_LIST ;address of channel list dlrte CMDDESC ;---SS stuff--- comm. desc. ( dlrte TTNAME ;---TYIO stuff--- sys$command dlrte TTCHAN ;entries for terminal channel .blkl 1 ;2-longword entry for extra stuff T table_offset=table_offset+4 dlrte NLEN,63 ;device descriptor name field  dlrte NADDR ;address dlrte NSTORE ;holding area for address dlrte RMINAME H .blkl 1 table_offset=table_offset+4 ;2 longword entry  dlrte RMICHAN t .blkl 2  table_offset=table_offset+8 ;3 longword entry < dlrte RMONAME  .blkl 1  table_offset=table_offset+4 ;2 longword entry h dlrte RMOCHAN  .blkl 2 0 table_offset=table_offset+8 ;3 longword entry  dlrte RMBUF  \; Size calculations for data prototype  $u_cbp==comp_buf_pntr  lookup_dispatch:: P newtab ;lookup atribute bytes dispatch through here  dlte JUMP_TO_ME,i_jump_to_me ;compiles a jump to its arg  dlte IMMEDIATE,i_immediate ;execute at compile time | dlte COMPILE_BYTE,i_compile_byte ;compiles a byte  dlte PUSH_THIS_WORD,i_push_this_wd ;constant D dlte PUSH_VOCAB,i_push_vocab ;branch  dlte DISP_TO_R11,i_disp_to_r11 ;variable, etc.  plt_length=.-lookup_dispatch  8ut_end:: dat_end::  d.save .psect dictionary ,.=kernel last_kernel:: .=globlink Xlast_global:: .restore  .psect kernel  Lnewpage  dictionary: x .psect dictionary @ dict_cur:  l .end start