; =====> SCHEMED.ASM ;*************************************** ;* TIPC Scheme '84 Runtime Support * ;* (C) Copyright 1984,1985,1986 by * ;* Texas Instruments Incorporated. * ;* All rights reserved. * ;* * ;* Date Written: April 1984 * ;* Last Modification: 10 Feb 1987 * ;*************************************** include schemed.equ include screen.equ ; Modification History: ; 26 Feb 86 - Modified the initial value of the global variable "listpage" ; (JCJ) so that it points to page zero (0) instead of END_LIST. This ; causes it to always point to a valid page, thus eliminating ; one check for each CONS operation. ; rb 5/22/86 - changed debug flag in R2 used as VM starts up; ; if none, R2=0 (nil), else R2=Scheme 0 (i.e. tagged fixnum zero) ; tc 2/10/87 - Changed page 5 special symbols to for #T instead of #!TRUE ; for the R^3 Report. ;************************************************************************ ;* Segment Alignment Macro * ;* * ;* Purpose: This macro causes "define bytes" to be inserted in the * ;* current data section to force the data item which * ;* follows it to be aligned on a paragraph boundary. * ;* * ;* Note: For this macro to work, the current data segment must be * ;* aligned on a paragraph boundary. This is accomplished * ;* through the "para" option of the "segment" assembler * ;* directive, e.g., * ;* * ;* data segment para public 'DATA' * ;* * ;************************************************************************ align macro AL_TMP = $ - AL_start ; get current location AL_TMP = AL_TMP MOD 16 ; isolate low order 4 bits AL_TMP = 16 - AL_TMP ; determine "correction" AL_TMP = AL_TMP MOD 16 ; adjust if already aligned IF AL_TMP db AL_TMP dup (0) ENDIF endm DGROUP group data data segment para public 'DATA' assume DS:DGROUP AL_start equ $ ; Start of data segment for align macro ;;; Page Table - This area of memory holds the table of base ;;; (paragraph) addresses for each of the page ;;; frames in Scheme's memory system. public pagetabl pagetabl label word dw page0 ; page 0 - 'nil or cdr nil dw 0 ; page 1 - characters (immediates) dw 0 ; page 2 - forwarded pointer dw 0 ; page 3 - 15-bit fixnums (immediates) dw page4 ; page 4 - special 32-bit flonums dw page5 ; page 5 - special symbols dw page6 ; page 6 - standard port page dw page7 ; page 7 - code for test programs dw page8 ; page 8 - initial environments ; remainder of page table dw NUMPAGES-PreAlloc dup (0) ; Page Attribute Table - The bits in the following table are ; used to indicate the state of each of the pages ; in the Scheme memory system. Only one kind of data ; object can be stored in a given page, so a single bit ; can be used to classify all references to a page. public attrib,w_attrib w_attrib equ $ ; Special redefinition for C to use as int attrib dw ATOM+READONLY ; page 0 - 'nil dw ATOM+CHARS+READONLY+NOMEMORY dw NOMEMORY dw ATOM+FIXNUMS+READONLY+NOMEMORY dw ATOM+FLONUMS+READONLY dw ATOM+SYMBOLS+READONLY dw ATOM+PORTS+READONLY dw ATOM+CODE dw ATOM ; Initial Environments dw NUMPAGES-9 dup (NOMEMORY) ; Next available location table - The following table contains ; the offsets of the next available location which ; may be allocated in each page. A negative value ; indicates that the page is full and that no further ; allocation is possible within a page. public nextcell nextcell dw 8 dup (END_LIST) dw env_nxt-page8 ; Environments page dw NUMPAGES-9 dup (END_LIST) ; Page link table - Pages which contain data objects of the same ; type are linked together via the following table. public pagelink pagelink dw NUMPAGES dup (END_LIST) ; Page type table - This table holds the "type" of each page for ; pointer classification purposes. The values in ; this table may be used as indicies into branch ; tables. public ptype ptype dw LISTTYPE*2 ; Page 0 contains list cells dw CHARTYPE*2 ; Page 1 is for character immediates dw FREETYPE*2 ; Page 2 is for "forwarded pointers" dw FIXTYPE*2 ; Page 3 is for fixnum immediates dw FLOTYPE*2 ; Page 4 contains pre-defined flonums dw SYMTYPE*2 ; Page 5 contains pre-defined symbols dw PORTTYPE*2 ; Page 6 contains standard I/O ports dw CODETYPE*2 ; Page 7 contains test programs dw ENVTYPE*2 ; Page 8 contains environments dw NUMPAGES-9 dup (FREETYPE*2) ; Rest of pages not pre-allocated public psize psize dw page0_end-page0 ; Page 0 contains special list cells dw 0 ; Page 1 is a tag for immediate characters dw 0 ; Page 2 reserved for "forwarded pointers" dw 0 ; Page 3 is a tag used for immediate fixnums dw page4_end-page4 ; Page 4 contains pre-defined flonums dw page5_end-page5 ; Page 5 contains pre-defined symbols dw page6_end-page6 ; Page 6 contains standard I/O ports dw page7_end-page7 ; Page 7 contains test programs dw page8_end-page8 ; Page 8 contains environments dw NUMPAGES-9 dup (MIN_PAGESIZE) ; Initialize default page size ; Table of pages for allocation by type public pagelist,listpage,fixpage,flopage,bigpage,sympage,strpage public vectpage,contpage,clospage,freepage,codepage,refpage,portpage public envpage pagelist equ $ listpage dw 0 ; [0] Page number for list cell allocation fixpage dw END_LIST ; [1] Page number for fixnum allocation flopage dw END_LIST ; [2] Page number for flonum allocation bigpage dw END_LIST ; [3] Page number for bignum allocation sympage dw END_LIST ; [4] Page number for symbol allocation strpage dw END_LIST ; [5] Page number for string allocation vectpage dw END_LIST ; [6] Page number for vector allocation contpage dw END_LIST ; [7] Page number for continuation allocation clospage dw END_LIST ; [8] Page number for closure allocation freepage dw END_LIST ; [9] Free page list header codepage dw END_LIST ; [10] Page number for code block allocation refpage dw END_LIST ; [11] Page number for ref cell allocation portpage dw END_LIST ; [12] Page number for port allocation charpage dw END_LIST ; [13] Page number for characters envpage dw ENV_PAGE ; [14] Page for environments ; Table of page attributes by data object type public pageattr pageattr dw LISTCELL ; [0] List cell attributes dw ATOM+FIXNUMS ; [1] Fixnum attributes dw ATOM+FLONUMS ; [2] Flonum attributes dw ATOM+BIGNUMS ; [3] Bignum attributes dw ATOM+SYMBOLS ; [4] Symbol attributes dw ATOM+STRINGS ; [5] String attributes dw ATOM+VECTORS ; [6] Vector (array) attributes dw ATOM+CONTINU ; [7] Continuation attributes dw ATOM+CLOSURE ; [8] Closure attributes dw 0 ; [9] Free page has no attributes dw ATOM+CODE ; [10] Code block attributes dw ATOM+REFS ; [11] Ref cell attributes dw ATOM+PORTS ; [12] Port attributes dw ATOM+CHARS ; [13] Character attributes dw ATOM ; [14] Environment attributes public nextpage,lastpage,nextpara,PAGESIZE nextpage dw 9 ; Next unused page number lastpage dw 9 ; Will hold last page # for ext memory nextpara dw 0 ; Next available paragraph number PAGESIZE dw MIN_PAGESIZE ; Table of bit settings to "or" in public bitable bitable dw 08000H,04000H,02000H,01000H,00800H,00400H,00200H,00100H dw 00080H,00040H,00020H,00010H,00008H,00004H,00002H,00001H public rtn_name rtn_name db "You didn't use the ENTER macro!",0 ; "Registers" for the Scheme Virtual Machine public nil_reg,regs,reg0,reg0_pag,reg0_dis nil_reg dw NIL_DISP dw NIL_PAGE*2 regs equ $ reg0 equ $ ; Virtual register 0 - always nil reg0_dis dw NIL_DISP reg0_pag dw NIL_PAGE*2 public reg1,reg1_pag,reg1_dis reg1 equ $ ; Virtual register 1 reg1_dis dw UN_DISP reg1_pag dw UN_PAGE*2 rept NUM_REGS-2 ; define the VM's remaining registers dw UN_DISP,UN_PAGE*2 endm public FNV_reg,FNV_pag,FNV_dis FNV_reg equ $ ; Fluid Environment Pointer FNV_dis dw NIL_DISP FNV_pag dw NIL_PAGE*2 public GNV_reg,GNV_pag,GNV_dis GNV_reg equ $ ; Global Environment Pointer GNV_dis dw g_env-page8 GNV_pag dw ENV_PAGE*2 public CB_reg,CB_pag,CB_dis CB_reg equ $ ; Code Base Pointer CB_dis dw 0 CB_pag dw 14 public tmp_reg,tmp_page,tmp_disp ; GC'ed temporary register tmp_reg equ $ tmp_disp dw NIL_DISP tmp_page dw NIL_PAGE*2 public tm2_reg,tm2_page,tm2_disp ; GC'ed temporary register tm2_reg equ $ tm2_disp dw NIL_DISP tm2_page dw NIL_PAGE*2 public tmp_adr,tm2_adr ; addresses of temporary registers tmp_adr dw tmp_reg tm2_adr dw tm2_reg ; Transcript File pointer public TRNS_reg,TRNS_pag,TRNS_dis TRNS_reg equ $ TRNS_dis dw NIL_DISP TRNS_pag dw NIL_PAGE*2 ; Storage for interned symbol 'quote public QUOTE_PA,QUOTE_DI QUOTE_DI dw NIL_DISP QUOTE_PA dw NIL_PAGE*2 public CONSOLE_,CON_PAGE,CON_DISP ; 'console interned symbol CONSOLE_ equ $ CON_DISP dw NIL_DISP CON_PAGE dw NIL_PAGE*2 public S_pc S_pc dw entry - page7 ; Storage for oblist hash table public hash_pag,hash_dis hash_pag db HT_SIZE dup (0) hash_dis dw HT_SIZE dup (0) ; Storage for property list hash table public prop_pag,prop_dis prop_pag db HT_SIZE dup (0) prop_dis dw HT_SIZE dup (0) ; Storage for object hash table public obj_ht obj_ht db OHT_SIZE*3 dup (0) ; Stack storage (stack buffer) public S_stack S_stack db NIL_PAGE*2 ; caller's code base pointer dw NIL_DISP db SPECFIX*2 ; return address displacement dw 0 db SPECFIX*2 ; caller's FP dw 0 db ENV_PAGE*2 ; current heap environment dw g_env-page8 db SPECFIX*2 ; static link dw 0 db NIL_PAGE*2 ; closure pointer ('nil means open call) dw NIL_DISP STK_HEAD equ $-S_stack db STKSIZE-STK_HEAD dup (0) public TOS,FP,BASE,PREV_reg,PREV_pag,PREV_dis TOS dw STK_HEAD-PTRSIZE ; current top-of-stack pointer FP dw 0 ; current stack frame pointer BASE dw 0 ; stack buffer base PREV_reg equ $ ; pointer to previous stack segment PREV_dis dw NIL_DISP PREV_pag dw NIL_PAGE*2 ; State variables for (reset) and (scheme-reset) public FP_save,FNV_save,STL_save,RST_ent,ERR_ent FP_save dw 0 ; save area for nominal stack FNV_save dw NIL_DISP,NIL_PAGE*2 ; fluid enviornment pointer save area STL_save dw NIL_DISP,NIL_PAGE*2 ; scheme-top-level value save area RST_ent dw reset_x - page7 ; entry point for reset code ERR_ent dw err_rtn - page7 ; entry point for error handler invocation ; Flags for VM Control public PC_MAKE,VM_debug,s_break PC_MAKE dw 1 ; PC's manufacturer flag VM_debug dw 0 ; flag indicating VM_debug mode s_break dw 0 ; flag indicating shift-break key depressed ; Current port public iooffs,ioseg iooffs dw 0 ioseg dw 0 ; Stack pointer for abort public abadr abadr dw 0 ; Special storage for nil align public page0 page0 db NIL_PAGE*2 ; Special constant: (cons nil nil) dw NIL_DISP db NIL_PAGE*2 dw NIL_DISP page0_end equ $ ; end of Page 0 ; Special 32-bit floating point constants area align public page4 page4 db FLOTYPE,00,00,00,00,00,00,0F0H,0BFH ;-1.0 db FLOTYPE,00,00,00,00,00,00,00,00 ; 0.0 db FLOTYPE,00,00,00,00,00,00,0F0H,03FH ; 1.0 page4_end equ $ ; end of Page 4 ; Define symbol constant symbol MACRO str local x,y x db SYMTYPE ; tag dw y-x ; length field db NIL_PAGE*2 ; link field page number - initially null dw NIL_DISP ; link field displacement - initially null db 0 ; hash key - 0 for "special symbols" db str ; character data y equ $ endm ; Special storage for single character symbols align public page5 page5 equ $ t_symbol equ $ symbol "#T" ; #T for #!true for 't for true symbol "#!UNASSIGNED" ; the proverbial undefined value symbol "#!NOT-A-NUMBER" ; undefined result of arithmetic eof_sym equ $ symbol "#!EOF" ; end-of-file indicator non_prt equ $ symbol "#!UNPRINTABLE" ; value of *the-non-printing-object* page5_end equ $ ; end of Page 5 align public page6 page6 equ $ BUFFSIZE equ 256 ; buffer size ; Standard Input Port (for now, a file) stdinp db PORTTYPE ; tag=PORT dw stdinp_-stdinp ; length of object in bytes db 0,0,0 ; null pointer dw 03Eh ; flags (r/w,window,open,transcript,binary) dw 0 ; handle (stdin CON) dw 0 ; cursor line dw 0 ; cursor column dw 0 ; upper left line dw 0 ; upper left column dw DEFAULT_NUM_ROWS ; number of lines dw DEFAULT_NUM_COLS ; number of columns dw -1 ; border attributes (none) dw 000FH ; text attributes (white, enable) dw 1 ; window flags (wrap) dw 0 ; current buffer position dw 0 ; current end of buffer db BUFFSIZE dup (0) ; input buffer db "CON" ; pathname stdinp_ equ $ ; The following point object is now used for the pcs-status-window stdoutp db PORTTYPE ; tag=PORT dw stdoutp_-stdoutp ; length of object in bytes db 0,0,0 ; null pointer dw 02Eh ; flags (r/w,window,open,no transcript,bin) dw 1 ; handle (stdout CON) dw 0 ; cursor line dw 0 ; cursor column dw DEFAULT_NUM_ROWS - 1 ; upper left line dw 0 ; upper left column dw 1 ; number of lines dw DEFAULT_NUM_COLS ; number of columns dw -1 ; border attributes (none) dw 001CH ; text attrs (reverse video, green, enable) dw 1 ; window flags (wrap) dw 0 ; current buffer position dw 0 ; current end of buffer db BUFFSIZE dup (0) ; output buffer db "CON" ; pathname stdoutp_ equ $ page6_end equ $ ; end of Page 6 fxn MACRO val db SPECFIX*2 dw val endm ; Environments align public page8 ENV_PAGE equ 8 page8 equ $ ; define USER-GLOBAL-ENVIRONMENT g_env db ENVTYPE dw (HT_SIZE*3)+BLK_OVHD+PTRSIZE db 0,0,0 ; parent pointer (there is no parent) db HT_SIZE*3 dup (0) ; define USER-INITIAL-ENVIRONMENT u_env db ENVTYPE dw (HT_SIZE*3)+BLK_OVHD+PTRSIZE db ENV_PAGE*2 dw g_env-page8 db HT_SIZE*3 dup (0) env_nxt equ $ ;;; dw MIN_PAGESIZE-(env_nxt-page8) ;;; db MIN_PAGESIZE-($-page8) dup (0) page8_siz equ (env_nxt-page8)+(1*ENV_SIZE) ;allow room for 1 environment db FREETYPE dw page8_siz-(env_nxt-page8) db page8_siz-($-page8) dup (0) page8_end equ $ ; Assembly area for test programs include sasm.mac align public page7 page7 equ $ db CODETYPE ; Block header dw firstend-page7 db SPECFIX*2 ; Code starting offset dw entry-page7 ; Constant (pointers) go here cstart equ * CSTL equ 0 db 0,0,0 ; "scheme-top-level" symbol goes here CREAD equ 1 db 0,0,0 ; "read" symbol goes here CEOF equ 2 db 0,0,0 ; interned "eof" symbol goes here CINP equ 3 db 0,0,0 ; interned "input-port" symbol goes here COUTP equ 4 db 0,0,0 ; interned "output-port" symbol goes here CCONS equ 5 db 0,0,0 ; interned "console" symbol goes here CNO_PRT equ 6 db 0,0,0 ; interned "*the-non-printing-object*" sym CUGENV equ 7 db 0,0,0 ; interned "user-global-environment" sym CUIENV equ 8 db 0,0,0 ; interned "user-initial-environment" sym ERR_NAME equ 9 db 0,0,0 ; interned "*error-handler*" symbol CWHO equ 10 db 0,0,0 ; interned "pcs-status-window" T_ equ 11 db 0,0,0 ; interned "t" NIL_ equ 12 db 0,0,0 ; interned "nil" ENGINE_ equ 13 db 0,0,0 ; interned "PCS-KILL-ENGINE" CEOFX equ 14 db SPECSYM*2 ; special non-interned "eof" symbol dw eof_sym-page5 CNO_PRTX equ 15 db SPECSYM*2 ; special non-interned "#!unprintable" sym dw non_prt-page5 CUGENVX equ 16 db ENV_PAGE*2 ; pointer to user-global-environment dw g_env-page8 CUIENVX equ 17 db ENV_PAGE*2 ; pointer to user-initial-environment dw u_env-page8 CWHOX equ 18 db SPECPOR*2 ; pointer to "who-line" window object dw stdoutp-page6 CT_ equ 19 db SPECSYM*2 ; pointer to #!true dw t_symbol-page5 ; Entry point follows entry equ $ ; STRINGP_ R2 ; second input argument specified? JNIL_S_ R2,no_debug ; if not, don't begin debug (jump) DEBUG_ ; initiate debug mode no_debug equ $ ; define "eof" LD_CON_ R63,CEOFX DEFINE_ R63,CEOF ; define "*the-non-printing-object*" to "#!unprintable" LD_CON_ R63,CNO_PRTX DEFINE_ R63,CNO_PRT ; define "user-global-environment" to point to said LD_CON_ R63,CUGENVX DEFINE_ R63,CUGENV ; define "user-initial-environment" to point to said LD_CON_ R63,CUIENVX DEFINE_ R63,CUIENV ; define "who-line" LD_CON_ R63,CWHOX DEFINE_ R63,CWHO ; (define t #!true) LD_CON_ R63,CT_ DEFINE_ R63,T_ ; (define nil '()) DEFINE_ R0,NIL_ ; fluid-bind "input-port", "output-port" to 'console LD_CON_ R63,CCONS BIND_FL_ CINP,R63 BIND_FL_ COUTP,R63 ; fluid-bind "scheme-top-level" to nil BIND_FL_ CSTL,R0 ; establish the default error handler LD_CON_ R63,ERR_NAME CLOSE_ R63,err_dflt,0 DEFINE_ R63,ERR_NAME ; establish the default PCS-KILL-ENGINE LD_CON_ R63,ENGINE_ CLOSE_ R63,ret_dflt,0 DEFINE_ R63,ENGINE_ ; check the input parameter to see if it's a filename FASL_ R1 ; fast load first program unit next_rd equ $ COPY_ R8,R0 FASL_ R8 LD_CON_ R9,CEOFX JEQ_S_ R9,R8,end_rd PUSH_ R8 ; save program just read EXECUTE_ R1 ; execute the previously read program POP_ R1 ; restore pointer to most recently read pgm JMP_S_ next_rd ; see if more procedures follow end_rd equ $ EXECUTE_ R1 ; Load program-Create the closure COPY_ R2,R1 ; Copy returned value to R2 SYMBOLP_ R2 ; Was a symbol returned? JNIL_S_ R2,not_sym ; If not, don't try to look it up COPY_ R2,R1 FLUID_P_ R2 JNIL_S_ R2,glob_sym LD_FL_R_ R1,R1 JMP_S_ not_sym glob_sym equ $ LD_GL_R_ R1,R1 ; Look up symbol in global environment not_sym equ $ COPY_ R2,R1 CLOSURP_ R2 JNIL_S_ R2,not_clos CALL_CL_ R1,0 ; Execute the closure not_clos equ $ LD_NIL_ R2 PRINT_ R1,R2 ; Print the result (if any) HALT_ ; Reset Code S_RESET_ ; debugger entry for forced reset reset_x equ $ LD_GLOBAL_ R1,ENGINE_ ; call PCS-KILL-ENGINE CALL_CL_ R1,0 CLR_REG_ ; clear all registers LD_FLUID_ R1,CSTL ; load value for 'scheme-top-level CALL_CL_ R1,0 ; call said closure JMP_S_ reset_x ; if control returns, reset again ; Error Handler Invocation err_rtn equ $ reg_ctr = R1 rept NUM_REGS-1 PUSH_ reg_ctr reg_ctr = reg_ctr+4 endm LD_GLOBAL_ R1,err_name CALL_CL_ R1,0 reg_ctr = (NUM_REGS-1)*4 rept NUM_REGS-1 POP_ reg_ctr reg_ctr = reg_ctr-4 endm EXIT_ err_dflt equ $ DEBUG_ ret_dflt equ $ EXIT_ firstend equ $ ; end of first code block page7_end equ $ data ends end