conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/schemed.asm

607 lines
25 KiB
NASM
Raw Normal View History

Unpack disk3.tgz
2023-05-20 05:57:06 -04:00
; =====> 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