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

Unpack disk3.tgz

This commit is contained in:
Lassi Kortela 2023-05-20 12:57:06 +03:00
parent 3a12151067
commit 777c904054
66 changed files with 30520 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
conio.h Normal file
View File

@ -0,0 +1,16 @@
/**
*
* This header file defines an equivalence between several of the
* standard level 2 I/O functions and their console I/O counterparts.
* Use this header file for programs which perform all of these functions
* to the console only, and need an unbuffered, direct interface to the
* user's console. See Section 3.2.3 of the manual for more information.
*
**/
#define getchar getch
#define putchar putch
#define gets cgets
#define puts cputs
#define printf cprintf
#define scanf cscanf


66
ctype.h Normal file
View File

@ -0,0 +1,66 @@
/**
*
* This header file defines various ASCII character manipulation macros,
* as follows:
*
* isalpha(c) non-zero if c is alpha
* isupper(c) non-zero if c is upper case
* islower(c) non-zero if c is lower case
* isdigit(c) non-zero if c is a digit (0 to 9)
* isxdigit(c) non-zero if c is a hexadecimal digit (0 to 9, A to F,
* a to f)
* isspace(c) non-zero if c is white space
* ispunct(c) non-zero if c is punctuation
* isalnum(c) non-zero if c is alpha or digit
* isprint(c) non-zero if c is printable (including blank)
* isgraph(c) non-zero if c is graphic (excluding blank)
* iscntrl(c) non-zero if c is control character
* isascii(c) non-zero if c is ASCII
* iscsym(c) non-zero if valid character for C symbols
* iscsymf(c) non-zero if valid first character for C symbols
*
**/
#define _U 1 /* upper case flag */
#define _L 2 /* lower case flag */
#define _N 4 /* number flag */
#define _S 8 /* space flag */
#define _P 16 /* punctuation flag */
#define _C 32 /* control character flag */
#define _B 64 /* blank flag */
#define _X 128 /* hexadecimal flag */
extern char _ctype[]; /* character type table */
#define isalpha(c) (_ctype[(c)+1]&(_U|_L))
#define isupper(c) (_ctype[(c)+1]&_U)
#define islower(c) (_ctype[(c)+1]&_L)
#define isdigit(c) (_ctype[(c)+1]&_N)
#define isxdigit(c) (_ctype[(c)+1]&_X)
#define isspace(c) (_ctype[(c)+1]&_S)
#define ispunct(c) (_ctype[(c)+1]&_P)
#define isalnum(c) (_ctype[(c)+1]&(_U|_L|_N))
#define isprint(c) (_ctype[(c)+1]&(_P|_U|_L|_N|_B))
#define isgraph(c) (_ctype[(c)+1]&(_P|_U|_L|_N))
#define iscntrl(c) (_ctype[(c)+1]&_C)
#define isascii(c) ((unsigned)(c)<=127)
#define iscsym(c) (isalnum(c)||(((c)&127)==0x5f))
#define iscsymf(c) (isalpha(c)||(((c)&127)==0x5f))
#define toupper(c) (islower(c)?((c)-('a'-'A')):(c))
#define tolower(c) (isupper(c)?((c)+('a'-'A')):(c))
#define toascii(c) ((c)&127)
/**
*
* Define NULL if it's not already defined
*
*/
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif

476
dos.h Normal file
View File

@ -0,0 +1,476 @@
/**
*
* This header file supplies information needed to interface with the
* particular operating system and C compiler being used.
*
**/
/**
*
* Define NULL if it's not already defined
*
*/
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif
/**
*
* The following symbols specify which operating system is being used.
*
* CPM Any CP/M OS
* CPM80 CP/M for Intel 8080 or Zilog Z80
* CPM86 CP/M for Intel 8086
* CPM68 CP/M for Motorola 68000
* MSDOS Microsoft's MSDOS
*
* Note: CPM will be set to 1 for any of the above.
*
* UNIX "Standard" UNIX
* MIBS General Automation's MIBS OS
*
*/
#if CPM80
#define CPM 1
#endif
#if CPM86
#define CPM 1
#endif
#if CPM68
#define CPM 1
#endif
#if MSDOS
#define CPM 1
#endif
/**
*
* The following definitions specify the particular C compiler being used.
*
* LATTICE Lattice C compiler
*
*/
#define LATTICE 1
/**
*
* The following type definitions take care of the particularly nasty
* machine dependency caused by the unspecified handling of sign extension
* in the C language. When converting "char" to "int" some compilers
* will extend the sign, while others will not. Both are correct, and
* the unsuspecting programmer is the loser. For situations where it
* matters, the new type "byte" is equivalent to "unsigned char".
*
*/
#if LATTICE
typedef unsigned char byte;
#endif
/**
*
* Miscellaneous definitions
*
*/
#define SECSIZ 128 /* disk sector size */
#if CPM
#define DMA (char *)0x80 /* disk buffer address */
#endif
/**
*
* The following structure is a File Control Block. Operating systems
* with CPM-like characteristics use the FCB to store information about
* a file while it is open.
*
*/
#if CPM
struct FCB
{
char fcbdrv; /* drive code */
char fcbnam[8]; /* file name */
char fcbext[3]; /* file name extension */
#if MSDOS
short fcbcb; /* current block number */
short fcblrs; /* logical record size */
long fcblfs; /* logical file size */
short fcbdat; /* create/change date */
char fcbsys[10]; /* reserved */
char fcbcr; /* current record number */
long fcbrec; /* random record number */
#else
char fcbexn; /* extent number */
char fcbs1; /* reserved */
char fcbs2; /* reserved */
char fcbrc; /* record count */
char fcbsys[16]; /* reserved */
char fcbcr; /* current record number */
short fcbrec; /* random record number */
char fcbovf; /* random record overflow */
#endif
};
#define FCBSIZ sizeof(struct FCB)
#endif
/**
*
* The following symbols define the sizes of file names and node names.
*
*/
#if CPM
#define FNSIZE 13 /* maximum file node size */
#define FMSIZE 64 /* maximum file name size */
#define FESIZE 4 /* maximum file extension size */
#else
#define FNSIZE 16 /* maximum file node size */
#define FMSIZE 64 /* maximum file name size */
#define FESIZE 4 /* maximum file extension size */
#endif
/**
*
* The following structures define the 8086 registers that are passed to
* various low-level operating system service functions.
*
*/
#if I8086
struct XREG
{
short ax,bx,cx,dx,si,di;
};
struct HREG
{
byte al,ah,bl,bh,cl,ch,dl,dh;
};
union REGS
{
struct XREG x;
struct HREG h;
};
struct SREGS
{
short es,cs,ss,ds;
};
struct XREGS
{
short ax,bx,cx,dx,si,di,ds,es;
};
union REGSS
{
struct XREGS x;
struct HREG h;
};
#endif
/**
*
* The following codes are returned by the low-level operating system service
* calls. They are usually placed into _OSERR by the OS interface functions.
*
*/
#if MSDOS
#define E_FUNC 1 /* invalid function code */
#define E_FNF 2 /* file not found */
#define E_PNF 3 /* path not found */
#define E_NMH 4 /* no more file handles */
#define E_ACC 5 /* access denied */
#define E_IFH 6 /* invalid file handle */
#define E_MCB 7 /* memory control block problem */
#define E_MEM 8 /* insufficient memory */
#define E_MBA 9 /* invalid memory block address */
#define E_ENV 10 /* invalid environment */
#define E_FMT 11 /* invalid format */
#define E_IAC 12 /* invalid access code */
#define E_DATA 13 /* invalid data */
#define E_DRV 15 /* invalid drive code */
#define E_RMV 16 /* remove denied */
#define E_DEV 17 /* invalid device */
#define E_NMF 18 /* no more files */
#endif
/**
*
* This structure contains disk size information returned by the getdfs
* function.
*/
struct DISKINFO
{
unsigned short free; /* number of free clusters */
unsigned short cpd; /* clusters per drive */
unsigned short spc; /* sectors per cluster */
unsigned short bps; /* bytes per sector */
};
/**
*
* The following structure is used by the dfind and dnext functions to
* hold file information.
*
*/
struct FILEINFO
{
char resv[21]; /* reserved */
char attr; /* actual file attribute */
long time; /* file time and date */
long size; /* file size in bytes */
char name[13]; /* file name */
};
/**
*
* The following structure appears at the beginning (low address) of
* each free memory block.
*
*/
struct MELT
{
struct MELT *fwd; /* points to next free block */
#if SPTR
unsigned size; /* number of MELTs in this block */
#else
long size; /* number of MELTs in this block */
#endif
};
#define MELTSIZE sizeof(struct MELT)
/**
*
* The following structure is a device header. It is copied to _OSCED
* when a critical error occurs.
*
*/
struct DEV
{
long nextdev; /* long pointer to next device */
short attr; /* device attributes */
short sfunc; /* short pointer to strategy function */
short ifunc; /* short pointer to interrupt function */
char name[8]; /* device name */
};
/**
*
* The following structure contains country-dependent information returned
* by the getcdi function.
*
*/
struct CDI2 /* DOS Version 2 format */
{
short fdate; /* date/time format */
/* 0 => USA (h:m:s m/d/y) */
/* 1 => Europe (h:m:s d/m/y) */
/* 2 => Japan (h:m:s d:m:y) */
char curr[2]; /* currency symbol and null */
char sthou[2]; /* thousands separator and null */
char sdec[2]; /* decimal separator and null */
char resv[24]; /* reserved */
};
struct CDI3 /* DOS Version 3 format */
{
short fdate; /* date format */
/* 0 => USA (m d y) */
/* 1 => Europe (d m y) */
/* 2 => Japan (d m y) */
char curr[5]; /* currency symbol, null-terminated */
char sthou[2]; /* thousands separator and null */
char sdec[2]; /* decimal separator and null */
char sdate[2]; /* date separator and null */
char stime[2]; /* time separator and null */
char fcurr; /* currency format */
/* Bit 0 => 0 if symbol precedes value */
/* => 1 if symbol follows value */
/* Bit 1 => number of spaces between value */
/* and symbol */
char dcurr; /* number of decimals in currency */
char ftime; /* time format */
/* Bit 0 => 0 if 12-hour clock */
/* => 1 if 24-hour clock */
long pcase; /* far pointer to case map function */
char sdata[2]; /* data list separator and null */
short resv[5]; /* reserved */
};
union CDI
{
struct CDI2 v2;
struct CDI3 v3;
};
/**
*
* Level 0 I/O services
*
**/
#ifndef NARGS
extern void chgdta(char *);
extern int chgfa(char *, int);
extern int chgft(int, long);
extern int dclose(int);
extern int dcreat(char *, int);
extern int dcreatx(char *, int);
extern int dfind(struct FILEINFO *, char *, int);
extern int dnext(struct FILEINFO *);
extern int dopen(char *, int);
extern unsigned dread(int, char *, unsigned);
extern long dseek(int, long, int);
extern int dunique(char *, int);
extern unsigned dwrite(int, char *, unsigned);
extern int getcd(int,char *);
extern int getch(void);
extern int getche(void);
extern int getdfs(int, struct DISKINFO *);
extern char *getdta(void);
extern int getfa(char *);
extern int getfc(int, int *);
extern long getft(int);
extern int getvfy(void);
extern int kbhit(void);
extern int putch(int);
extern int rlock(int, long, long);
extern void rstdta(void);
extern void rstvfy(void);
extern int runlk(int, long, long);
extern void setvfy(void);
extern int ungetch(int);
#else
extern void chgdta();
extern int chgfa();
extern int chgft();
extern int dclose();
extern int dcreat();
extern int dcreatx();
extern int dfind();
extern int dnext();
extern int dopen();
extern unsigned dread();
extern long dseek();
extern int dunique();
extern unsigned dwrite();
extern int getcd();
extern int getch();
extern int getche();
extern int getdfs();
extern char *getdta();
extern int getfa();
extern int getfc();
extern long getft();
extern int getvfy();
extern int kbhit();
extern int putch();
extern int rlock();
extern void rstdta();
extern void rstvfy();
extern int runlk();
extern void setvfy();
extern int ungetch();
#endif
/**
*
* Miscellaneous external definitions
*
*/
#ifndef NARGS
extern int chgclk(unsigned char *);
extern int chgdsk(int);
extern char *envpack(char **, char **);
extern int envunpk(char *);
#if SPTR
extern unsigned FP_OFF(long);
extern unsigned FP_SEG(long);
#else
extern unsigned FP_OFF(char *);
extern unsigned FP_SEG(char *);
#endif
extern long ftpack(char *);
extern void ftunpk(long, char *);
extern int getbrk(void);
extern int getcdi(int, struct CDI3 *);
extern void getclk(unsigned char *);
extern int getdsk(void);
extern int getpf(char *, char *);
extern int getpfe(char *, char *);
extern unsigned inp(unsigned);
extern int int86(int, union REGS *, union REGS *);
extern int int86s(int, union REGSS *, union REGSS *);
extern int int86x(int, union REGS *, union REGS *, struct SREGS *);
extern int intdos(union REGS *, union REGS *);
extern int intdoss(union REGSS *, union REGSS *);
extern int intdosx(union REGS *, union REGS *, struct SREGS *);
extern int isnet(void);
extern int isnetdc(int);
extern int isnetfh(int);
extern int isneton(void);
extern void makedv(char *, unsigned *, unsigned *);
extern void makepv(int(*)(), unsigned *, unsigned *);
extern void movedata(unsigned, unsigned, unsigned, unsigned, unsigned);
extern int onbreak(int(*)());
extern void onerror(int);
extern void outp(unsigned, unsigned);
extern void peek(unsigned, unsigned, char *, unsigned);
extern void poke(unsigned, unsigned, char *, unsigned);
extern int poserr(char *);
extern void rstbrk(void);
extern void rstdsk(void);
extern int setcdi(int);
extern void setbrk(void);
#else
extern int chgclk();
extern int chgdsk();
extern char *envpack();
extern int envunpk();
extern unsigned FP_OFF();
extern unsigned FP_SEG();
extern long ftpack();
extern void ftunpk();
extern int getbrk();
extern int getcdi();
extern void getclk();
extern int getdsk();
extern int getpf();
extern int getpfe();
extern unsigned inp();
extern int int86();
extern int int86s();
extern int int86x();
extern int intdos();
extern int intdoss();
extern int intdosx();
extern int isnet();
extern int isnetdc();
extern int isnetfh();
extern int isneton();
extern void makedv();
extern void makepv();
extern void movedata();
extern int onbreak();
extern void onerror();
extern void outp();
extern void peek();
extern void poke();
extern int poserr();
extern void rstbrk();
extern void rstdsk();
extern int setcdi();
extern void setbrk();
#endif

193
dos.mac Normal file
View File

@ -0,0 +1,193 @@
.XLIST
PAGE 58,132
;**
;
; This macro library defines the operating environment for the 8086 S
; memory model, which allows 64Kbytes of data and 64Kbytes of program.
;
;**
MSDOS EQU 2
;**
;
; The following symbols define the 8086 memory mode being used. Set LPROG
; to 1 for a large program segment (greater than 64K-bytes), and set LDATA
; to 1 for a large data segment. Set COM to 1 to generate .COM files
; instead of .EXE files. Note that if COM is not zero, then LPROG and
; LDATA must be 0.
;
;**
COM EQU 0
LPROG EQU 0
LDATA EQU 0
;**
;
; The following symbols are established via LPROG and LDATA as follows:
;
; S8086 set for small model (small prog, small data)
; D8086 set for model with large data, small prog
; P8086 set for model with large prog, small data
; L8086 set for large model
;
;**
IF (LPROG EQ 0) AND (LDATA EQ 0)
S8086 EQU 1
D8086 EQU 0
P8086 EQU 0
L8086 EQU 0
ENDIF
IF (LPROG EQ 0) AND (LDATA NE 0)
S8086 EQU 0
D8086 EQU 1
P8086 EQU 0
L8086 EQU 0
ENDIF
IF (LPROG NE 0) AND (LDATA EQ 0)
S8086 EQU 0
D8086 EQU 0
P8086 EQU 1
L8086 EQU 0
ENDIF
IF (LPROG NE 0) AND (LDATA NE 0)
S8086 EQU 0
D8086 EQU 0
P8086 EQU 0
L8086 EQU 1
ENDIF
;**
;
; The DSEG and PSEG macros are defined to generate the appropriate GROUP
; and SEGMENT statements for the memory model being used. The ENDDS and
; ENDPS macros are then used to end the segments.
;
;**
DSEG MACRO
DGROUP GROUP DATA
DATA SEGMENT WORD PUBLIC 'DATA'
ASSUME DS:DGROUP
ENDM
ENDDS MACRO
DATA ENDS
ENDM
IF S8086
PSEG MACRO
PGROUP GROUP PROG
PROG SEGMENT BYTE PUBLIC 'PROG'
ASSUME CS:PGROUP
ENDM
ENDPS MACRO
PROG ENDS
ENDM
ENDIF
IF D8086
PSEG MACRO
CGROUP GROUP CODE
CODE SEGMENT BYTE PUBLIC 'CODE'
ASSUME CS:CGROUP
ENDM
ENDPS MACRO
CODE ENDS
ENDM
ENDIF
IF P8086
PSEG MACRO
_CODE SEGMENT BYTE PUBLIC 'CODE'
ASSUME CS:_CODE
ENDM
ENDPS MACRO
_CODE ENDS
ENDM
ENDIF
IF L8086
PSEG MACRO
_PROG SEGMENT BYTE PUBLIC 'PROG'
ASSUME CS:_PROG
ENDM
ENDPS MACRO
_PROG ENDS
ENDM
ENDIF
;**
;
; The BEGIN and ENTRY macros establish appropriate function entry points
; depending on whether NEAR or FAR program addressing is being used. The
; only difference between the two is that BEGIN generates a PROC operation
; to start a segment.
;
BEGIN MACRO NAME ; begin a function
PUBLIC NAME
IF LPROG
NAME PROC FAR
ELSE
NAME PROC NEAR
ENDIF
ENDM
ENTRY MACRO NAME
PUBLIC NAME
IF LPROG
NAME LABEL FAR
ELSE
NAME LABEL NEAR
ENDIF
ENDM
;**
;
; The following symbols are defined to help set up a STRUC defining the
; stack frame:
;
; CPSIZE -> code pointer size (2 or 4)
; DPSIZE -> data pointer size (2 or 4)
;
; These wouldn't be necessary if it were possible to use macros or even
; conditionals within a STRUC.
;
IF LPROG
CPSIZE EQU 4
ELSE
CPSIZE EQU 2
ENDIF
IF LDATA
DPSIZE EQU 4
ELSE
DPSIZE EQU 2
ENDIF
;
; The SETX macro sets the symbol X to 4 if LPROG is 0 or to 6 otherwise.
; X can then be used to skip past the BP and return address save area
; in the stack frame when accessing the function arguments.
;
SETX MACRO
IF LPROG
X EQU 6
ELSE
X EQU 4
ENDIF
ENDM
;
; The PEXTRN macro defines an external pointer in the data segment.
;
PEXTRN MACRO NAME
IF LDATA
EXTRN NAME:DWORD
ELSE
EXTRN NAME:WORD
ENDIF
ENDM
.LIST

2
freesp.equ Normal file
View File

@ -0,0 +1,2 @@
dog equ 1


167
math.h Normal file
View File

@ -0,0 +1,167 @@
/**
*
* Structure to hold information about math exceptions
*
*/
struct exception
{
int type; /* error type */
char *name; /* math function name */
double arg1, arg2; /* function arguments */
double retval; /* proposed return value */
};
/*
*
* Exception type codes, found in exception.type
*
*/
#define DOMAIN 1 /* domain error */
#define SING 2 /* singularity */
#define OVERFLOW 3 /* overflow */
#define UNDERFLOW 4 /* underflow */
#define TLOSS 5 /* total loss of significance */
#define PLOSS 6 /* partial loss of significance */
/**
*
* Error codes generated by basic arithmetic operations (+ - * /)
*
*/
#define FPEUND 1 /* underflow */
#define FPEOVF 2 /* overflow */
#define FPEZDV 3 /* zero divisor */
#define FPENAN 4 /* not a number (invalid operation) */
#define FPECOM 5 /* not comparable */
/**
*
* Constants
*
*/
#define PI 3.14159265358979323846
#define PID2 1.57079632679489661923 /* PI divided by 2 */
#define PID4 0.78539816339744830962 /* PI divided by 4 */
#define I_PI 0.31830988618379067154 /* Inverse of PI */
#define I_PID2 0.63661977236758134308 /* Inverse of PID2 */
#define HUGE 1.797693e308 /* huge value */
#define TINY 2.2e-308 /* tiny value */
#define LOGHUGE 709.778 /* natural log of huge value */
#define LOGTINY -708.396 /* natural log of tiny value */
/**
*
* External declarations
*
*/
extern int _FPERR; /* floating point arithmetic error */
extern int errno; /* UNIX error code */
#ifndef NARGS
extern double acos(double);
extern double asin(double);
extern double atan(double);
extern double atan2(double, double);
extern double atof(char *);
extern double ceil(double);
extern double cos(double);
extern double cosh(double);
extern void CXFERR(int);
extern double drand48(void);
extern char *ecvt(double, int, int *, int *);
extern double erand48(short *);
extern double except(int, char *, double, double, double);
extern double exp(double);
extern double fabs(double);
extern char *fcvt(double, int, int *, int *);
extern double floor(double);
extern double fmod(double, double);
extern double frexp(double, int *);
extern char *gcvt(double, int, char *);
extern long jrand48(short *);
extern double ldexp(double, int);
extern void lcong48(short *);
extern double log(double);
extern double log10(double);
extern long lrand48(void);
extern int matherr(struct exception *);
extern double modf(double, double *);
extern long mrand48(void);
extern long nrand48(short *);
extern double pow(double, double);
extern int rand(void);
extern short *seed48(short *);
extern double sin(double);
extern double sinh(double);
extern double sqrt(double);
extern void srand(unsigned);
extern void srand48(long);
extern double tan(double);
extern double tanh(double);
#else
extern double acos();
extern double asin();
extern double atan();
extern double atan2();
extern double atof();
extern double ceil();
extern double cos();
extern double cosh();
extern void CXFERR();
extern double drand48();
extern char *ecvt();
extern double erand48();
extern double except();
extern double exp();
extern double fabs();
extern char *fcvt();
extern double floor();
extern double fmod();
extern double frexp();
extern char *gcvt();
extern long jrand48();
extern void lcong48();
extern double ldexp();
extern double log();
extern double log10();
extern long lrand48();
extern int matherr();
extern double modf();
extern long mrand48();
extern long nrand48();
extern double pow();
extern int rand();
extern short *seed48();
extern double sin();
extern double sinh();
extern double sqrt();
extern void srand();
extern void srand48();
extern double tan();
extern double tanh();
#endif
/**
*
* Macros
*
*/
#define abs(x) ((x)<0?-(x):(x))
#define max(a,b) ((a)>(b)?(a):(b))
#define min(a,b) ((a)<=(b)?(a):(b))
/**
*
* Define NULL if it's not already defined
*
*/
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif

17
memtype.equ Normal file
View File

@ -0,0 +1,17 @@
IFDEF REGMEM
MIN_PAGESIZE EQU 0C00H ; Minimum page size for conventional memory
ENDIF
IFDEF EXPMEM
MIN_PAGESIZE EQU 04000h ; Minimum page size for expanded memory
ENDIF
IFDEF EXTMEM
MIN_PAGESIZE EQU 04000h ; Minimum page size for extended memory
ENDIF
IFDEF PROMEM
MIN_PAGESIZE EQU 0C00h ; Minimum page size for protected memory
MAX_PAGESIZE EQU 07FF0h ; Maximum page size for protected memory
ENDIF


17
memtype.h Normal file
View File

@ -0,0 +1,17 @@
#ifdef REGMEM
#define MIN_PAGESIZE 0x0C00
#endif
#ifdef EXPMEM
#define MIN_PAGESIZE 0x4000
#endif
#ifdef EXTMEM
#define MIN_PAGESIZE 0x4000
#endif
#ifdef PROMEM
#define MIN_PAGESIZE 0x0C00
#define MAX_PAGESIZE 0x7FF0
#endif


12
pcmake.equ Normal file
View File

@ -0,0 +1,12 @@
;
; A list of EQU's for the various types of PCs
;
UNKNOWN equ 0
TIPC equ 1
IBMPC equ 0ffh
IBMXT equ 0feh
IBMJR equ 0fdh
IBMAT equ 0fch ;IBM PC-AT
IBM80 equ 0f8h ;IBM PS/2 Model 80
IBMTYPE equ 0f0h ;IBM machine types >= this value


10
pcmake.h Normal file
View File

@ -0,0 +1,10 @@
/* A list of DEFINES's for the various types of PCs */
#define UNKNOWN 0
#define TIPC 1
#define IBMPC 0x0ff
#define IBMXT 0x0fe
#define IBMJR 0x0fd
#define IBMAT 0x0fc
#define IBM80 0xf8h ;IBM PS/2 Model 80
#define IBMTYPE 0xf0h ;IBM machine types >= this value


1403
prosprin.asm Normal file
View File

File diff suppressed because it is too large Load Diff

888
prosread.asm Normal file
View File

@ -0,0 +1,888 @@
; =====> PROSREAD.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* S-Expression reading *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* Last Modification: 10 Feb 1987 *
;* *
;* tc 2/10/87 fix to convert first *
;* char after # to upper case *
;* tc 2/10/87 added support to do *
;* readline *
;***************************************
page 60,132
include scheme.equ
include sinterp.arg
SPACE equ 20h
CTRL_Z equ 1Ah
LINEFEED equ 0Ah
RETURN equ 0Dh
COM equ 3Bh
BK_SLASH equ 5Ch
BUFSIZE equ 256
TEST_NUM equ 8
EOFERR equ 1
SHARPERR equ 7
PORTERR equ -2
HEAPERR equ -3
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public test_ch, t_array
extrn locases:word
extrn hicases:word
extrn CXFERR_s:word
extrn port_r:word
srd_str db "READ-ATOM",0
sln_str db "READ-LINE",0
inv_char db "Invalid character constant",0
limit dw ? ; current size of atom buffer
main_reg dw ? ; main register
flg_eof dw ? ; whether to flag end-of-file
atomb dw ? ; atom buffer
test_ch db 0Ah,20h,7Fh,0Ch,09h,08h,0Dh,1Bh ; special characters
char db 20h ; most recently received char
t_str1 db "NEWLINE",0
t_str2 db "SPACE",0
t_str3 db "RUBOUT",0
t_str4 db "PAGE",0
t_str5 db "TAB",0
t_str6 db "BACKSPACE",0
t_str7 db "RETURN",0
t_str8 db "ESCAPE",0
t_array dw t_str1
dw t_str2
dw t_str3
dw t_str4
dw t_str5
dw t_str6
dw t_str7
dw t_str8
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;;;***************************************************************************
;;; Support for read-line
;;;***************************************************************************
rln_proc proc
extrn next_SP:near
extrn src_err:near
public srd_line
srd_line: lods byte ptr ES:[SI]
save <SI>
add AX,offset reg0 ; compute register address
mov main_reg,AX
xor BX,BX
push BX
push AX
C_call get_port,,Load_ES ; get the port object
mov SP,BP ; get the return status
test AX,AX ; error returned?
jnz srd_lerr
pushm <tmp_disp,tmp_page,main_reg>
call sread_ln ; get a line
mov SP,BP
jmp next_SP ; return to interpreter
;
srd_lerr: lea BX,sln_str
jmp src_err ; link to error handler
rln_proc endp
;;;***************************************************************************
;;; Set up for the operation of reading a single line from the given port.
;;;***************************************************************************
extrn setabort:near
extrn abort:near
extrn ssetadr:near
srdlnarg struc
temp_r dw ? ; temporary storage
srdln_BP dw ? ; caller's BP
dw ? ; caller's return address
rp_reg dw ? ; port register
rpg dw ? ; adjusted page number
rdisp dw ? ; displacement
srdlnarg ends
;
public sread_at
sread_ln proc near
push BP
sub SP, offset srdln_BP ; allocate local storage
mov BP,SP
call setabort ; save stack pointer
pushm <[BP].rdisp,[BP].rpg>
call ssetadr ; set port address
mov SP,BP
test AX,AX ; check return status
jz srdl_010
mov AX,PORTERR ; port error
push AX
call abort
;
mov flg_eof,1 ; flag eof
srdl_010:
call rcvchar ; get char, eof won't return here
cmp AL,LINEFEED ; is char linefeed?
je srdl_010 ; if so, ignore
mov [BP].temp_r,AX ; save character read
mov AX,BUFSIZE ; Get buffer size
mov limit,AX
push AX
C_call getmem ; allocate buffer
mov SP,BP
cmp AX,0 ; memory available?
jne srdl_020
;error allocate C heap space
mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp srdln_ret
srdl_020: mov SI,AX
mov atomb,AX ; address of buffer
mov flg_eof,0 ; don't flag error on EOF
xor BX,BX ; index into buffer
mov AX,[BP].temp_r ; restore saved character
; read characters
srdln_cha:
cmp AL,RETURN ; Return character?
je srdln_ret ; yes, return
cmp AL,CTRL_Z ; EOF character?
je srdln_ret ; yes, return
cmp AL,LINEFEED ; Linefeed character?
je srdln_ret ; yes, don't put in atomb
pushm <AX,BX>
call addchar ; Add character to buffer
mov SP,BP
inc BX
srdln_nxt:
call rcvchar ; Get next character
jmp srdln_cha ; Go get next character
srdln_ret:
mov CX,STRTYPE ; Allocate string data type
mov [BP].temp_r,BX
pushm <BX,CX,main_reg>
c_call alloc_bl,,Load_ES
mov SP,BP
mov CX,3 ; Copy buffer to Scheme string
mov SI,atomb
pushm <[BP].temp_r,SI,CX,main_reg>
call toblock
mov AX,limit ; Release buffer
pushm <AX,atomb>
C_call rlsmem
mov SP,BP
mov flg_eof,1 ; Reset flags
mov limit,0
add SP,offset srdln_BP ; Deallocate local storage
pop BP
ret ; Return
sread_ln endp
;;;***************************************************************************
;;; Support for read-atom
;;;***************************************************************************
rds_proc proc
extrn next_SP:near
extrn src_err:near
public srd_atom
srd_atom: lods byte ptr ES:[SI]
save <SI>
add AX,offset reg0 ; compute register address
mov main_reg,AX
xor BX,BX
push BX
push AX
C_call get_port,,Load_ES ; get the port object
mov SP,BP ; get the return status
test AX,AX ; error returned?
jnz srd_err
pushm <tmp_disp,tmp_page,main_reg>
call sread_at ; sread_atom()
mov SP,BP
jmp next_SP ; return to interpreter
;
srd_err: lea BX,srd_str
jmp src_err ; link to error handler
rds_proc endp
;;;***************************************************************************
;;; Set up for the operation of reading a single atom from the given port.
;;; Special characters such as ')' are parsed as lists(!) to tell them from
;;; ordianry atoms.
;;;***************************************************************************
extrn setabort:near
extrn abort:near
extrn ssetadr:near
sreadarg struc
dw ? ; caller's BP
dw ? ; caller's return address
p_reg dw ? ; port register
pg dw ? ; adjusted page number
disp dw ? ; displacement
sreadarg ends
;
public sread_at
sread_at proc near
push BP
mov BP,SP
call setabort ; save stack pointer
mov BX,[BP].p_reg ;be certain main_reg gets set if
;sread_at gets called directly from C
mov main_reg,BX
pushm <[BP].disp,[BP].pg>
call ssetadr ; set port address
mov SP,BP
test AX,AX ; check return status
jz srd_010
mov AX,PORTERR ; port error
push AX
call abort
;
srd_010: mov flg_eof,1 ; initialization
mov limit,0
; skip spaces
srd_spa: call rcvchar
call ck_space ; check for space
test CX,CX
jz srd_spa ; yes, skip
; skip comments
srd_com: cmp AL,COM ; check for comment
jne srd_at
srd_c10: call rcvchar
cmp AL,RETURN
jne srd_c10 ; yes, ignore the whole line
jmp srd_spa
;
srd_at: test AL,AL ; null character?
jz srd_spa
call read_ato
pop BP
ret
sread_at endp
;;;***************************************************************************
;;; Fetch one character from the input stream
;;;***************************************************************************
extrn take_ch:near
rcvchar proc near
pop DX ; fetch return address
;
push DX ; save registers
push SI
push DI
push CX
push BX
call take_ch ; takechar()
pop BX ; restore registers
pop CX
pop DI
pop SI
pop DX
; Check the character
cmp AX,256
jge rcv_10
cmp AL,CTRL_Z ; EOF character?
je rcv_10 ; yes, jump
mov char,AL
jmp DX ; return to caller
; EOF character is fetched
rcv_10: cmp flg_eof,0 ; EOF flag set?
jne rcv_20 ; yes, error
mov AX,CTRL_Z
mov char,AL
jmp DX ; return to caller
;
rcv_20: mov AX,EOFERR
push AX
call abortrea ; abortread(EOFERR)
rcvchar endp
;;;***************************************************************************
;;; Read in an atom (symbol, string, number)
;;; Store the pointer to the atom in REG.
;;; Special characters such as ')' or ',' are read as atoms themselves.
;;; Normal atoms will end in a whitespace or a terminating macro character;
;;; strings end with the closing '"'.
;;; Numbers in the requested base are interpreted as such.
;;; On exit, the next character in the buffer is the one following the last
;;; character of the atom.
;;;***************************************************************************
extrn toblock:near
extrn cons:near
extrn buildint:near
extrn alloc_st:near
extrn scannum:near
extrn pushchar:near
readarg struc
num_base dw ? ; base of number
tmpreg dw ?
inputch dw ? ; whether the #\ macro is in effect
escaped dw ? ; whether an escape char is used
inflo dq ? ; for floating point value
bignum dw ?
biglimit dw ?
read_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
readarg ends
;
read_ato proc near
push ES
push BP
sub SP,offset read_BP ; allocate local storage
mov BP,SP
xor CX,CX
mov [BP].tmpreg,AX
;;; cmp AL,SPACE ; check for space?
;;; jne read_at
;;; mov [DI].C_page,CX ; yes, form NIL and return
;;; mov [DI].C_disp,CX
;;; jmp read_end
read_at: mov flg_eof,CX ; initialization
mov [BP].inputch,CX
mov [BP].escaped,CX
mov CXFERR_s,CX
mov AX,BUFSIZE
mov limit,AX
mov [BP].num_base,10
push AX
C_call getmem ; allocate memory
mov SP,BP
cmp AX,0 ; memory available?
jne read_01
memerr: mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp read_ret
read_01: mov SI,AX
mov atomb,AX ; save the address of atom buffer
mov DI,main_reg
xor BX,BX
mov AX,[BP].tmpreg
; check for the special character first
cmp AL,5Bh ; [
je read_10
cmp AL,5Dh ; ]
je read_10
cmp AL,7Bh ; {
je read_10
cmp AL,7Dh ; }
je read_10
cmp AL,28h ; (
je read_10
cmp AL,29h ; )
je read_10
cmp AL,27h ; '
je read_10
cmp AL,60h ; `
jne read_st
; special character case
read_10: mov [SI],AL ; *atomb = ch
inc BX
jmp read_sp
;
read_st: cmp AL,22h ; "
jne read_co
; string case
push AX
call delimby ; get the string
mov SP,BP
mov [BP].tmpreg,BX ; save BX register
mov CX,STRTYPE
pushm <BX,CX,main_reg>
C_call alloc_bl,,Load_ES ; allocate string object
mov SP,BP
mov CX,3
mov SI,atomb
pushm <[BP].tmpreg,SI,CX,main_reg>
call toblock ; copy string to string object
jmp read_bye
;
read_co: cmp AL,2Ch ; ,
jne read_mac
; comma case
mov [SI],AL
inc BX
call rcvchar ; get the next character
cmp AL,40h ; check for @
je read_20
cmp AL,2Eh ; check for .
je read_20
jmp read_nor
read_20: mov [SI+BX],AL
inc BX
jmp read_sp
;
read_mac: cmp AL,23h ; #
je read_25
jmp read_sym
; macro case
read_25: mov flg_eof,1
read_30: test BX,BX ; first character?
jz read_34
read_32: jmp read_200 ; no, jump
;
read_34: cmp AL,23h ; #
jne read_32 ; no, jump
call rcvchar ; get the next character
call ck_space ; check for space
test CX,CX
jnz read_40
read_35: mov AX,SHARPERR ; yes, error
push AX
call abortrea
;
read_40: mov byte ptr [SI+1],AL ; save the character
push BX
mov BX,offset locases ; address of lower-case characters
xlat
pop BX ; restore registers
cmp AL,62h ; b?
jne read_d
mov [BP].num_base,2
jmp read_100
;
read_d: cmp AL,64h ; d?
jne read_x
mov [BP].num_base,10
jmp read_100
;
read_x: cmp AL,78h ; x?
je read_50
cmp AL,68h ; h?
jne read_o
read_50: mov [BP].num_base,16
jmp read_100
;
read_o: cmp AL,6Fh ; o?
jne read_ba
mov [BP].num_base,8
jmp read_100
;
read_ba: cmp AL,BK_SLASH ; \?
jne read_i
call rcvchar
pushm <AX,BX>
call addchar
mov SP,BP
inc BX
mov [BP].inputch,1
mov [BP].escaped,1
jmp read_100
;
read_i: cmp AL,69h ; i?
je read_100
cmp AL,65h ; e?
je read_100
cmp AL,73h ; s?
je read_100
cmp AL,6Ch ; l?
je read_100
cmp AL,3Ch ; <?
je read_60 ; yes, error
cmp AL,29h ; )?
jne read_70
read_60: jmp read_35 ; yes, error
;
read_70: mov byte ptr [SI],23h ; default
mov BX,offset hicases ; address of higher-case characters
xlat
mov byte ptr [SI+1],AL ; Change letter past # to upper case
mov BX,2
cmp AL,28h ; check for (
jne read_100
jmp read_sp ; yes, special case
;
read_100: call rcvchar ; get the next character
jmp read_30
;
read_200: mov flg_eof,0
; handle for symbol
read_sym: ; default
call ck_space ; check for space
test CX,CX
jz read_en ; yes, jump
cmp AL,CTRL_Z ; eof character?
je read_en
cmp AL,28h ; (
je read_en
cmp AL,29h ; )
je read_en
cmp AL,27h ; '
je read_en
cmp AL,60h ; `
je read_en
cmp AL,COM ; comment?
je read_en
cmp AL,2Ch ; ,
je read_en
cmp AL,22h ; "
je read_en
cmp AL,5Bh ; [
je read_en
cmp AL,5Dh ; ]
je read_en
cmp AL,7Bh ; {
je read_en
cmp AL,7Dh ; }
je read_en
push BX
mov BX,offset hicases ; address of higher-case characters
xlat
pop BX
cmp AL,7Ch ; |?
jne read_210
mov [BP].escaped,1
push AX
call delimby ; read the whole symbol
mov SP,BP
jmp read_250
;
read_210: cmp AL,BK_SLASH ; \?
jne read_220
mov [BP].escaped,1
mov flg_eof,1
call rcvchar
mov flg_eof,0
read_220: pushm <AX,BX>
call addchar
mov SP,BP
inc BX
read_250: call rcvchar ; get the next character
jmp read_sym
;
read_en: xor AL,AL ; put null at end of token
pushm <AX,BX>
call addchar
mov SP,BP
; Check for single, unescaped dot
cmp BX,1
jne read_num
cmp byte ptr [SI],2Eh ; check for .
jne read_num
cmp [BP].escaped,1
je read_num
jmp read_nor
; At this point a token has been accumulated, check for number
read_num: mov [BP].tmpreg,BX ; save BX register
push [BP].num_base
push SI
call scannum ; scan number
mov SP,BP
mov SI,atomb ; restore SI register
mov BX,[BP].tmpreg ; restore BX register
test AX,AX ; number or not?
jnz read_n05
jmp read_500
read_n05: cmp [BP].escaped,1
jne read_n07
jmp read_500
read_n07: cmp AX,0
jle read_300 ; negative for floating point number
; integer of some size
add AX,9 ; (AX + 9) / 2
shr AX,1 ; AX = bytes needed for integer
mov [BP].biglimit,AX ; save for later
push AX
C_call getmem ; allocate memory for bignum
mov SP,BP
cmp AX,0 ; memory available?
jne read_n10
jmp memerr ; no, error
read_n10: mov BX,AX
mov [BP].bignum,AX
mov byte ptr [BX+3],0
mov byte ptr [BX+4],0
pushm <[BP].num_base, atomb, BX>
call buildint ; form integer
mov SP,BP
mov DI,main_reg
mov BX,[BP].bignum
pushm <BX,DI>
C_call alloc_in,,Load_ES ; alloc_int
mov SP,BP
pushm <[BP].biglimit,[BP].bignum>
C_call rlsmem ; release memory for bignum
mov SP,BP
jmp read_rls
; Floating point number
read_300: lea DX,[BP].inflo
pushm <[BP].num_base, DX, SI>
C_call scanflo,,Load_ES ; scan the flonum
mov SP,BP
mov DI,main_reg
lea BX,[BP].inflo
pushm <[BX+6],[BX+4],[BX+2],[BX]> ; push flonum value
push DI
C_call alloc_fl,,Load_ES ; alloc_flonum
mov SP,BP
jmp read_rls
; Allocate character or interned symbol
read_500: cmp [BP].inputch,0 ; #\ macro?
mov DI,main_reg
jne read_510
jmp read_600 ; no, symbol
read_510: mov [DI].C_page,SPECCHAR*2
cmp BX,1 ; only one character?
jne read_mul ; no, jump
xor AH,AH
mov AL,byte ptr [SI]
mov [DI].C_disp,AX ; return the character
jmp read_rls
; Check for a multichar character constant
read_mul: mov AL,byte ptr [SI]
mov BX,offset hicases ; address of higher-case characters
xlat
mov byte ptr [SI],AL
xor BX,BX
read_515: cmp BL,TEST_NUM ; finish the comparison?
je read_580 ; yes, jump
lea DI,t_array ; save BX register
mov CX,BX
shl BX,1 ; get the word offset
mov DI,word ptr [DI+BX] ; address of special string
xor BX,BX
read_520: mov AL,byte ptr [DI+BX] ; get the character in string
cmp AL,0 ; end of string
je read_530 ; match
cmp byte ptr [SI+BX],AL
jne read_540
inc BX
jmp read_520
read_530: mov BX,CX
lea SI,test_ch ; address of special characters
mov AL,byte ptr [SI+BX]
mov DI,main_reg
mov [DI].C_disp,AX ; return the special character
jmp read_rls
;
read_540: mov BX,CX
inc BX
jmp read_515
; For the unrecognized multi-char character constant, return #\?
read_580: mov DI,main_reg
mov [DI].C_disp,3Fh ; return '?' character
;;; push SI
;;; lea BX,tmp_reg
;;; push BX
;;; C_call alloc_st,,Load_ES ; alloc_string for error message
;;; mov SP,BP
;;; lea BX,tmp_reg
;;; push BX
;;; lea BX,inv_char
;;; push BX
;;; xor BX,BX
;;; push BX
;;; C_call set_erro,,Load_ES ; set_error
;;; mov SP,BP
mov CXFERR_s,-1 ; error status
jmp read_rls
; Not a character, but a symbol
read_600: push BX ; length of symbol
push SI ; address of symbol
push DI ; register
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
jmp read_rls
;
read_sp: pushm <BX, SI, DI>
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
lea BX,nil_reg
mov DI,main_reg
pushm <BX, DI, DI>
call cons ; encase in a list
mov SP,BP
jmp read_bye
;
read_nor: pushm <BX, SI, DI>
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
lea BX,nil_reg
mov DI,main_reg
pushm <BX, DI, DI>
call cons ; encase in a list
mov SP,BP
read_rls: cmp char,CTRL_Z ; EOF character?
je read_bye
call pushchar ; put post-atom char back to buffer
;
read_bye: mov AX,limit
pushm <AX, atomb>
C_call rlsmem ; release memory
mov SP,BP
mov flg_eof,1 ; reset flags
mov limit,0
;
read_end: mov AX,CXFERR_s ; return status
read_ret: add SP,offset read_BP ; release local storage
pop BP
pop ES
ret
read_ato endp
;;;************************************************************************
;;; DELIMBY(c)
;;; DELIMBY takes characters from the input stream and places them
;;; in the buffer ATOMB, starting at offset stored in BX register, and
;;; ending when the delimiting character C is reached.
;;; Note: SI = address of atomb
;;; BX = number of characters in atomb
;;;************************************************************************
deliarg struc
dw ? ; caller's BP
dw ? ; caller's return address
cha dw ? ; character
deliarg ends
delimby proc near
push BP ; get the return address
mov BP,SP
mov flg_eof,1 ; signal the EOF error
call rcvchar
deli_10: mov CX,[BP].cha
cmp AL,CL ; reach the end?
je deli_50 ; yes, return
cmp AL,RETURN ; carriage return?
je deli_40 ; yes, ignore
cmp AL,BK_SLASH ; check for \
jne deli_30
call rcvchar ; yes, ignore
deli_30: pushm <AX,BX>
call addchar
mov SP,BP
inc BX
deli_40: call rcvchar ; get the next character
jmp deli_10
deli_50: mov flg_eof,0
pop BP
ret
delimby endp
;;;************************************************************************
;;; ADDCHAR (i, c)
;;; ADDCHAR takes the character c and places it in the dynamic
;;; atom buffer atomb, at offset i. If the buffer can not contain
;;; any more characters, additional space is allocated, and limit
;;; is adjusted accordingly.
;;;************************************************************************
addarg struc
add_tmp dw ?
add_BP dw ? ; caller's BP
dw ? ; caller's return address
index dw ?
chara dw ?
addarg ends
addchar proc near
push BP
sub SP,offset add_BP ; allocate local storage
mov BP,SP
mov BX,[BP].index
cmp BX,limit ; room for character?
jge add_10 ; no, jump
add_01: mov AX,[BP].chara
mov byte ptr [SI+BX],AL
add_ret: add SP,offset add_BP
pop BP
ret
add_10: mov AX,limit
add AX,BUFSIZE
push AX
C_call getmem ; allocate memory
mov SP,BP
cmp AX,0 ; memory available?
jne add_20
mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp add_ret
add_20: mov DI,AX ; address of new buffer
mov SI,atomb
mov CX,limit
rep movsb ; copy characters
mov [BP].add_tmp,AX ; save buffer pointer
pushm <limit, atomb>
C_call rlsmem ; discard the old buffer
mov SP,BP
mov SI,[BP].add_tmp
mov atomb,SI
mov CX,limit
add CX,BUFSIZE ; increase the limit
mov limit,CX
mov BX,[BP].index
jmp add_01
addchar endp
;;;************************************************************************
;;; ABORTREAD(code)
;;; Cancels the entire read operation via ABORT, after
;;; resetting some vital registers.
;;; Note: DI = address of main register
;;;************************************************************************
abortarg struc
dw ? ; caller's BP
dw ? ; caller's return address
errcode dw ? ; error code
abortarg ends
abortrea proc near
push BP
mov BP,SP
mov DI,main_reg ; main register
cmp [BP].errcode,EOFERR ; EOF error?
jne ab_010
mov [DI].C_page,EOF_PAGE*2 ; return eof indicator
mov [DI].C_disp,EOF_DISP
jmp ab_020
;
ab_010: xor AX,AX
mov [DI].C_page,AX ; NUL main register
mov [DI].C_disp,AX
;
ab_020: push [BP].errcode
call abort
pop BP
ret
abortrea endp
;;;**********************************************************************
;;; Local support to check the character in AX is space or not
;;; Note: CX = 0 iff the character is whitespace
;;;**********************************************************************
ck_space proc near
pop DX ; get the return address
xor CX,CX
cmp AL,SPACE ; space?
je is
cmp AL,9
jb isnot
cmp AL,0Dh
jbe is
isnot: inc CX
is: jmp DX ; return to caller
ck_space endp
prog ends
end


548
prowin.asm Normal file
View File

@ -0,0 +1,548 @@
; =====> PROWIN.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* Window I/O support *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* Last Modification: 24 March 1986 *
;* 7 Jan 1987 - dbs *
;* added random I/O *
;***************************************
page 60,132
include scheme.equ
include sinterp.arg
include screen.equ
BUFFSIZE equ 256 ; input/output buffer
WINDSIZE equ 32-BLK_OVHD
PORTATTR equ 62
LABEL equ 32+BUFFSIZE ; window label field
P_FLAGS equ 6
W_FLAGS equ 26
WINDOW equ 4
B_ATTR equ 22
T_ATTR equ 24
CUR_LINE equ 10
CUR_COL equ 12
UL_LINE equ 14
UL_COL equ 16
N_LINES equ 18
N_COLS equ 20
NUM_FLDS equ 12
CHUNK equ 14
STR_PTR equ 3
OPEN equ 8
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn port_pg:word,port_ds:word
public MAX_ROWS,MAX_COLS
bad_port db "[VM INTERNAL ERROR] Bad port for window output",CR,LF,0
mk_win_st db "%MAKE_WINDOW",0
sv_win_st db "WINDOW-SAVE-CONTENTS",0
rt_win_st db "WINDOW-RESTORE-CONTENTS",0
gt_win_st db "%REIFY-PORT",0
cl_win_st db "WINDOW_CLEAR",0
defaults dw 0,0,0,0 ; default values of window object
max_rows db DEFAULT_NUM_ROWS,0
max_cols db DEFAULT_NUM_COLS,0
dw -1,15,1,0,0
wnlines dw 0 ; number of lines
wncols dw 0 ; number of columns
wulline dw 0 ; upper-left line number
wulcol dw 0 ; upper-left column number
branchtab dw setw_20 ; [0] : cursor line
dw setw_20 ; [1] : cursor column
dw setw_30 ; [2] : upper left corner line
dw setw_40 ; [3] : upper left corner column
dw setw_50 ; [4] : number of lines
dw setw_60 ; [5] : number of columns
dw setw_100 ; [6] : border attribute
dw setw_100 ; [7] : text attribute
dw setw_100 ; [8] : flags
dw setw_100 ; [9] : buffer position
dw setw_100 ; [10] : buffer end
dw setw_100 ; [11] : port flag
dw setw_70 ; [12] : # of chunks
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
extrn rest_scr:near
extrn save_scr:near
win_proc proc near
;;;************************************************************************
;;; Allocate a window object
;;;************************************************************************
extrn zero_blk:near
extrn next_SP:near
extrn src_err:near
extrn adj4bord:near
public make_win
make_win: lods byte ptr ES:[SI] ; load the operand register
save <SI>
add AX,offset reg0 ; compute register address
mov BX,AX
mov SI,[BX].C_disp ; get displacement
mov BX,[BX].C_page ; get page number
mov tmp_disp,SI ; save window label pointer
mov tmp_page,BX
cmp byte ptr ptype+[BX],STRTYPE*2 ; check string type
jne make_err
jmp short make_020
make_err: test BX,BX
jz make_020 ; null window label
lea BX,mk_win_st ; load address of text
jmp src_err ; display error message
make_020: mov BX,BUFFSIZE+WINDSIZE ; get object length
mov CX,PORTTYPE ; port type
pushm <BX,CX,AX>
C_call alloc_bl,,Load_ES ; allocate block for window object
pop BX
mov DI,[BX].C_disp ; get displacement
save <DI>
mov BX,[BX].C_page ; get page numbe of window object
LoadPage ES,BX ; get page address
shr BX,1
pushm <DI, BX>
call zero_blk ; zero window object
restore <DI>
mov word ptr ES:[DI+6],PORTATTR ; store port attribute
mov AX,DI
add DI,10 ; position to move default values
lea SI,defaults ; address of default values
mov CX,NUM_FLDS-1 ; length of defaults
rep movsw ; move defaults into object
mov DI,AX
mov AX,tmp_page
mov BX,tmp_disp
mov byte ptr ES:[DI+STR_PTR],AL ; store window label pointer
mov word ptr ES:[DI+STR_PTR+1],BX
jmp next_SP
;;;************************************************************************
;;; Get Window Attributes
;;; Get Window Attributes was translated from C. The following C comments
;;; show the mappings of the arguments to get-window-attributes to their
;;; actual locations within the port object.
;;;
;;;
;;;#define NUM_FIELDS 12
;;;static int defaults[NUM_FIELDS] = {0, /* cursor line number */
;;; 0, /* cursor column number */
;;; 0, /* upper left corner line number */
;;; 0, /* upper left corner column number */
;;; 25, /* number of lines */
;;; 80, /* number of columns */
;;; -1, /* no border */
;;; 15, /* text high intensity, enable */
;;; 1, /* wrap enabled */
;;; 0, /* current buffer position */
;;; 0, /* current buffer end */
;;;TRANSCRIPT+BINARY+WINDOW+OPEN+READ_WRITE}; /* port attributes */
;;;static int map_attr[NUM_FIELDS] = {10,12,14,16,18,20,22,24,26,28,30,6};
;;;
;;;************************************************************************
public get_wind
get_wind: lods word ptr ES:[SI] ; load register operand
save <SI> ; save the location pointer
xor BX,BX
mov BL,AH
add BX,offset reg0 ; compute address of register
xor AH,AH
add AX,offset reg0
save <AX> ; save registers
save <BX>
mov CX,1
pushm <CX, AX>
C_call get_port,,Load_ES ; get the port object
mov SP,BP
mov SI,tmp_page
cmp byte ptr ptype+[SI],PORTTYPE*2
jne get_err
restore <BX>
cmp [BX].C_page,SPECFIX*2
jne get_err
mov BX,word ptr [BX].C_disp ; get the value
shl BX,1
sar BX,1
cmp BX,0
jl get_err
cmp BX,NUM_FLDS
jg get_err ; used to be jge - dbs
LoadPage ES,SI ; get page address
mov SI,tmp_disp
restore <AX>
mov DI,AX
mov word ptr [DI].C_page,SPECFIX*2
cmp BX,12
jne get_05
mov AX,word ptr ES:[SI+CHUNK]; get chunk number
jmp get_20
get_05: cmp BX,11
jne get_10
mov AX,word ptr ES:[SI+6]
jmp get_20
get_10: shl BX,1 ; get the word offset
mov AX,word ptr ES:[SI+10+BX]
get_20:
test word ptr ES:[SI+P_FLAGS],WINDOW ; Port a window?
jz get_25 ; No, jump
and AX,07FFFh ; Yes, return integer
mov word ptr [DI].C_disp,AX
jmp next_SP ; Return to interpreter
get_25:
xor BX,BX
push BX ; push long integer value
push AX
push DI ; register to store value
C_call long2int,,Load_ES ; convert to scheme integer
mov SP,BP
jmp next_SP
get_err: lea BX,gt_win_st
jmp src_err ; link to error handler
;;;************************************************************************
;;; Modify Transcript File Status
;;;************************************************************************
public trns_chg
trns_chg: lods byte ptr ES:[SI] ; load register operand
save <SI>
add AX,offset reg0 ; compute address of register
mov BX,AX
mov SI,[BX].C_disp
mov BX,[BX].C_page
cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type
jne trns_10
LoadPage ES,BX ; get page address
mov AX,word ptr ES:[SI+P_FLAGS]
mov CX,AX
and AX,OPEN ; open?
jz trns_10
and CX,3 ; read and write?
jz trns_10
mov TRNS_pag,BX
mov TRNS_dis,SI
jmp next_SP
trns_10: xor AX,AX
mov TRNS_pag,AX
mov TRNS_dis,AX
jmp next_SP
;;;************************************************************************
;;; Save Window Contents
;;;************************************************************************
public save_win
save_win: lods byte ptr ES:[SI] ; load register operand
save <SI>
add AX,offset reg0 ; compute address of register
xor BX,BX
pushm <BX, AX>
save <AX>
C_call get_port,,Load_ES ; get port object
mov SP,BP
mov BX,tmp_page
cmp byte ptr ptype+[BX],PORTTYPE*2 ; check port type
je save_01
save_err: lea BX,sv_win_st
jmp src_err ; link to error handler
save_01: LoadPage ES,BX ; get page address
mov DI,tmp_disp
mov AX,word ptr ES:[DI+P_FLAGS]
and AX,WINDOW ; window object?
jz save_err
mov AX,word ptr ES:[DI+UL_LINE]
mov BX,word ptr ES:[DI+UL_COL]
mov CX,word ptr ES:[DI+N_LINES]
mov DX,word ptr ES:[DI+N_COLS]
mov wulline,AX
mov wulcol,BX
mov wnlines,CX
mov wncols,DX
mov AX,word ptr ES:[DI+B_ATTR] ; border attribute
cmp AX,-1 ; bordered?
je save_10 ; no, jump
lea AX,wulline
lea BX,wulcol
lea CX,wnlines
lea DX,wncols
pushm <DX, BX, CX, AX>
call adj4bord ; adjust window region
save_10: mov AX,wnlines
mov BX,wncols
; compute the length of string to save window contents
mul BL
shl AX,1 ; * 2
add AX,2 ; + 2
push AX
restore <AX>
mov CX,STRTYPE ; string type
pushm <CX, AX>
C_call alloc_bl,,Load_ES ; alloc_block
mov SP,BP
pushm <wncols,wnlines,wulcol,wulline>
restore <AX>
push AX
call save_scr ; save screen
jmp next_SP ; return to interpreter
;;;************************************************************************
;;; Restore Window Contents
;;;************************************************************************
public rest_win
rest_win: lods word ptr ES:[SI] ; load register operand
save <SI> ; save the location pointer
xor BX,BX
mov BL,AH
add BX,offset reg0 ; compute address of register
xor AH,AH
add AX,offset reg0
save <BX>
xor CX,CX
pushm <CX, AX>
C_call get_port,,Load_ES ; get the port object
mov SP,BP
restore <BX> ; BX = data to be restored
mov SI,[BX].C_page
cmp byte ptr ptype+[SI],STRTYPE*2 ; check type
jne rest_err
mov DI,tmp_page
cmp byte ptr ptype+[DI],PORTTYPE*2 ; check type
jne rest_err
LoadPage ES,DI ; get page address
mov DI,tmp_disp
mov AX,word ptr ES:[DI+P_FLAGS]
and AX,WINDOW ; window object?
jz rest_err
mov AX,word ptr ES:[DI+UL_LINE]
mov BX,word ptr ES:[DI+UL_COL]
mov CX,word ptr ES:[DI+N_LINES]
mov DX,word ptr ES:[DI+N_COLS]
mov wulline,AX
mov wulcol,BX
mov wnlines,CX
mov wncols,DX
mov AX,word ptr ES:[DI+B_ATTR] ; border attribute
cmp AX,-1
je rest_10
lea AX,wulline
lea BX,wulcol
lea CX,wnlines
lea DX,wncols
pushm <DX, BX, CX, AX>
call adj4bord ; adjust window region
rest_10: pushm <wncols, wnlines, wulcol, wulline>
restore <BX>
push BX
call rest_scr ; restore screen
jmp next_SP ; return to interpreter
rest_err: lea BX,rt_win_st
jmp src_err ; link to error handler
win_proc endp
;;;************************************************************************
;;; Set Window Attribute
;;;************************************************************************
setw_arg struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
setw_reg dw ?
setw_att dw ?
setw_val dw ?
setw_arg ends
public set_wind
set_wind proc near
push ES
push BP
mov BP,SP
mov AX,1
pushm <AX, [BP].setw_reg>
C_call get_port,,Load_ES ; get port address
mov SP,BP
mov BX,tmp_page
cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type
jne setw_err
mov SI,[BP].setw_att
cmp word ptr [SI].C_page,SPECFIX*2 ; check attribute type
jne setw_err
mov AX,[SI].C_disp ; get attribute value
shl AX,1
sar AX,1
cmp AX,0 ; check attribute value
jl setw_err
cmp AX,NUM_FLDS
jge setw_err
mov SI,[BP].setw_val ; get the value pointer
cmp word ptr [SI].C_page,SPECFIX*2 ; check type
je setw_10
setw_err: lea BX,gt_win_st ; address of error message
pushm <[BP].setw_val, [BP].setw_att, [BP].setw_reg>
mov AX,3
pushm <AX, BX>
C_call set_src_,,Load_ES ; set_src_err
mov SP,BP
mov AX,-1 ; return error status
jmp setw_ret
setw_10: mov CX,[SI].C_disp ; get the value
shl CX,1
sar CX,1
LoadPage ES,BX ; get page address of port
mov SI,tmp_disp ; displacement of port object
mov BX,AX
shl BX,1 ; get the word offset
jmp branchtab+[BX]
; cursor line/cursor column
setw_20: cmp CX,0
jl setw_err ; negative value, error
jmp setw_100
; upper left hand corner line number
setw_30: xor AX,AX
xor DH,DH
mov DL,MAX_ROWS
dec DX ; MAX_ROWS - 1
call fit_in_r
mov AX,word ptr ES:[SI+N_LINES]
inc DX
sub DX,CX ; MAX_ROWS - value
cmp AX,DX
jle setw_35
mov word ptr ES:[SI+N_LINES],DX
setw_35: jmp setw_100
; upper left hand corner column number
setw_40: xor AX,AX
xor DH,DH
mov DL,MAX_COLS
dec DX ; MAX_COLUMNS - 1
call fit_in_r
mov AX,word ptr ES:[SI+N_COLS]
inc DX
sub DX,CX ; MAX_COLUMNS - value
cmp AX,DX
jle setw_35
mov word ptr ES:[SI+N_COLS],DX
jmp setw_35
; number of lines
setw_50: mov AX,word ptr ES:[SI+UL_LINE]
xor DH,DH
mov DL,MAX_ROWS
sub DX,AX ; MAX_ROWS - UL_LINE
mov AX,1
call fit_in_r
jmp setw_100
; number of columns
setw_60: mov AX,word ptr ES:[SI+P_FLAGS]
and AX,WINDOW ; window?
jz setw_100 ; no, jump
mov AX,word ptr ES:[SI+UL_COL]
xor DH,DH
mov DL,MAX_COLS
sub DX,AX ; MAX_COLUMNS - UL_COL
mov AX,1
call fit_in_r
jmp setw_100
; chunk#
setw_70: mov BX,CHUNK
jmp setw_120
; store the value
setw_100: sar BX,1
cmp BX,11
jne setw_110
mov BX,6
jmp setw_120
setw_110: shl BX,1 ; word offset
add BX,10
setw_120: mov word ptr ES:[SI+BX],CX ; store the value
xor AX,AX
setw_ret: pop BP
pop ES
ret
set_wind endp
;;;************************************************************************
;;; Force Value into Range
;;; Purpose: To test a value (in CX) to determine if it falls within a
;;; range of values, as specified by an lower (in AX) and
;;; upper (in DX) bounds. If the value is within the range,
;;; the value is returned (in CX) unchanged. If it is outside
;;; the range, the value of the endpoint nearest its value
;;; is returned (in CX).
;;;************************************************************************
fit_in_r proc near
pop DI ; get the return address
cmp CX,AX ; value < lower?
jge fit_10
mov CX,AX ; yes, return lower
fit_01: jmp DI ; return to caller
fit_10: cmp CX,DX ; value > upper?
jle fit_01 ; no, return
mov CX,DX ; yes, return upper
jmp DI ; return to caller
fit_in_r endp
;;;************************************************************************
;;; Write message to the who-line
;;;************************************************************************
who_arg struc
pg dw ?
dis dw ?
who_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
str dw ? ; pointer to message string
who_arg ends
extrn ssetadr:near
extrn printtxt:near
public who_writ
who_writ proc near
push ES
push BP
sub SP,offset who_BP ; allocate local storage
mov BP,SP
mov ax,port_pg ;save current port address
mov [BP].pg,ax
mov ax,port_ds
mov [BP].dis,ax
mov AX,WHO_DISP
mov BX,WHO_PAGE*2
pushm <AX, BX>
call ssetadr ;get new port address
mov SP,BP
xor BX,BX ;compute length of string
mov SI,[BP].str
who_010: cmp byte ptr [SI+BX],0 ;string end?
je who_020 ; yes, exit loop
inc BX
jmp who_010
; Write message to the who line
who_020: push BX ;bx = strlen(str)
push SI ;si = address of string
call printtxt
mov SP,BP
mov BX,[BP].pg ;restore original port
cmp byte ptr ptype+[BX],PORTTYPE*2 ;check port type
jne who_ret
LoadPage ES,BX ;get page address
mov SI,[BP].dis
cmp byte ptr ES:[SI],PORTTYPE ;check port type
jne who_ret
pushm <SI, BX>
call ssetadr ;set port address
mov SP,BP
who_ret: add SP,offset who_BP ;release local storage
pop BP
pop ES
ret
who_writ endp
prog ends
end


1903
realio.asm Normal file
View File

File diff suppressed because it is too large Load Diff

90
realio.equ Normal file
View File

@ -0,0 +1,90 @@
;*******************************************************************************
; *
; Macros and equates for i/o and graphics which are performed in real mode. *
; *
; *
;*******************************************************************************
IFNDEF DOS
DOS equ 021h ; Dos Function Request
ENDIF
IFNDEF RPC
RPC equ 0E1h ; Real Procedure Call
ENDIF
IFNDEF BLOCK_XFER
BLOCK_XFER equ 0EC00h ; Block Transfer
ENDIF
;
; Entry points within realio.asm for performing text I/O.
;
REAL_BELL equ 0 ;ring the bell
REAL_CLEAR equ 1 ;clear the screen
REAL_BORDER equ 2 ;draw window borders
REAL_SAVESCR equ 3 ;save screen contents
REAL_RESTSCR equ 4 ;restore screen contents
REAL_CURON equ 5 ;turn cursor on
REAL_CUROFF equ 6 ;turn cursor off
REAL_PUTCUR equ 7 ;position cursor
REAL_PUTC equ 8 ;write character
REAL_SCROLLUP equ 9 ;scroll up
REAL_SCROLLDN equ 10 ;scroll down
REAL_EGACURS equ 11 ;ega cursor
REAL_CHGVMODE equ 12 ;change video mode
REAL_WRTSTRNG equ 13 ;write string to port
REAL_WRTBLOCK equ 14 ;write string to display
;
; The following macro creates the code to call all of the real mode I/O
; routines. The arguments (which reside on the stack) are moved to the
; a buffer which resides in real mode, along with one of the above defined
; function indicators. Then an rpc call is performed, such that the correct
; real mode xli routine is envoked.
;
REALIO MACRO FUNCTION,ARGSTART,ARGEND,CONTINUE
; address arguments
push es
push si
push di
mov si,bp
add si,(ARGSTART - 2) ;ds:si => arguments
; move arguments to real mode buffer
push word ptr [si] ;save word at this location
mov word ptr [si],FUNCTION ;and replace with function opcode
IFDIF <ARGSTART>,<ARGEND> ;cx = length
mov cx,((ARGEND + 2) - (ARGSTART - 2))
ELSE
mov cx,(ARGEND - (ARGSTART - 2))
ENDIF
mov di,word ptr REAL_BUF_SELECTOR ;get real buffer selector
mov es,di
mov di,word ptr REAL_BUF_TOP ;get top address of buffer
sub di,cx ;es:di => real mode buffer
mov ax,BLOCK_XFER ;xfer block to real memory
int DOS
pop [si] ;restore word at this location
; issue call to real mode handler
mov al,rpc_handle ;real procedure handle
mov ah,RPC ;rpc function call
push di ;stack pointer
push XLI_REALIO ;real i/o function designator
mov dx,sp
mov cx,4 ;cx = # bytes in rpc buffer
IFNB <CONTINUE>
mov bx,2 ;bx = number return bytes
ELSE
xor bx,bx ;bx = number return bytes
ENDIF
int DOS
add sp,4
pop di
pop si
pop es
ENDM


1357
realschm.asm Normal file
View File

File diff suppressed because it is too large Load Diff

290
regschem.h Normal file
View File

@ -0,0 +1,290 @@
/* =====> SCHEME.H */
/* TIPC Scheme Data Declarations for Lattice C */
/* Last Modification: 01 January 1986 */
extern char *rtn_name;
#define ASSERT(arg) if(!(arg))asrt$(rtn_name,"arg")
#define ENTER(xyz) static char *rtn_name = "xyz"
/* Data conversion macros */
/* Adjust page number- this macro converts a logical page number to
the representation which is stored in the interpreter's registers
and pointers. "CORRPAGE" performs the reverse transformation */
#define ADJPAGE(x) ((x)<<1)
/* Correct page number- this macro converts the interpreter's encoding
of a page number into the logical page number. "ADJPAGE" performs
the reverse transformation. */
#define CORRPAGE(x) ((x)>>1)
/* Fetch value for Fixnum (immediate) from pointer */
#define get_fix(pg,ds) (((ds)<<1)>>1)
/* Fetch value for Character (immediate) from pointer */
#define get_char(pg,ds) ((ds) & 0x00ff)
/* define truth */
#define TRUE 1
#define FALSE 0
#define NULL 0 /* null pointer */
/* Position of page/displacement values in "registers" */
#define C_DISP 0
#define C_PAGE 1
/* Page Management Table Definitions */
#define NUMPAGES 128 /* maximum number of pages */
#define DEDPAGES 8 /* Number of dedicated pages */
#define MIN_PAGESIZE 0x0C00 /* minimum page size in bytes (fixed size) */
#define PTRMASK MIN_PAGESIZE-1 /* mask to isolate a pointer displacement */
#define PAGEINCR 2 /* increment to get to next page */
#define PAGEMASK 0x00FE /* mask to isolate a page number */
#define WORDSIZE 16 /* computer's word size (bits/word) */
#define WORDINCR 2 /* number of address units/word */
#define HT_SIZE 211 /* the oblist's hash table size */
#define STKSIZE 900 /* the stack's length (bytes) */
#define BLK_OVHD 3 /* number of overhead bytes in a block header */
#define NUM_REGS 64 /* number of registers in the Scheme VM */
/* Data Type Equates */
#define NUMTYPES 15 /* the number of data types */
#define LISTTYPE 0
#define FIXTYPE 1
#define FLOTYPE 2
#define BIGTYPE 3
#define SYMTYPE 4
#define STRTYPE 5
#define ARYTYPE 6
#define VECTTYPE ARYTYPE
#define CONTTYPE 7
#define CLOSTYPE 8
#define FREETYPE 9
#define CODETYPE 10
#define REFTYPE 11
#define PORTTYPE 12
#define CHARTYPE 13
#define ENVTYPE 14
#define EOFERR 1 /* Codes for function ERRMSG */
#define DOTERR 2
#define QUOTERR 3
#define RPARERR 4
#define OVERERR 5
#define DIV0ERR 6
#define SHARPERR 7
#define FULLERR -1
#define PORTERR -2
#define HEAPERR -3
#define BUFSIZE 80
#define SYM_OVHD 7
#define PTRSIZE 3
#define LISTSIZE 6
#define FIXSIZE 2
#define FLOSIZE 9
#define SMALL_SIZE 1024 /* a "small" length for a block */
#define SPECCHAR 1 /* special page of characters */
#define SPECFIX 3 /* special page of fixnums */
#define SFIXLEN 0 /* length (bytes) of special fixnum page */
#define SPECFLO 4 /* special page of flonums */
#define SFLOLEN 24 /* length (bytes) of special flonum page */
#define SPECSYM 5 /* special page of symbols */
#define SSYMLEN 0x51 /* length (bytes) of special symbol page */
#define SPECSTK 6
#define SPECPOR 6 /* special page of ports */
#define SPORLEN 92 /* length (bytes) of special port page */
#define SPECCODE 7 /* code page for the bootstrap loader */
#define END_LIST 0x7FFF /* end of linked list marker */
#define NIL_PAGE 0 /* Location of "nil" */
#define NIL_DISP 0
#define T_PAGE SPECSYM /* Location of "t" (for true) */
#define T_DISP 0x0000
#define UN_PAGE SPECSYM /* Location of "#!unassigned" */
#define UN_DISP 0x0009
#define NTN_PAGE SPECSYM /* Location of "#!not-a-number" */
#define NTN_DISP 0x001C
#define OVR_PAGE SPECSYM /* Location of overflow designator */
#define OVR_DISP 0x001C /* (same as "not a number" for now) */
#define DIV0_PAGE SPECSYM /* Location of divide-by-zero designator */
#define DIV0_DISP 0x001C /* (same as "not a number" for now) */
#define IN_PAGE SPECPOR /* Location of standard input port */
#define IN_DISP 0
#define OUT_PAGE SPECPOR /* Location of standard output port */
/* #define OUT_DISP 0x011f */
#define OUT_DISP 0 /* input=output for standard console device */
#define WHO_PAGE SPECPOR /* Location of "who-line" port */
#define WHO_DISP 0x0123
#define EOF_PAGE SPECSYM /* Location of non-interned "**eof**" symbol */
#define EOF_DISP 0x0031
#define NPR_PAGE SPECSYM /* Location of "#!unprintable" */
#define NPR_DISP 0x003D
#define ADD_OP 0 /* addition */
#define SUB_OP 1 /* subtraction */
#define MUL_OP 2 /* multiplication */
#define DIV_OP 3 /* divide */
#define MOD_OP 4 /* modulo */
#define AND_OP 5 /* bitwise and */
#define OR_OP 6 /* bitwise or */
#define MINUS_OP 7 /* minus */
#define EQ_OP 8 /* equal comparison */
#define NE_OP 9 /* not equal comparison */
#define LT_OP 10 /* less than comparison */
#define GT_OP 11 /* greater than comparison */
#define LE_OP 12 /* less than or equal comparison */
#define GE_OP 13 /* greater than or equal comparison */
#define ABS_OP 14 /* absolute value */
#define QUOT_OP 15 /* quotient */
#define TRUNC_OP 16 /* truncate */
#define FLOOR_OP 17 /* floor */
#define CEIL_OP 18 /* ceiling */
#define ROUND_OP 19 /* round */
#define FLOAT_OP 20 /* float */
#define ZERO_OP 21 /* zero? */
#define POS_OP 22 /* positive? */
#define NEG_OP 23 /* negative? */
/* Numeric Error Codes */
#define REF_GLOBAL_ERROR 1 /* reference of unbound global variable */
#define SET_GLOBAL_ERROR 2 /* SET! error-- global not defined */
#define REF_LEXICAL_ERROR 3 /* reference of unbound lexical variable */
#define SET_LEXICAL_ERROR 4 /* SET! error-- lexical variable not defined */
#define REF_FLUID_ERROR 5 /* reference of unbound fluid variable */
#define SET_FLUID_ERROR 6 /* SET-FLUID! error-- fluid not bound */
#define VECTOR_OFFSET_ERROR 7 /* vector index out of range */
#define STRING_OFFSET_ERROR 8 /* string index out of range */
#define SUBSTRING_RANGE_ERROR 9 /* invalid substring range */
#define INVALID_OPERAND_ERROR 10 /* invalid operand to VM instruction */
#define SHIFT_BREAK_CONDITION 11 /* SHFT-BRK key was depressed by user */
#define NON_PROCEDURE_ERROR 12 /* attempted to call non-procedural object */
#define TIMEOUT_CONDITION 13 /* timer interrupt */
#define WINDOW_FAULT_CONDITION 14 /* attempt to do I/O to a de-exposed window */
#define FLONUM_OVERFLOW_ERROR 15 /* flonum overflow/underflow */
#define ZERO_DIVIDE_ERROR 16 /* division by zero */
#define NUMERIC_OPERAND_ERROR 17 /* non-numeric operand */
#define APPLY_ARG_LIMIT_ERROR 18 /* too many arguments for APPLY to handle */
#define VECTOR_SIZE_LIMIT_ERROR 19 /* vector too big */
#define STRING_SIZE_LIMIT_ERROR 20 /* string too big */
#define DOS_FATAL_ERROR 21 /* DOS fatal i/o error (24H INT) */
/* Scheme VM Control Flags */
extern int PC_MAKE; /* variable denoting PC's manufacturer & type */
extern int VM_debug; /* VM debug mode flag */
extern int s_break; /* shift-break indicator */
extern int QUOTE_PAGE; /* Location of "quote" */
extern int QUOTE_DISP;
extern unsigned PAGESIZE;
extern unsigned pagetabl[NUMPAGES]; /* Paragraph Address (bases) */
extern struct {
unsigned atom:1;
unsigned listcell:1;
unsigned fixnums:1;
unsigned flonums:1;
unsigned bignums:1;
unsigned symbols:1;
unsigned strings:1;
unsigned arrays:1;
unsigned nomemory:1;
unsigned readonly:1;
unsigned continu:1;
unsigned closure:1;
unsigned refs:1;
unsigned ports:1;
unsigned code:1;
unsigned characters:1;
} attrib[NUMPAGES]; /* Page Attribute Bits */
extern int w_attrib[NUMPAGES]; /* Re-define attribute bits as integer */
extern int nextcell[NUMPAGES]; /* Next Available Cell Pointers */
extern int pagelink[NUMPAGES]; /* Next Page of Same Type */
extern int ptype[NUMPAGES]; /* Page Type Index */
extern unsigned psize[NUMPAGES]; /* Page Size Table */
extern int pageattr[NUMTYPES]; /* Page attribute initialization table */
extern int pagelist[NUMTYPES]; /* Page allocation table (by types) */
extern int listpage; /* Page for List Cell allocation */
extern int fixpage; /* Page for Fixnum allocation */
extern int flopage; /* Page for Flonum allocation */
extern int bigpage; /* Page for Bignum allocation */
extern int sympage; /* Page for Symbol allocation */
extern int strpage; /* Page for String allocation */
extern int arypage; /* Page for Array allocation */
extern int contpage; /* Page for Continuation allocation */
extern int clospage; /* Page for Closure allocation */
extern int freepage; /* Free page allocation list header */
extern int codepage; /* Page for Code Block allocation */
extern int refpage; /* Ref cell page allocation list header */
extern int nextpage; /* Next Page Number for Allocation in the
Logical Address Space */
extern unsigned nextpara; /* Next Paragraph Address for Allocation */
/* Scheme's Virtual Registers */
extern long reg0, regs[NUM_REGS];
extern int nil_reg[2];
extern int reg0_page, reg0_disp, tmp_reg[2], tmp_page, tmp_disp;
extern int tm2_reg[2], tm2_page, tm2_disp;
extern int FNV_reg[2], GNV_reg[2], CB_reg[2], PREV_reg[2];
extern int FNV_pag, FNV_dis, GNV_pag, GNV_dis, CB_pag, CB_dis;
extern int PREV_pag, PREV_dis, FP, BASE;
extern int CONSOLE_[2], CON_PAGE, CON_DISP;
extern int TRNS_reg[2], TRNS_pag, TRNS_dis; /* transcript file pointer */
extern int condcode, S_pc;
/* Stack */
extern int TOS; /* top of stack pointer (displacement in bytes */
extern char S_stack[STKSIZE]; /* the stack itself */
/* Hash Table */
extern char hash_page[HT_SIZE];
extern int hash_disp[HT_SIZE];
/* Property List Hash Table */
extern char prop_page[HT_SIZE];
extern int prop_disp[HT_SIZE];
/* State Variables for (reset) and (scheme-reset) */
extern int FP_save, RST_ent;
extern int FNV_save[2];
extern int STL_save[2];
/* Port fields */
#define pt_direc 6
#define pt_lnlen 20
#define pt_csrcol 12
#define dtaoffs 32
/* Error message text strings */
extern char m_error[], m_src[], m_dest[], m_first[], m_second[], m_third[];
/* Macros Normally Found in STDIO.H */
#define abs(x) ((x)<0?-(x):(x))
#define max(a,b) ((a)>(b)?(a):(b))
#define min(a,b) ((a)<=(b)?(a):(b))
/* Scheme Function Macros */
#define alloc_sym(dest,len) alloc_block(dest,SYMTYPE,len+PTRSIZE+1)
/* International Case Conversion Macros */
extern char locases[256];
extern char hicases[256];
#undef tolower
#define tolower(c) locases[(c)]
#undef toupper
#define toupper(c) hicases[(c)]
#undef islower
#define islower(c) ((c)!=hicases[(c)])
#undef isupper
#define isupper(c) ((c)!=locases[(c)])
#undef isspace
#undef isdigit
#define isdigit(c) isdig((c),10)
#undef isxdigit
#define isxdigit(c) isdig((c),16)


37
rpc.equ Normal file
View File

@ -0,0 +1,37 @@
;
; Dos function requests provided by AIA for performing real procedure calls
;
RPC_INIT equ 0E0h ; Initialize RPC
RPC equ 0E1h ; Issue RPC
;
; Real procedure entry points.
;
; REALSCHM.ASM is a real procedure which is loaded upon initialization of
; Scheme and accessed via real procedure calls. It currently contains a
; table of 25 entries (0-24) which contain routines accessable from our
; protected mode code. The first 20 entries will contain addresses to
; code within realschm.asm, primarily for things like xli support which
; can't be provided in protected mode. The next 5 entries are for system
; xli routines. An xli routine is distinguished as a system xli routine by
; having the FB_SYSINT flag in the file block set non-zero. Note that the
; system xli routines must be in a specified order, as defined in
; PRO2REAL.ASM.
;
;
RPCINIT equ 0 ;Initialize real procedure
RPCRETBUF equ 0 ;Return real procedure buffer address
RPCTYPE equ 1 ;Return pc type and graphics info
RPCLDEXE equ 2 ;Load an XLI file
RPCUNLDALL equ 3 ;Unload all XLI files
RPCXESC equ 4 ;Perform XESC to an XLI function
RPCXLISSR equ 5 ;XESC Special Services Return
RPCTAKCRT equ 6 ;takeover real mode crt interrupt
RPCRSTCRT equ 7 ;restore real mode system crt interrupt
; order dependent system xli files (see table in pro2real.asm & realschm.asm)
XLI_REALIO equ 20 ;Perform text I/O
XLI_GRAPH equ 21 ;Perform Graphics


247
saprop.asm Normal file
View File

@ -0,0 +1,247 @@
; =====> SAPROP.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Property List Support *
;* *
;* (C) Copyright 1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 7 May 1986 *
;* Last Modification: 11 May 1986 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;************************************************************************
;* Search for Property in Property List *
;* *
;* Calling Sequence: found? = prop_search(list,prop); *
;* *
;* Input Parameters: list - the property list for a symbol. *
;* prop - the property for which to search. *
;* *
;* Output Parameters: found? - if the property was found in the list, *
;* found?=1; else found?=0. *
;* list - a pointer to the property/value pair *
;* for the specified property. If not found, NIL. *
;* *
;* Note: This routine is an assembly language version of the following *
;* C source: *
;* prop_search(list, prop) *
;* int list[2],prop[2]; *
;* { *
;* int search[2]; /* current search entry in list */ *
;* int temp[2]; /* temporary "register" */ *
;* ENTER(prop_search); *
;* *
;* mov_reg(search, list); *
;* take_cdr(search); *
;* while(search[C_PAGE]) *
;* { *
;* mov_reg(temp, search); *
;* take_car(temp); *
;* if (eq(temp,prop)) *
;* { *
;* mov_reg(list, search); *
;* return(FOUND); *
;* } *
;* take_cddr(search); *
;* } /* end: while(search[C_PAGE]) */ *
;* return(NOT_FOUND); *
;* } /* end of function: prop_search(list, prop) */ *
;************************************************************************
p_arg struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; return address
p_list dw ? ; addr of reg containing list to search
p_prop dw ? ; the property for which we're searching
p_arg ends
public prop_sea
prop_sea proc near
push ES ; save caller's ES register
push BP ; save caller's BP register
mov BP,SP ; establish addressability
; Load up the property for which we're searching into CL:DX
mov BX,[BP].p_prop
mov CL,byte ptr [BX].C_page
mov DX,[BX].C_disp
; Load up a pointer to the beginning of the property list
mov SI,[BP].p_list
xor BX,BX
mov BL,byte ptr [SI].C_page
mov DI,[SI].C_disp
jmp short start
; Property didn't match-- keep searching list
no_match: mov BL,ES:[DI].cdr_page
mov DI,ES:[DI].cdr
; Take CDR to get to first property/value pair or to follow list
start: cmp BL,0
je p_nf
cmp byte ptr ptype+[BX],LISTTYPE*2
jne p_nf
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[DI].cdr_page
mov DI,ES:[DI].cdr
; Test for valid list cell
cmp BL,0
je p_nf
cmp byte ptr ptype+[BX],LISTTYPE*2
jne p_nf
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
cmp DX,ES:[DI].car
jne no_match
cmp CL,ES:[DI].car_page
jne no_match
; Property found!-- return pointer to it
mov byte ptr [SI].C_page,BL ; move pointer to property entry
mov [SI].C_disp,DI ; into the "list" operand register
pop BP ; restore caller's BP register
pop ES ; restore caller's ES register
mov AX,1 ; indicate property found
ret ; return
; End of property list-- return not found
p_nf: xor AX,AX ; indicate no match found
pop BP ; restore caller's BP register
pop ES ; restore caller's ES register
ret ; return
prop_sea endp
;************************************************************************
;* Search for Symbol in Property List *
;* *
;* Calling Sequence: sym_search(sym) *
;* *
;* Input Parameters: sym - a register containing a symbol who's *
;* property list is to be located. *
;* *
;* Output Parameters: sym - the register is updated to point to the *
;* property list for the symbol. If no property *
;* list exists, it is set to NIL. *
;* *
;* Note: This routine is an assembly language version of the following *
;* C source: *
;* sym_search(sym) *
;* int sym[2]; *
;* { *
;* int hash_value; /* symbol's hash value */ *
;* int sym_save[2]; /* initial value of symbol argument */ *
;* int temp[2]; /* temporary "register" */ *
;* ENTER(sym_search); *
;* *
;* if (ptype[CORRPAGE(sym[C_PAGE])] == SYMTYPE*2) *
;* { *
;* /* save symbol's page and displacement for testing purposes */ *
;* mov_reg(sym_save, sym); *
;* *
;* /* obtain hash chain to search */ *
;* hash_value = sym_hash(sym); *
;* sym[C_PAGE] = prop_page[hash_value]; *
;* sym[C_DISP] = prop_disp[hash_value]; *
;* *
;* while(sym[C_PAGE]) *
;* { *
;* mov_reg(temp, sym); *
;* take_caar(temp); *
;* if (eq(temp, sym_save)) *
;* { *
;* /* symbol found-- return pointer to symbol's property list */*
;* take_car(sym); *
;* break; *
;* } *
;* else *
;* { *
;* take_cdr(sym); *
;* } *
;* } /* end: while(sym[C_PAGE]) */ *
;* } *
;* } /* end of function: sym_search(sym) */ *
;* *
;************************************************************************
sym_args struc
dw ? ; caller's ES register
dw ? ; caller's BP register
dw ? ; return address
s_sym dw ? ; address of symbol/result register
sym_args ends
public sym_sear
sym_sear proc near
push BP ; save the caller's BP register
push ES ; save the caller's ES register
mov BP,SP ; establish addressability
; Load a pointer to the symbol and get its hash value
mov SI,[BP].s_sym ; load symbol register's address
mov BX,[SI].C_page ; load symbol's page number
cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it?
jne s_nf ; if not a symbol, return NIL
mov SI,[SI].C_disp ; load symbol's displacement and
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; paragraph address
mov CX,BX ; copy the symbol into CL:DX
mov DX,SI
mov BL,ES:[SI].sym_hkey ; load hash key
mov DI,BX ; copy hash key into DI and
shl DI,1 ; multiply by two for word index
mov BL,prop_pag+[BX] ; load property list header for this
mov DI,prop_dis+[DI] ; symbol's bucket
jmp short go
; Search the next entry in the bucket
s_next: mov BX,AX
LoadPage ES,BX
;;; mov ES,AX ; restore ES register for bucket entry
s_next1: mov BL,ES:[DI].cdr_page ; load pointer to next bucket entry from
mov DI,ES:[DI].cdr ; the CDR field
go: cmp BL,0 ; end of bucket?
je s_nf ; if so, jump
cmp byte ptr ptype+[BX],LISTTYPE*2 ; list cell?
jne s_nf ; if not a pair (?), jump
LoadPage ES,BX
mov AX,BX ; Save Bucket entry page number
;;; mov ES,pagetabl+[BX] ; load list cell's paragraph address
; Fetch the property list from the CAR field of the bucket entry
mov BL,ES:[DI].car_page
mov SI,ES:[DI].car
cmp BL,0 ; no property list for this bucket entry?
je s_next1 ; if not (?), ignore it
cmp byte ptr ptype+[BX],LISTTYPE*2 ; it is a pair, isn't it?
jne s_next1 ; if not (?), ignore it
;;; mov AX,ES ; save ES register for bucket entry
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load the paragraph addr of prop list entry
cmp DX,ES:[SI].car ; entry for our symbol?
jne s_next ; if not, jump
cmp CL,ES:[SI].car_page ; entry for our symbol?
jne s_next ; if not, jump
; Symbol's property list found-- return in symbol register (or return NIL)
mov DI,[BP].s_sym ; reload source/destination register address
mov byte ptr [DI].C_page,BL ; store prop list pointer into
mov [DI].C_disp,SI ; the register
pop ES ; restore the caller's ES register
pop BP ; restore the caller's BP register
ret ; return
; Invalid list structure-- return NIL
s_nf: xor AX,AX ; create a NIL pointer
mov DI,[BP].s_sym
mov byte ptr [DI].C_page,AL
mov [DI].C_disp,AX
pop ES
pop BP
ret
sym_sear endp
prog ends
end


564
sasm.mac Normal file
View File

@ -0,0 +1,564 @@
; =====> SASM.MAC
;***************************************
;* TIPC Scheme '84 Assembler Macros *
;* (C) Copyright 1984,1984 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 14 May 1984 *
;* Last Modification: 1 April 1985 *
;***************************************
; Register equates
R0 equ 0
R1 equ 4
R2 equ 8
R3 equ 12
R4 equ 16
R5 equ 20
R6 equ 24
R7 equ 28
R8 equ 32
R9 equ 36
R10 equ 40
R11 equ 44
R12 equ 48
R13 equ 52
R14 equ 56
R15 equ 60
R16 equ 64
R17 equ 68
R18 equ 72
R19 equ 76
R20 equ 80
R21 equ 84
R22 equ 88
R23 equ 92
R24 equ 96
R25 equ 100
R26 equ 104
R27 equ 108
R28 equ 112
R29 equ 116
R30 equ 120
R31 equ 124
R32 equ 128
R33 equ 132
R34 equ 136
R35 equ 140
R36 equ 144
R37 equ 148
R38 equ 152
R39 equ 156
R40 equ 160
R41 equ 164
R42 equ 168
R43 equ 172
R44 equ 176
R45 equ 180
R46 equ 184
R47 equ 188
R48 equ 192
R49 equ 196
R50 equ 200
R51 equ 204
R52 equ 208
R53 equ 212
R54 equ 216
R55 equ 220
R56 equ 224
R57 equ 228
R58 equ 232
R59 equ 236
R60 equ 240
R61 equ 244
R62 equ 248
R63 equ 252
; Instruction macros
COPY_ macro dest,src
db 0,dest,src
endm
LD_CON_ macro dest,numb
db 1,dest,numb
endm
LD_IMM_ macro dest,val
db 2,dest,val
endm
LD_NIL_ macro dest
db 3,dest
endm
LD_LCL_ macro dest,entry
db 4,dest,entry
endm
LD_GLOBAL_ macro dest,src
db 7,dest,src
endm
LD_FLUID_ macro dest,src ; load fluid
db 8,dest,src
endm
LD_S_ macro dest,src,off
temp_ld = offset off
temp_ld = temp_ld/3
db 9,dest,src,temp_ld
endm
LD_L_ macro dest,src,off
temp_ld = offset off
temp_ld = temp_ld/3
db 10,dest,src
dw temp_ld
endm
LD_R_ macro dest,src,off
db 11,dest,src,off
endm
LD_GL_R_ macro dest,src
db 27,dest,src
endm
BIND_FL_ macro const,src ; bind fluid variable
db 29,const,src
endm
DEFINE_ macro dest,const
db 31,dest,const
endm
DEF_ENV_ macro sym,val,env
db 220,sym,val,env
endm
CLOSE_ macro dest,lbl,nargs
local x
db 60,dest
dw lbl-x
db nargs
x equ $
endm
LD_FL_R_ macro dest,src ; load fluid from symbol in register
db 63,dest,src ; temporary instruction?
endm
LD_CAR_ macro dest,src
db 64,dest,src
endm
LD_CDR_ macro dest,src
db 65,dest,src
endm
LD_CAAR_ macro dest,src
db 66,dest,src
endm
LD_CADR_ macro dest,src
db 67,dest,src
endm
LD_CDAR_ macro dest,src
db 68,dest,src
endm
LD_CDDR_ macro dest,src
db 69,dest,src
endm
LD_CAAAR_ macro dest,src
db 70,dest,src
endm
LD_CAADR_ macro dest,src
db 71,dest,src
endm
LD_CADAR_ macro dest,src
db 72,dest,src
endm
LD_CADDR_ macro dest,src
db 73,dest,src
endm
LD_CDAAR_ macro dest,src
db 74,dest,src
endm
LD_CDADR_ macro dest,src
db 75,dest,src
endm
LD_CDDAR_ macro dest,src
db 76,dest,src
endm
LD_CDDDR_ macro dest,src
db 77,dest,src
endm
LD_CADDDR_ macro dest,src
db 78,dest,src
endm
CONS_ macro dest,car,cdr
db 79,dest,car,cdr
endm
SETCAR_ macro dest,src
db 20,dest,src
endm
SETCDR_ macro dest,src
db 21,dest,src
endm
ST_S_ macro dest,src,off
db 17,dest,src,offset off
endm
ST_L_ macro dest,src,off
db 18,dest,src
dw offset off
endm
ST_R_ macro dest,src,off
db 19,dest,src,off
endm
SETREF_ macro val,ref
db 22,val,ref
endm
JMP_S_ macro label
db 32,label-$-1
endm
JMP_L_ macro label
db 33
dw label-$-2
endm
JNIL_S_ macro reg,label
db 34,reg,label-$-1
endm
JNIL_L_ macro reg,label
db 35,reg
dw label-$-2
endm
JNNIL_S_ macro reg,label
db 36,reg,label-$-1
endm
JNNIL_L_ macro reg,label
db 37,reg
dw label-$-2
endm
JATOM_S_ macro reg,label
db 38,reg,label-$-1
endm
JATOM_L_ macro reg,label
db 39,reg
dw label-$-2
endm
JNATOM_S_ macro reg,label
db 40,reg,label-$-1
endm
JNATOM_L_ macro reg,label
db 41,reg
dw label-$-2
endm
DEREF_ macro dest ; (deref x)
db 46,dest
endm
REF_ macro dest ; (ref x)
db 47,dest
endm
CALL_ macro label,dl_lvl,dl_heap
db 48
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_TR_ macro label,dl_lvl,dl_heap
db 49
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_CC_ macro label,dl_lvl,dl_heap
db 50
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_CT_ macro label,dl_lvl,dl_heap
db 51
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_CL_ macro reg,nargs
db 52,reg,nargs
endm
CLOSURP_ macro dest ; (closure? obj)
db 129,dest
endm
FLUID_P_ macro dest ; (fluid-bound? obj)
db 134,dest
endm
STRINGP_ macro dest ; (string? obj)
db 143,dest
endm
SYMBOLP_ macro dest ; (symbol? obj)
db 144,dest
endm
MINUS_ macro dest ; (minus n)
db 151,dest
endm
A_S_ macro dest ; (ascii->symbol n)
db 160,dest
endm
S_A_ macro dest ; (symbol->ascii sym)
db 161,dest
endm
ADD_ macro dest,src
db 80,dest,src
endm
ADDI_ macro dest,imm
db 81,dest,imm
endm
SUB_ macro dest,src
db 82,dest,src
endm
MUL_ macro dest,src
db 83,dest,src
endm
MULI_ macro dest,imm
db 84,dest,imm
endm
DIV_ macro dest,src
db 85,dest,src
endm
DIVI_ macro dest,imm
db 86,dest,imm
endm
MOD_ macro dest,src
db 88,dest,src
endm
JEQ_S_ macro reg1,reg2,label
db 42,reg1,reg2,label-$-1
endm
JEQ_L_ macro reg1,reg2,label
db 43,reg1,reg2
dw label-$-2
endm
JNEQ_S_ macro reg1,reg2,label
db 44,reg1,reg2,label-$-1
endm
JNEQ_L_ macro reg1,reg2,label
db 45,reg1,reg2
dw label-$-2
endm
EQ_ macro n1,n2
db 94,n1,n2
endm
NE_ macro n1,n2
db 97,n1,n2
endm
LT_ macro n1,n2
db 92,n1,n2
endm
GT_ macro n1,n2
db 95,n1,n2
endm
LE_ macro n1,n2
db 93,n1,n2
endm
GE_ macro n1,n2
db 96,n1,n2
endm
EQ_Z_ macro dest ; (=0 n)
db 146,dest
endm
LT_Z_ macro dest ; (<0 n)
db 147,dest
endm
GT_Z_ macro dest ; (>0 n)
db 148,dest
endm
ABS_ macro dest ; (abs n)
db 149,dest
endm
FLOOR_ macro dest ; (floor n)
db 152,dest
endm
FLOAT_ macro dest ; (float n)
db 150,dest
endm
GENSYM_ macro dest ; (gensym sym)
db 162,dest
endm
EXPLODE_ macro dest ; (explode sym)
db 163,dest
endm
IMPLODE_ macro dest ; (implode list)
db 164,dest
endm
LENGTH_ macro dest ; (length list)
db 165,dest
endm
LAST_PR_ macro dest ; (last-pair list)
db 166,dest
endm
POP_ macro dest
db 24,dest
endm
PUSH_ macro dest
db 25,dest
endm
DROP_ macro count
db 26,count
endm
EXECUTE_ macro code
db 58,code
endm
EXIT_ macro ; restore (return from call)
db 59
endm
APPLY_ macro ftn,arg ; apply funtion to args
db 56,ftn,arg
endm
APPLYTR_ macro ftn,arg ; apply funtion to args-tail recursive
db 57,ftn,arg
endm
CB_ALLOC_ macro dest ; allocate code block
db 172,dest
endm
ST_CONST_ macro src,cb,offset ; store constant
db 173,src,cb,offset
endm
ST_BYTE_ macro src,cb,offset ; store code byte
db 174,src,cb,offset
endm
OPEN_ macro file,mode ; open I/O port
db 176,file,mode
endm
CLOSEP_ macro file ; close I/O port
db 177,file
endm
PRIN1_ macro dest,port ; print s-expression
db 178,dest,port
endm
PRINC_ macro dest,port ; print s-expression
db 179,dest,port
endm
PRINT_ macro dest,port ; print s-expression
db 180,dest,port
endm
NEWLINE_ macro port ; print newline
db 181,port
endm
READ_ macro dest ; read s-expression
db 182,dest
endm
FASL_ macro dest ; fast load
db 191,dest
endm
HALT_ macro ; return to MS-DOS
db 248
endm
GC_ macro ; garbage collect
db 249
endm
PTIME_ macro ; display current time
db 250
endm
S_RESET_ macro ; scheme-reset
db 252
endm
CLR_REG_ macro ; clear registers
db 253
endm
DEBUG_ macro ; begin debug mode
db 255
endm


512
sbid.asm Normal file
View File

@ -0,0 +1,512 @@
;
;***************************************
;* TIPC Scheme Runtime Support *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 5 June 1985 *
;* Last Modification: 15 May 1986 *
;***************************************
page 60,132
MSDOS equ 021h ; MS-DOS service call interrupt
FREEMEM equ 049h ; Free memory function identifier
MODIFMEM equ 04Ah ; Modify allocated memory function id
BIDTASK equ 04Bh ; Load and execute program function id
PRSTRING equ 09h
CREATE_FL equ 3Ch ; Create file function
OPEN_FL equ 3Dh ; Open file function
CLOSE_FL equ 3Eh ; Close file function
READ_FL equ 3Fh ; Read file function
WRITE_FL equ 40h ; Write file function
DELETE_FL equ 41h ; Delete file function
GET_DRIVE equ 19h ; Current disk function
SET_DRIVE equ 0Eh ; Select disk function
GET_DIR equ 47h ; Return text of current directory function
SET_DIR equ 3Bh ; Change the current directory function
TI_CRTINT equ 49h*4 ; CRT dsr interrupt - TI
IBM_CRTINT equ 10h*4 ; CRT dsr interrupt - IBM
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn _paras:word ; total number of paragraphs available
extrn _psp:dword ; program segment prefix paragraph address
; extrn first_pa:word ; seg addr of 1st page in Scheme heap
extrn first_dos:word ; seg addr of memory allocated to Scheme heap
extrn PC_MAKE:word ; type of machine
drive db ? ; place holder for current drive number
dir_path db ? ; Drive Letter (as part of the path name)
db ":\" ; GET_DIR function doesn't prepend "root"
path db 80 dup(?) ; dir path buffer, excluding drive
sav_file db "pc__s.sav",00 ; ASCIZ save file pathname
len_sav_name equ $-sav_file
cmd_ db "COMSPEC="
cmd_1 equ $
ENVPTR dw 0 ; DOS EXEC parameter block
CMDOFF dw 0 ; "
CMDSEG dw 0 ; "
FCB1OFF dw 5Ch ; "
FCB1SEG dw 0 ; "
FCB2OFF dw 6Ch ; "
FCB2SEG dw 0 ; "
data ends
XGROUP group PROGX
PROGX segment byte public 'PROGX'
assume CS:XGROUP
public install
public uninstall
;************************************************************************
;* Bid another Task *
;************************************************************************
bid_args struc
dw ? ; caller's BP
dw ? ; caller's ES
dd ? ; far return address to caller of bid_task
dw ? ; near return address to caller of bid
bid_file dw ? ; program's file name
bid_parm dw ? ; parameters
free_req dw ? ; requested # of free paragraphs
bid_args ends
sav_SP dw 0 ; save area for current stack pointer
sav_SS dw 0 ; save area for stack segment register
;
; Paragraph Addresses
;
; _paras --> +--------------------+ <----
; | /|\ | : Freed for bidded task,
; | | | : Saved to disk save file
; | | -- free_req | : start: _paras - free_req
; | | | : length: free_req
; | \|/ | : (free_req >= _paras - first_dos)
; |~~~~~~~~~~~~~~~~~~~~| <----
; | | :
; | (heap) | : Allocated to stay resident
; | | : # paras: _paras -
; first_pa --> +--------------------+ : _psp -
; | (unused area) | : free_req
; first_dos --> +--------------------+ :
; | | :
; | (PCS) | :
; | | :
; | | :
; _psp --> +--------------------+ <----
; | |
;
close proc near ; Closes the file whose handle is in BX
mov AH,CLOSE_FL
int MSDOS
ret
close endp
delete proc near ; Deletes the save file
assume DS:DGROUP
mov DX,offset dir_path
mov AH,DELETE_FL
int MSDOS
ret
delete endp
bid_task proc far
push ES
push BP
mov BP,SP ; establish local addressability
; Check if requested # of free paragraphs within bounds
cmp [BP].free_req,0 ; default to free max?
je free_all ; yes, branch
mov AX,_paras ; compute requested base of free area
sub AX,[BP].free_req ;
jb free_all ; request greater than all memory? branch
cmp AX,first_dos ; below base of free-able area?
jnb req_ok ; no, ok -- jump
free_all: mov AX,_paras ; compute max # of free-able paras
sub AX,first_dos ;
mov [BP].free_req,AX ; update # of paras to free
req_ok:
; Save Scheme's user memory
; First create save file
; Save current drive and directory path
mov AH,GET_DRIVE ; get current drive number (0=A,1=B,...,4=E)
int MSDOS
mov drive,AL ; and save it
inc AL ; "correct" current drive number
mov DL,AL ; put current drive into DL
add AL,40h ; (make it a capital letter)
mov dir_path,AL ; put the drive letter into dir_path
mov SI,offset path ; point DS:SI to path buffer
mov AH,GET_DIR ; get current path
int MSDOS
; Append save file's name to end of directory path
find_end: mov BX,offset path ; point to beginning of path name
mov CX,64 ; maximum length of path name
findloop: cmp byte ptr [BX],0
je name_end
inc BX
loop findloop
name_end: cmp byte ptr [BX-1],'\' ; was last character a backslash?
je add_save ; if so then don't append another one (jump!)
mov byte ptr [BX],'\' ; else append a backslash then the filename
inc BX
add_save: push SI ; Now add concat'nate filename (PC__S.SAV)
mov AX,DS
mov ES,AX
mov DI,BX ; load destination address
mov SI,offset sav_file
mov CX,len_sav_name
rep movsb ; appending the save file name + NULL
pop SI
; Now open the save file...
mov DX,offset dir_path ; point DS:DX to ASCIZ save file path
mov CX,20h ; file attribute
mov AH,CREATE_FL
int MSDOS ; do it
jnb crt_ok ; branch if create ok
jmp exit ; quit now if unable to create save file
crt_ok:
; Now dump memory to the file (file handle in AX)
mov BX,AX ; put file handle into BX
mov DI,[BP].free_req ; DI = number of paras to write
mov AX,_paras ; compute base of area to free
sub AX,[BP].free_req ;
push DS ; save DS
mov DS,AX ; init DS:DX to base of area to save
xor DX,DX ;
wrt_para: cmp DI,0FFFh ; can write all paras in one shot?
jbe wrt_last ; yes, jump
sub DI,0FFFh ; dec paras-to-write count
mov CX,0FFF0h ; write FFF0 bytes
mov AH,WRITE_FL
int MSDOS ; do it
jb wrt_err ; branch if error
cmp AX,CX ; wrote all bytes?
je wrt_ok1 ; yes, branch
mov AX,20 ; indicate write count error
jmp short wrt_err
wrt_ok1: mov AX,DS ; inc buffer pointer
add AX,0FFFh
mov DS,AX
jmp wrt_para ; write out next FFF paras
wrt_last: mov CL,4 ; shift para count to byte count
shl DI,CL
mov CX,DI ; put byte count into CX
mov AH,WRITE_FL
int MSDOS ; do it
jb wrt_err ; branch if error
cmp AX,CX ; wrote all bytes?
je wrt_ok2
mov AX,20 ; indicate write count error
wrt_err: pop DS ; restore DS
push AX ; save error code
call close ; close and delete save file
call delete
pop AX ; restore error code
jmp exit ; and quit
wrt_ok2: pop DS ; restore DS
call close ; close up file for safe keeping
jnb wrt_ok3 ; branch if all ok
jmp exit ; quit if can't close file
wrt_ok3:
; Free up Scheme's user memory
mov ES,first_dos ; point ES to base of allocated area
mov BX,_paras ; compute # paras to remain allocated
sub BX,first_dos ;
sub BX,[BP].free_req ;
mov AH,MODIFMEM ; load modify memory function id
int MSDOS ; change PCS memory allocation
jnc mem_ok
memerr: push AX ; save error code
call delete ; delete save file
pop AX ; restore error code
jmp exit ; and quit
mem_ok:
; Bid up specified program
; Set up parameter block
mov AX,[BP].bid_parm ; Set up dword pointer to command line
mov CMDOFF,AX
mov CMDSEG,DS
mov AX,word ptr _psp+2 ; Point to FCBs in program segment prefix
mov FCB1SEG,AX
mov FCB2SEG,AX
mov ES,AX
mov AX,ES:[02Ch] ; copy current environment ptr to
mov ENVPTR,AX ; parameter area
; Set ES:BX to address of parameter block
mov AX,DS
mov ES,AX
mov BX,offset ENVPTR
; Set DS:DX to address of ASCIZ pathname (of file to be loaded)
push DS ; save DS segment register
mov DX,[BP].bid_file
mov DI,DX
cmp byte ptr [di],0 ; check if pt'ed to string is empty
jne bid_it
; No filename-- bid up a new command interpreter;
; have to search environment for COMSPEC= string
mov ES,ENVPTR ; ES:DI points to 1st string in environment
xor DI,DI
; Test for end of environment
get_plop: cmp byte ptr ES:[DI],0 ; last entry in environment?
je cmd_err ; if so, COMSPEC= not found
mov SI,offset cmd_ ; load address of comparison string
mov CX,cmd_1-cmd_ ; and length of same
repe cmps cmd_,ES:[DI] ; does this entry begin "COMSPEC="?
je found ; if so, found it! (jump)
xor AX,AX ; clear AX for search
mov CX,-1 ; set CX for maximum length
repne scas byte ptr ES:[DI] ; find \0 which terminates string
jmp get_plop ; loop
; No command interpreter found
cmd_err: mov AX,10 ; treat as bad-environment error
jmp short bid_err
; Found COMSPEC=
found: mov DX,DI ; DS:DX is ptr to command interpreter
push DS ; (swap DS and ES)
push ES
pop DS
pop ES
; issue load task function call
bid_it: push BP ; Old IBM-PCs & XTs destroy BP on func 4B.
mov CS:sav_SP,SP ; save current stack pointer
mov CS:sav_SS,SS ; save stack segment register
xor AL,AL ; load and execute condition
mov AH,BIDTASK ; load "load and execute" ftn id
int MSDOS ; perform service call
cli ; disable all interrupts
mov SS,CS:sav_SS ; restore stack base pointer
mov SP,CS:sav_SP ; restore stack pointer
sti ; enable interrupts
pop BP ; restore BP (Thanks IBM) :-(
pop DS ; restore DS segment register
jb bid_err ; branch if error in bidding task
xor AX,AX ; indicate no error
bid_err: push AX ; save error code
; ReAllocate Scheme's user memory
mov ES,first_dos ; point ES to base of allocated area
mov BX,_paras ; compute # of all available paras
sub BX,first_dos ;
mov AH,MODIFMEM ; load modify memory function id
int MSDOS ; change PCS memory allocation
jnc read_mem
fatal: pop AX ; throw away bid error code
call delete ; delete save file
mov AX,0FFFFh ; indicate cannot continue, -1
jmp exit
; Restore Scheme's user memory
; First open save file
read_mem: mov DX,offset dir_path ; point DS:DX to ASCIZ save file path
mov AL,00 ; access code for reading
mov AH,OPEN_FL
int MSDOS ; do it
jb fatal ; abort if cannot open save file
; Now read memory from the file (file handle in AX)
mov BX,AX ; put file handle into BX
mov DI,[BP].free_req ; DI = number of paras to read
mov AX,_paras ; compute base of area to restore from disk
sub AX,[BP].free_req ;
push DS ; save DS
mov DS,AX ; init DS:DX to base of area to restore
xor DX,DX
rd_para: cmp DI,0FFFh ; can read all paras in one shot?
jbe rd_last ; yes, jump
sub DI,0FFFh ; dec paras-to-read count
mov CX,0FFF0h ; read FFF0 bytes
mov AH,READ_FL
int MSDOS ; do it
jb read_err ; branch if read error
cmp AX,CX ; read all bytes?
jne read_err ; no, branch
read_ok1: mov AX,DS ; inc buffer pointer
add AX,0FFFh
mov DS,AX
jmp rd_para ; read in next FFF paras
rd_last: mov CL,4 ; shift para count to byte count
shl DI,CL
mov CX,DI ; put byte count into CX
mov AH,READ_FL
int MSDOS ; do it
jb read_err ; branch if error reading file
cmp AX,CX ; read all bytes?
je read_ok2 ; yes, branch
read_err: pop DS ; restore DS
call close ; close save file
jmp fatal ; and abort
read_ok2: pop DS ; restore DS
call close ; close save file
call delete ; and delete it
pop AX ; restore bid error code
exit: pop BP ; restore caller's BP
pop ES ; restore ES segment register
ret ; return to caller
bid_task endp
;------------------------------------------------------------------------
; The following routines will inhibit text display to the screen for
; the duration of the dos-call.
;
; Note: Programs such as Lotus 1-2-3 which write directly to the
; screen memory will still be visible.
;
;------------------------------------------------------------------------
exec_args struc
dw ? ; caller's BP
dd ? ; far return address to caller of install
dw ? ; near return address to caller of exec
file dw ? ; program's file name
parm dw ? ; parameters
fre_req dw ? ; requested # of free paragraphs
display dw ? ; Indicates if screen should be disturbed
exec_args ends
CRTSAV dd ?
CRTINT dw ?
DSSAV dw ?
INSTALLED dw ?
install proc far
; This routine installs a routine at the CRT DSR interrupt
;
push bp
mov bp,sp
push bx
mov cs:INSTALLED,0 ; Assume routine won't be installed
mov bx,[BP].display ; Indicates if commands will be sent
cmp bx,0 ; Screen can be disturbed?
pop bx
jne non_null ; Install new interrupt routine
jmp xinstall ; exit
non_null:
mov cs:INSTALLED,1
push ds
push es
push ax
push bx
push dx
push si
push di
mov ax,ds
mov cs:DSSAV,ax
;
; Install new routine at the CRT DSR interrupt
;
mov ax,0 ; Save off routine adr of CRT DSR
mov ds,ax
mov si,offset xgroup:CRTSAV
mov word ptr cs:[CRTINT],IBM_CRTINT ; Assume its IBM
mov es,cs:DSSAV
cmp word ptr es:PC_MAKE,1 ; Is it a TI?
jne is_IBM
mov word ptr cs:[CRTINT],TI_CRTINT
is_IBM:
mov di,cs:CRTINT
mov ax,ds:[di]
mov cs:[si],ax
mov ax,ds:[di+2]
mov cs:[si+2],ax
cli ; Clear interrupts
mov ax,offset xgroup:crtdsr
mov ds:[di],ax
mov ds:[di+2],cs
sti ; Enable interrupts
pop di
pop si
pop dx
pop bx
pop ax
pop es
pop ds
xinstall:
pop bp
ret
install endp
; **************************************************************************
; This routine restores the original routine for the CRT DSR interrupt
;
uninstall proc far
cmp cs:INSTALLED,1 ; Was an int routine installed?
je non_null2
jmp xuninstall
non_null2:
push ds
push ax
push si
push di
mov ax,0
mov ds,ax
mov si,offset xgroup:CRTSAV ; Restore CRT DSR routine
mov ax,cs:[si]
mov di,cs:CRTINT
mov ds:[di],ax
mov ax,cs:[si+2]
mov ds:[di+2],ax
pop di
pop si
pop ax
pop ds
xuninstall:
ret
uninstall endp
;
; This is the do-nothing routine installed at the CRT DSR interrupt
;
crtproc proc far
crtdsr:
sti
mov ax,0
iret
crtproc endp
PROGX ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
extrn unfixint:near
extrn zcuron:near
extrn zcuroff:near
extrn fix_intr:near
public bid
bid proc near
call unfixint ; reset shift-break vector
call zcuron ; turn the cursor back on
call install
call bid_task
push AX ; save error code
call uninstall
call zcuroff ; turn the cursor back off
call fix_intr ; set shift-break vector
pop AX ; restore error code
ret
bid endp
prog ends
end


707
sbigmath.asm Normal file
View File

@ -0,0 +1,707 @@
; =====> SBIGMATH.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Bignum Math Utilities *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: June 1984 *
;* Last Modification: 27 May 1986 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
data ends
XGROUP GROUP PROGX
PROGX segment byte public 'PROGX'
assume CS:XGROUP,DS:DGROUP
; Convert a bignum to a flonum
; Calling sequence: big2flo(bigptr,floptr)
; Where: bigptr ---- pointer to bignum workspace
; floptr ---- pointer to flonum
b2fargs struc
dw ? ;Caller's BP
dd ? ;Return address
dw ? ;Another return address
big dw ? ;Pointer to bignum
flo dw ? ;Pointer to flonum
b2fargs ends
%big2flo proc far
push BP
mov BP,SP
cld ;Direction forward
mov SI,[BP].big ;Point DS:SI to working bignum
mov CX,[SI] ;Get size
cmp CX,3
ja all64 ;Jump if at least 64 bits
add SI,3 ;Point to bignum proper
xor BX,BX
xor DI,DI
lodsw ;Fetch least sig. word
mov DX,AX ;Store in DX
dec CX
jcxz smljust ;Jump if no more bignum words
lodsw ;Else get next least sig. word
mov DI,AX
dec CX
jcxz smljust ;Jump if no more bignum words
lodsw ;Get 3rd least sig. word
mov BX,AX
smljust: xor AX,AX ;Clear most sig. word
jmp short justify ;Left-justify the number
all64: shl CX,1 ;Point SI to 4th most sig. word
add SI,CX
sub SI,5
lodsw ;Load bignum into registers
mov DX,AX
lodsw
mov DI,AX
lodsw
mov BX,AX
lodsw
;JUSTIFY: At this stage, the 64 most significant bignum bits are in
; AX:BX:DI:DX respectively, AX most significant
justify: mov SI,[BP].big ;Fetch pointer to bignum again
mov CX,[SI] ;Get size (words)
cmp CX,40h
ja toobig ;Jump if bignum too big
cmp CX,4 ;Skip if not a small bignum
jae enough
mov CX,4 ;Otherwise, start with constant
enough: shl CX,1 ;Multiply by 16 (size in bits)
shl CX,1
shl CX,1
shl CX,1
justflp: dec CX ;Reduce exponent
shl DX,1 ;Shift bignum left
rcl DI,1
rcl BX,1
rcl AX,1
jnc justflp ;Until most significant 1 vanishes
add CX,3ffh ;Add flonum exponent constant
mov SI,DI ;Now use SI for num, DI for address
shftrt: shr CX,1 ;Shift CX:AX:BX:SI:DX as one
rcr AX,1
rcr BX,1
rcr SI,1
rcr DX,1
cmp CX,80h ;Until most sig. exponent bit is in 2nd
jae shftrt ; most sig. bit of CL
mov DI,[BP].big ;Get pointer to bignum again
test byte ptr[DI]+2,1 ;Negative?
jz posskip ;No, skip
or CL,80h ;Set sign bit
posskip: mov DI,[BP].flo ;Point ES:DI to flonum
push AX ;Save part of new flonum
mov AL,DH ;Write to flonum space
stosb
mov AX,SI
stosw
mov AX,BX
stosw
pop AX
stosw
mov AL,CL
stosb
xor AX,AX ;Return 0 if all well
pop BP ;Restore BP
ret
toobig: mov AX,1 ;Return 1 if conversion impossible
pop BP
ret
%big2flo endp
; Convert fixnum to bignum
; Calling sequence: fix2big(fixnum,bigptr)
; Where: fixnum ---- Integer of small absolute value
; bigptr ---- Pointer to bignum space
f2bargs struc
dw ? ;Caller's BP
dd ? ;Return address
dw ? ;Another return address
fix dw ? ;Fixnum
bigp dw ? ;Pointer to bignum
f2bargs ends
%fix2big proc far
push BP
mov BP,SP
mov DI,[BP].bigp ;Point ES:DI to bignum
mov AX,1 ;Fill size field
stosw
xor AL,AL ;Clear AL
mov BX,[BP].fix ;Fetch fixnum value
shl BX,1 ;Put sign bit in AL
rcl AL,1
stosb ;Fill sign field
sar BX,1 ;Restore fixnum
or AL,AL ;Negative fixnum?
jz posfx ;Skip if positive
neg BX ;Otherwise, find absolute value
posfx: mov [DI],BX ;Store magnitude of fixnum
pop BP ;Restore BP
ret
%fix2big endp
;;;; Decrement bignum
;;;; Calling sequence: sub1big(buf)
;;;; Where: buf ---- pointer to bignum
;;;unibig struc
;;; dw ? ;Return address
;;;bbuf dw ? ;Pointer to working bignum
;;;unibig ends
;;; public sub1big
;;;sub1big proc far
;;; mov BX,SP ;Get bignum pointer
;;; mov SI,SS:[BX].bbuf
;;; test byte ptr[SI]+2,1 ;Is bignum negative?
;;; jnz incbig ;If so, increase magnitude
;;; jmp short decbig ;Else decrease magnitude
;;;sub1big endp
;;;; Increment bignum
;;;; Calling sequence: add1big(buf)
;;; public add1big
;;;add1big proc far
;;; mov BX,SP ;Get bignum pointer
;;; mov SI,SS:[BX].bbuf
;;; test byte ptr[SI]+2,1 ;Is bignum negative?
;;; jnz decbig ;Yes, decrease magnitude
;;;;INCBIG increments magnitude of working bignum at DS:SI
;;;incbig: mov DI,SI ;Save bignum pointer
;;; mov CX,[SI] ;Get length (words)
;;; add SI,3 ;Point to bignum proper
;;;carrylp: inc word ptr[SI] ;Increment bignum
;;; jnz done ;If no carry, finished
;;; inc SI ;Else go to next word
;;; inc SI
;;; loop carrylp ;Loop while not end of bignum
;;; mov word ptr[SI],1 ;Else place final 1
;;; inc word ptr[DI] ;Lengthen bignum
;;;done: ret
;;;;DECBIG decrements magnitude of working bignum at DS:SI
;;;decbig: mov DI,SI ;Save pointer
;;; mov CX,[SI] ;Get length
;;; add SI,3 ;Point to bignum proper
;;; dec CX ;CX = (length - 1)
;;;borrowlp: lodsw ;Load current word
;;; sub AX,1 ;Decrement and store
;;; mov [SI-2],AX
;;; jnc done ;Jump if no borrow
;;; loop borrowlp ;Loop if not on last word
;;; dec word ptr[SI] ;Else decrement last word
;;; jnz done ;Jump if bignum not to be shortened
;;; dec word ptr[DI] ;Else shorten
;;; ret
;;;add1big endp
; set up big1's index for comparison, used with %magcomp
%pbig1 proc near
shl CX,1
dec SI
add SI,CX
shr CX,1
ret
%pbig1 endp
; set up big1's index for comparison, used with %magcomp
%pbig2 proc near
shl CX,1
dec DI
add DI,CX
shr CX,1
ret
%pbig2 endp
; Compare magnitudes of two bignums
; Calling sequence: data = magcomp(big1,big2)
; Where: big1,big2 -- pointers to bignum buffers
; data ------- a positive integer as follows:
; Bit 0 set iff |BIG1| < |BIG2|
; Bit 1 set iff |BIG1| > |BIG2|
; Bit 2 set iff BIG1 < BIG2
; Bit 3 set iff BIG1 > BIG2
; Bit 4 set iff BIG1,BIG2 have same sign
twobigs struc
dd ? ;Return address
dw ? ;Another return address
big1 dw ? ;First bignum
big2 dw ? ;Second bignum
twobigs ends
%magcomp proc far
xor AL,AL ;Clear AL
xor DX,DX ; clear DX
mov BX,SP ;Fetch bignum pointers
mov SI,[BX].big1
mov DI,[BX].big2
mov AH,[SI]+2 ;Get sign bits
mov DH,[DI]+2
xor DH,AH ;Put XOR of signs into carry
shr DH,1
jc sgnskp ;Jump if different signs
or AL,16 ;Else set proper bit in AL
sgnskp: rcl AH,1
mov CX,[SI] ;Get BIG1's length
mov DX,[DI] ; get BIG2's length
cld ;Direction forward
cmpsw ;Compare lengths
jb bigr2 ;Jump if BIG2 longer
ja bigr1 ;Jump if BIG1 longer
same_ln: call %pbig1 ;If same size, point SI,DI to last words
call %pbig2 ; (most significant)
std ;Direction backward
repe cmpsw ;Repeat until unequal
jb rbig2
ja rbig1
test AH,1 ;Signs same?
jz compend ;Yes, exit
difsign: test AH,2 ;Is BIG1 positive?
jnz grtr2 ;No, BIG2 is greater
jz grtr1 ;Else BIG1 is greater
bigr1: call %pbig1
cmp word ptr [SI],0 ; check high word,
jne rbig1 ; big1 is really bigger
mov SI,[BX].big1 ; restore SI
inc SI
inc SI
dec CX ; high order word is empty
cmp CX,DX ; compare length's again
je same_ln ; same length
jmp bigr1 ; repeat until unequal or same lengths
rbig1: or AL,2 ;Set the |BIG1|>|BIG2| bit
test AH,1 ;Signs same?
jnz difsign ;No, different signs
test AH,2 ;Both positive?
jnz grtr2 ;No, so BIG2 is greater
grtr1: or AL,8 ;Set the BIG1>BIG2 bit
cld ; Set direction forward (JCJ-12/6/84)
ret
bigr2: push CX
mov CX,DX ; swap CX and DX
pop DX
call %pbig2 ; Set up big2's pointers
cmp word ptr [DI],0 ; check high word
jne rbig2 ; big2 really is bigger
mov DI,[BX].big2 ; restore DI
inc DI
inc DI
dec CX ; high order word is empty
cmp DX,CX ; compare length's again
je same_ln ;
jmp bigr2 ; repeat until unequal or same lengths
rbig2: or AL,1 ;Set the |BIG1|<|BIG2| bit
test AH,1 ;Signs same?
jnz difsign ;No, different signs
test AH,2 ;Both positive?
jnz grtr1 ;No, BIG1 is greater
grtr2: or AL,4 ;Set the BIG1<BIG2 bit
compend: cld ; Set direction forward (JCJ-12/6/84)
ret
%magcomp endp
; Add magnitudes of bignums
; Calling sequence: bigadd(big1,big2)
; Where: big1 ---- bignum of lesser magnitude
; big2 ---- bignum of greater magnitude
; When done, BIG2 will hold the sum
%bigadd proc far
mov BX,SP ;Fetch bignum pointers
mov SI,[BX].big1
mov DI,[BX].big2
cld ;Direction forward
lodsw ;Get length of smaller bignum
mov CX,AX ;Save length
sub AX,[DI] ;Find and push difference in lengths
neg AX
push AX
inc SI ;Point SI,DI to bignums proper
add DI,3
clc ;Prepare to add
addlp: lodsw ;Fetch source addend
adc [DI],AX ;Add to destination addend
inc DI ;Point DI to next word
inc DI
loop addlp ;Do until smaller bignum exhausted
pop CX ;Fetch length difference (CF unchanged)
jnc doneadd ;Stop if no carry
mov SI,[BX].big2 ;Point SI to destination bignum
jcxz samlen ;Jump if bignums the same length
adclp: inc word ptr[DI] ;Otherwise, add carry
jnz doneadd ;Jump if no resultant carry
add DI,2 ;Point DI to next word
loop adclp ;Do until whole number is done or no carry
samlen: mov word ptr[DI],1 ;Store last carry
inc word ptr[SI] ;Note bignum's size increase
doneadd: ret
%bigadd endp
; Subtract magnitudes of bignums
; Calling sequence: bigsub(big1,big2)
; Where: big1 ---- bignum of lesser magnitude
; big2 ---- bignum of greater magnitude
; When done, BIG2 will hold the difference
; When done, BIG2 will hold the sum
%bigsub proc far
mov BX,SP ;Fetch pointers to bignums
mov SI,[BX].big1
mov DI,[BX].big2
cld ;Direction forward
lodsw ;Get length of smaller bignum
mov CX,AX
inc SI ;Point SI,DI to bignums proper
add DI,3
clc ;Prepare to subtract
sublp: lodsw ;Fetch subtrahend
sbb [DI],AX ;Subtract
inc DI ;Point DI to next word
inc DI
loop sublp ;Do until smaller bignum exhausted
jnc pack ;Jump if no borrow
borlp: mov AX,[DI] ;Fetch word
sub AX,1 ;Decrement and store
stosw
jc borlp ;Jump if further borrowing needed
pack: mov DI,[BX].big2 ;Fetch pointer to 2nd bignum
mov SI,DI ;Save pointer in SI
mov AX,[SI] ;Fetch bignum length
mov CX,AX ;Save (length-1) in CX
dec CX
shl AX,1 ;Point DI to last word of bignum
inc AX
add DI,AX
std ;Direction backward
xor AX,AX ;Find number of leading 0-words
repe scasw ; (not counting least sig. word)
jz smlskp ;Jump if only one non-0 word
inc CX ;Else, at least 2 non-0 words
smlskp: inc CX ;Form (length - # of leading 0-words)
mov [SI],CX ;Save in bignum size field
cld ;Clear the direction flag
ret
%bigsub endp
; Multiply two bignums
; Calling sequence: bigmul(big1,big2,big3)
; Where: big1,big2 -- factors
; big3 ------- destination of product
mulargs struc
carry dw ? ;Multiplication carry
dw ? ;Caller's BP
dd ? ;Return address
dw ? ;Another return address
mbig1 dw ? ;Factor of greater magnitude
mbig2 dw ? ;Factor of lesser magnitude
mbig3 dw ? ;Product destination
mulargs ends
; When done, BIG2 will hold the sum
%bigmul proc far
push BP ;Save BP
dec SP ;Create space for multiplication carry
dec SP
mov BP,SP ;Point BP to args
cld ;Direction forward
mov SI,[BP].mbig1 ;Fetch factor pointers
mov DI,[BP].mbig2
lodsw ;Fetch BIG1's length
mov CX,AX ;Put sum of lengths in CX
add CX,[DI]
scasw ;Which has greater magnitude?
jae xchgskp ;Jump if BIG1 is not smaller
xchg DI,SI
xchgskp: lodsb ;Fetch one factor's sign
xor AL,[DI] ;XOR with the other factor's sign
inc DI ;Point DI to bignum proper
mov BX,DI ;And store in BX
mov DI,[BP].mbig3 ;Store length into product
xchg AX,CX
stosw
push AX ;Save total length of product
xchg AX,CX ;Store sign byte into product
stosb
push DI ;Set product to 0 over whole length
xor AX,AX
rep stosw
pop DI
xchg DI,BX ;Restore BX and DI
mov CX,[DI]-3 ;Fetch length of BIG2
sub BX,SI ;Point [BX+SI-2] to product
dec BX
dec BX
mov [BP].mbig1,SI ;Store pointer to data of BIG1
mullp2: push CX ;Save counter of BIG2 words
;Add (BIG1*part of BIG2) to current product
mov word ptr[BP].carry,0 ;Clear carry in
mov SI,[BP].mbig1 ;Fetch bignum pointer
mov CX,[SI]-3 ;Get number of words in bignum
mullp: lodsw ;Get factor part from BIG1
mul word ptr[DI] ;Multiply by factor part from BIG2
add AX,[BP].carry ;Add carry in
adc DX,0
add [BX+SI],AX ;Add product part into BIG3
adc DX,0 ;Adjust and store carry
mov [BP].carry,DX
loop mullp ;Continue for all BIG1
mov [BX+SI+2],DX ;Store carry remaining
;
pop CX ;Restore BIG2 counter
inc DI ;Point DI to next word in BIG2
inc DI
inc BX ;Point BX to next word in BIG3
inc BX
loop mullp2 ;Continue for all BIG2
mov BX,[BP].mbig3 ;Fetch pointer to BIG3 (beginning)
pop SI ;Point SI to last word of product
shl SI,1
inc SI
add SI,BX
cmp word ptr[SI],0 ;Test last word for zero
jnz muldone ;Done if not zero
dec word ptr[BX] ;Decrement bignum length
muldone: inc SP ;Discard temporary carry variable
inc SP
pop BP ;Restore BP
ret
%bigmul endp
; Divide one bignum by another
; Calling sequence: bigdiv(dvdnd,dvsr,quot)
; Where: dvdnd ----- dividend
; dvsr ------ divisor
; quot ------ quotient
divargs struc
dw ? ;Caller's BP
dvsrsz dw ? ;Size of divisor (words)
bitcount dw ? ;Estimated bits in quotient
align dw ? ;Alignment of dividend to divisor
ldvsr dw ? ;Pointer to last word of divisor
dd ? ;Return address
dw ? ;Another return address
dvdnd dw ? ;Dividend
dvsr dw ? ;Divisor
quot dw ? ;Quotient
divargs ends
; When done, BIG2 will hold the sum
%bigdiv proc far
sub SP,8 ;Room for local variables
push BP
mov BP,SP
mov DI,[BP].quot ;Get pointers to arguments
mov SI,[BP].dvdnd
mov BX,[BP].dvsr
cld ;Direction forward
lodsw ;Get dividend length
mov CX,[BX] ;Fetch divisor length
cmp CX,1 ;Check divisor for 0
jne dvsrok
cmp word ptr[BX]+3,0 ;Check divisor data word
jnz dvsrok
mov AX,CX ;Put nonzero value in AX
pop BP
add SP,8 ;Restore stack
ret ;Exit
dvsrok: inc BX ;Point BX+1 to divisor sign
mov DX,CX ;Find & store pointer to last divisor word
shl DX,1
add DX,BX
mov [BP].ldvsr,DX
sub AX,CX ;Find dividend-divisor length difference
mov DX,AX ;Save in DX for now
inc AX ;Store maximum quotient length (words)
stosw
inc CX ;Save length of working divisor
mov [BP].dvsrsz,CX
dec AX ;Find and store quotient bit count
shl AX,1
shl AX,1
shl AX,1
shl AX,1
inc AX
mov [BP].bitcount,AX
lodsb ;Get dividend sign
xor AL,[BX]+1 ;Find and store quotient sign
stosb
mov [BP].dvdnd,SI ;Save pointer to dividend proper
mov [BP].quot,DI ;Save pointer to quotient proper
xor AX,AX ;Zero first two words of quotient
stosw
std
stosw
dec DX ;Account for extra divisor word
shl DX,1 ;Store divisor-dividend alignment
add DX,SI
mov [BP].align,DX
mov word ptr[BX],0 ;Put 0-word at start of divisor
mov [BP].dvsr,BX ;Save pointer to working divisor
bigdivlp: call divcmp ;Dividend less than aligned divisor?
jb divbit0 ;Yes, perform division
test word ptr[BX],8000h ;Can divisor be shifted left?
jnz divbit1 ;No, perform division
mov SI,[BP].dvsr ;Otherwise, shift entire divisor left
mov CX,[BP].dvsrsz
clc ;Start by shifting in 0
shllp: rcl word ptr[SI],1 ;Shift through divisor word
inc SI ;Point SI to next word
inc SI
loop shllp ;Do for entire divisor
inc [BP].bitcount ;Increase bit count
jmp bigdivlp ;See if divisor is big enough yet
divlp: call divcmp ;Dividend less than aligned divisor?
cld ; (Direction forward)
jb divbit0 ;Yes, rotate 0 into quotient
mov SI,[BP].align ;Otherwise, subtract divisor
mov DI,SI
mov BX,[BP].dvsr
sub BX,SI
dec BX
dec BX
mov CX,[BP].dvsrsz
clc ;No carry in
divsublp: lodsw
sbb AX,[SI+BX]
stosw
loop divsublp
divbit1: clc ;Clear carry (to rotate 1 in)
divbit0: cmc
mov SI,[BP].quot ;Fetch pointer to quotient
mov CX,[SI]-3 ;Fetch quotient length
quotlp: rcl word ptr[SI],1 ;Rotate bit in
inc SI
inc SI
loop quotlp ;Rotate bits through whole quotient
dec [BP].bitcount ;Last quotient bit rotated in?
jz divdone ;Yes, stop
mov SI,[BP].ldvsr ;Otherwise realign divisor (shr)
mov CX,[BP].dvsrsz
std ;Direction backward
cmp word ptr[SI],0 ;Time to shift divisor words?
jnz wshftskp ;No, don't bother
mov BX,SI ;Save last word pointer
mov DX,CX ;Save word count
mov DI,SI ;Destination = source+2
dec SI
dec SI
dec CX ;Shift significant divisor words
rep movsw
xor AX,AX ;Clear least significant word
stosw
mov SI,BX ;Restore last word pointer
mov CX,DX ;Restore count
sub [BP].align,2 ;Reset divisor alignment
wshftskp: clc ;Shift 0 in
shrlp: rcr word ptr[SI],1 ;Shift
dec SI
dec SI
loop shrlp ;Shift entire divisor
jmp divlp ;After all this, loop 'til division done
divdone: mov BX,[BP].dvdnd ;Fetch dividend pointer
mov DI,[BX]-3 ;Fetch former length of dividend
dec DI ;Put length-1 in CX
mov CX,DI
shl DI,1 ;Point DI to last dividend word
add DI,BX
std ;Direction backward
xor AX,AX ;Pack as in BIGSUB
repe scasw
jz smlskp2
inc CX
smlskp2: inc CX
mov [BX]-3,CX ;Save in bignum size field
mov BX,[BP].quot ;Fetch quotient pointer
mov DI,[BX]-3 ;Point BX+DI to last quotient word
dec DI
shl DI,1
cmp word ptr[BX+DI],0 ;If last word is 0, decrease length
jnz divex
dec word ptr[BX]-3
divex: pop BP ;Restore stack
add SP,8
xor AX,AX ;Return 0
cld ;Clear direction flag
ret
%bigdiv endp
;Compare working divisor to dividend
divcmp proc near
mov DI,[BP].ldvsr ;Get pointer to last divisor word
mov CX,[BP].dvsrsz ;Fetch number of compares to do
mov SI,[BP].align ;Get dividend pointer
mov AX,CX ;Save # of wrods for pointer adjust
cmp SI,[BP].dvdnd ;Dividend longer than divisor?
jae adjskp ;Yes, jump
dec CX ;Don't compare first divisor word
adjskp: dec AX ;Adjust pointer into dividend
shl AX,1
add SI,AX
mov BX,DI ;Save pointer to last divisor byte
std ;Direction backward
repz cmpsw ;Compare until unequal
ret
divcmp endp
PROGX ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public big2flo
big2flo proc near
call %big2flo
ret
big2flo endp
public fix2big
fix2big proc near
call %fix2big
ret
fix2big endp
public magcomp
magcomp proc near
call %magcomp
ret
magcomp endp
public bigadd
bigadd proc near
call %bigadd
ret
bigadd endp
public bigsub
bigsub proc near
call %bigsub
ret
bigsub endp
public bigmul
bigmul proc near
call %bigmul
ret
bigmul endp
public bigdiv
bigdiv proc near
call %bigdiv
ret
bigdiv endp
prog ends
end


1277
sc.asm Normal file
View File

File diff suppressed because it is too large Load Diff

453
scannum.asm Normal file
View File

@ -0,0 +1,453 @@
; =====> SCANNUM.ASM
;****************************************
;* TIPC Scheme '84 Runtime Support *
;* Numeric I/O Support *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 12 June 1985 *
;* Last Modification: 22 July 1985 *
;****************************************
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public decpoint
decpoint db '.'
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
; Classify numeric string ending with a control character
; Calling sequence: scannum(s,base)
; Where ---- s: pointer to start of character string
; base: default base
; This function returns 0 if not a number, -1 if a flonum, and n>0
; if an integer, where n is the number of digits in the integer.
;
; NOTE : DS is not guaranteed to point to the local data segment
;
scanargs struc
dw ? ;Caller's BP
dw ? ;Return address
sptr dw ? ;Pointer to string
scanbase dw ? ;Default base
scanargs ends
public scannum
scannum proc near
push BP
mov BP,SP
cld ;Direction forward
mov SI,[BP].sptr ;Point DS:SI to characters
mov BX,[BP].scanbase ;Set default base
xor CX,CX ;Initialize digit count
baselp: lodsb ;Fetch first char
cmp AL,'#' ;Skip over the base macros
jne nomac
lodsb ;Get base argument
sub AL,40h
js nonnum ;If not a base designator, not a number
and AL,0dfh ;Shift to upper case
xor BL,BL ;Zero current base
cmp AL,5 ;Check for #E,#I,#L,#S macros
je baselp ; (legal, but don't affect base)
cmp AL,9
je baselp
cmp AL,12
je baselp
cmp AL,19
je baselp
cmp AL,2 ;Jump if binary (#B)
je bbin
cmp AL,4 ;Jump if decimal (#D)
je bdec
cmp AL,15 ;Jump if octal (#O)
je boct
cmp AL,24 ;Jump if hexadecimal (#X)
je bhex
cmp AL,8 ;Jump if not #H (the only legal one left)
jne nonnum
bhex: mov BL,6
bdec: add BL,2
boct: add BL,6
bbin: add BL,2
jmp baselp ;Check for another switch
nomac: cmp AL,'+' ;If +, note its presence
je wassign
cmp AL,'-' ;If not -, skip next char fetch
jne notsign
wassign: lodsb ;Fetch next char
notsign: cmp AL,ss:decpoint ;Decimal point already?
je point1 ;Jump if so... must be a flonum
call isdg ;Otherwise, there must be a digit
jnc nonnum ;If not, not a number
wholelp: lodsb ;Else get next character
call isdg
jc wholelp ;Keep reading digits in whole part
cmp AL,32 ;End of string?
jb intnum ;Yes, we have an integer
cmp AL,ss:decpoint ;Jump on decimal point
je point
call ismarker ;Jump if exponent marker (E or L valid)
je expon
nonnum: xor AX,AX ;Return 0, forget all else
pop BP
ret
intnum: mov AX,CX ;Return digit count
pop BP
ret
point1: lodsb ;We must have digit here
call isdg
jnc nonnum
point: lodsb ;Get characters up to non-digit
call isdg
jc point
cmp AL,32 ;If end of string, we have flonum
jb flonum
call ismarker ;Otherwise, check for exponent marker
je expon
jne nonnum
expon: mov BL,10 ;Exponents are in base 10
lodsb ;Get next char
cmp AL,'-' ;Valid exponent sign
jne edig ;Jump if not signed
lodsb ;Else get next char
edig: call isdg ;We must end with a nonempty string
jnc nonnum ; of base 10 digits
exponlp: lodsb
call isdg
jc exponlp
cmp AL,32 ;If not end of string, nonnum
jae nonnum
flonum: mov AX,-1 ;Return -1 (flonum code)
pop BP
ret
;ISDG: CF is set iff the char in AL is a digit in base BX
; Also, if a digit, the digit count in CX is incremented
isdg: cmp AL,'0' ;Not if below 0
jl nodig
cmp AL,'1' ;0 or 1 anytime
jbe yesdig
cmp BL,2 ;Nothing else for base 2
je nodig
cmp AL,'7' ;2-7 for base 8,10,16
jbe yesdig
cmp BL,8 ;Nothing else for base 8
je nodig
cmp AL,'9' ;8 or 9 for bases 10 or 16
jbe yesdig
cmp BL,10 ;Nothing else for base 10
je nodig
and AL,0dfh ;Convert to upper case
cmp AL,'A' ;Base 16... Check for A-F
jb nodig
cmp AL,'F'
jbe yesdig
nodig: clc
ret
yesdig: inc CX ;Increment digit count
stc
ret
;ISMARKER: ZF is set iff the character in AL is an exponent marker
ismarker: cmp AL,'e'
je mark
cmp AL,'l'
je mark
cmp AL,'E'
je mark
cmp AL,'L'
je mark
mark: ret
scannum endp
; Check character for digit status in a given base
; Calling sequence: isdig(c,base)
; Where ---- c: character to check
; base: base in which to check
isdargs struc
dw ? ;Caller's BP
dw ? ;Return address
charg dw ? ;Character
barg dw ? ;Base
isdargs ends
public isdig
isdig proc near
push BP
mov BP,SP
mov AL,byte ptr[BP].charg ;Fetch character
mov BX,[BP].barg ;Fetch base
call isdg ;Determine digitness
jc wasdg ;Was a digit...don't zero AX
xor AX,AX ;Otherwise return 0
wasdg: pop BP
ret
isdig endp
; Convert digit character to its value
; Calling sequence: digval(c)
; Where ---- c: assumed to be a digit character
digargs struc
dw ? ;Caller's BP
dw ? ;Return address
carg dw ? ;Character
digargs ends
public digval
digval proc near
push BP
mov BP,SP
mov AL,byte ptr[BP].carg ;Fetch character
xor AH,AH
and AL,01fh ;Reduce bits
cmp AL,16 ;Number or letter?
jb hexdig ;Jump if letter
and AL,0fh ;Zero the high nibble
pop BP
ret
hexdig: add AL,9 ;Raise the lower nibble
pop BP
ret
digval endp
; Convert flonum in interval [1.0e15,1.0e16) to bignum
; Calling sequence: flo2big(flo,buf)
; Where ---- flo: flonum in interval [1e15,1e16)
; buf: bignum math buffer, minimum size 11 bytes
flo2args struc
dw ? ;Caller's BP
dw ? ;Return address
num dw ?,?,?,? ;Flonum (4 words)
big dw ? ;Pointer to math buffer
flo2args ends
public flo2big
flo2big proc near
push BP
mov BP,SP
mov DI,[BP].big ;Point DI to math buffer
cld ;Direction forward
mov AX,4 ;Store bignum size (words) in buffer
stosw
mov AX,[BP+6].num ;Fetch exponent
mov CX,AX ;Save exponent in CX
rol AX,1 ;Store sign in buffer
and AL,1
stosb
mov AX,CX ;Restore exponent to AX
xor CH,CH ;Put (433h-exponent) in CX
shr CL,1
shr CL,1
shr CL,1
shr CL,1
sub CL,3
neg CL
and AX,0fh ;Remove exponent from word in AX
or AL,10h
lea SI,[BP].num ;Point SI to flonum
movsw
movsw
movsw
stosw ;Word that used to have exponent
sub DI,8 ;Point DI back to start of bignum
cmp CL,-1 ;Branch if mantissa to be shifted left
je manleft
or CL,CL ;Branch if not to be shifted right
jz shifted
manright: shr word ptr[DI+6],1 ;Shift bignum right
rcr word ptr[DI+4],1
rcr word ptr[DI+2],1
rcr word ptr[DI],1
loop manright ;Loop until done
jmp short shifted
manleft: shl word ptr[DI],1 ;Shift bignum left
rcl word ptr[DI+2],1
rcl word ptr[DI+4],1
rcl word ptr[DI+6],1
shifted: pop BP
ret
flo2big endp
; Form floating-point ASCII representation from 16 digits and scale
; Calling sequence: formflo(digs,chars,scale,prec,exp)
; Where ---- digs: the digit characters of the flonum
; chars: buffer to store the formed flonum
; scale: flonum exponent part
; prec: desired precision
; exp: whether to use exponential format
; Returns the length of the formed flonum string
formargs struc
dw ? ;Caller's BP
dw ? ;Return address
digptr dw ? ;Pointer to digits
chrptr dw ? ;Pointer to result string
scale dw ? ;Exponent part
fprec dw ? ;Precision
fexp dw ? ;Exponential format specifier
formargs ends
public formflo
formflo proc near
push BP
mov BP,SP
mov SI,[BP].digptr ;Point SI to digit string
mov DI,[BP].chrptr ;Point DI to destination
cld ;Direction forward
mov DX,[BP].fexp ;Fetch form specifier
mov AL,[SI] ;Fetch first digit
cmp AL,'0'
je toosmall ;Jump if zero
cmp AL,'-' ;Negative sign?
jne nonsign ;Jump if not signed
signed: stosb ;Put sign in return buffer
inc [BP].digptr ;Adjust pointer to first digit
inc SI
nonsign: mov BX,14 ;Round off the last digit
call round
mov BX,[BP].fprec ;Fetch precision
or BX,BX
jz putspace ;Jump if arbitrary precision
;Determine location at which to begin rounding
cmp BX,14 ;If precision out of range, replace
jbe precok ; with highest possible
mov BX,14
precok: or DX,DX
jnz doround ;If exponential, round now
add BX,[BP].scale ;Add scale to precision
jns notsmall ;Jump unless number rounds to 0
cmp BX,-1
jne toosmall ;Jump if num definitely rounds to 0
cmp byte ptr[SI],'5' ;Check sigfig
jb toosmall ;Jump if too small
mov word ptr[SI],2031h ;Else round up and adjust scale
inc [BP].scale
jmp short spaced
toosmall: mov AL,'0' ;Put (prec+1) 0's at start of input
mov BX,[BP].fprec ; buffer
toosmlp: mov [SI],AL
inc SI
dec BL
jns toosmlp
mov byte ptr[SI],' ' ;Follow by space
mov DI,[BP].chrptr ;Start output over (wipe out any sign)
jmp short spaced
notsmall: cmp BX,16
jae spaced ;Jump if no sense in rounding
doround: call round ;Round the digits
jmp short spaced
;For arbitrary precision, change all trailing zeros to spaces
; (there exists at least one nonzero digit)
putspace: add SI,14 ;Point SI to last digit
spacelp: cmp byte ptr[SI],'0'
jne spaced
and byte ptr[SI],0efh
dec SI
jmp spacelp
;Now the spaces are in - start formatting
spaced: mov SI,[BP].digptr ;Point SI to digit string
mov BX,[BP].scale ;Fetch scale
mov CX,[BP].fprec ;Fetch precision
or DX,DX ;If exponent form desired
jnz exform ; supply it
cmp BX,-14 ;If scale>-15, check precision
jge midscale
or CL,CL ;If precision arbitrary, force expo-form
jz exform
midscale: cmp BX,0
jl smallfix ;Branch if explicit form called for
cmp BX,14
jle largefix ;Branch if explicit, but >1
;Form an exponential-format flonum
exform: movsb ;Transfer first digit
mov AL,decpoint ;Place decimal point
placex: stosb ;Store character
lodsb ;Transfer digits up to first space
cmp AL,' '
jne placex
mov AL,'e' ;Place exponent marker
stosb
cmp BH,0 ;If scale negative, negate & store sign
jge posscale
neg BX
mov AL,'-'
stosb
posscale: mov AX,BX ;Move scale to AX
mov BH,10 ;Put divisor in BH
mov DX,SP ;Save current stack pointer
divlpf: div BH ;Divide
mov BL,AH ;Push digit
add BL,'0'
push BX
xor AH,AH ;Remove the remainder
or AL,AL ;Loop until the quotient is zero
jnz divlpf
storelp: pop AX ;Restore exponent digit
stosb ;Place it
cmp SP,DX ;Loop until no more digits left
jne storelp
jmp short retlen
;Form a fixed-decimal flonum magnitude greater than 1
largefix: lodsb ;Fetch digit
or AL,10h ;Turn ' ' to '0'
stosb ;Store digit
dec BL ;Loop until all pre-point digs done
jns largefix
mov AL,decpoint ;Place decimal point
stosb
digmrg: or CL,CL
jnz preclp ;Jump if precision set
arblp: lodsb ;Otherwise, arbitrary; do until space
cmp AL,' '
je retlen
stosb
jmp arblp
llp: stosb
preclp: dec CL ;Last digit done?
js retlen ;Jump if so
dodigs: lodsb ;Now do digits until precision reached
cmp AL,' ' ;Space?
jne llp ;If not, store it
dec SI ;Restore SI
mov AL,'0' ;Prepare to place 0
jmp llp
;Form a fixed-decimal flonum magnitude less than 1
smallfix: mov CH,CL ;Copy precision to CH
mov AL,'0' ;Place "0."
stosb
mov AL,decpoint
slp: stosb
inc BX
jz digmrg ;If 0's done, do significant figures
or CH,CH ;If precision was zero
jz skpprec ; don't bother checking it
dec CL
js retlen ;If the precision is reached, stop
skpprec: mov AL,'0' ;Otherwise, place 0's until scale=0
jmp slp
;Formation complete
retlen: mov AX,DI ;Return length of string
sub AX,[BP].chrptr
pop BP
ret
;ROUND: Round the ASCII digits of a flonum, starting at [BX+SI]
; SI->start of digits and is unchanged; BX destroyed
round: mov AL,' ' ;Get digit after least-rounded and
xchg AL,[BX+SI+1] ; replace it with a space
cmp AL,'5'
jb rounded ;Jump if rounded down
roundlp: mov AL,[BX+SI] ;Otherwise, increment digit
inc AL
mov [BX+SI],AL ;Replace incremented digit
cmp AL,'9'
jbe rounded ;Jump if no carryover
mov byte ptr[BX+SI],'0' ;Else replace digit
dec BX ;Go to next digit
jns roundlp
mov byte ptr[BX+SI+1],'1' ;There are no more digits, place
inc [BP].scale ; leading 1 and adjust scale
rounded: ret
formflo endp
prog ends
end


651
scar_cdr.asm Normal file
View File

@ -0,0 +1,651 @@
; =====> SCAR_CDR.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;*Interpreter -- Car and Cdr operations*
;* *
;* (C) Copyright 1984,1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 11 September 1984 *
;* Last Modification: 26 February 1986*
;***************************************
include scheme.equ
; Modification History:
; 26 Feb 86 - modified the "CONS" support to attempt a "short circuit"
; (JCJ) allocation of a list cell, instead of calling the
; "alloc_list_cell" support unconditionally.
include sinterp.mac
include sinterp.arg
take_car macro
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[SI].car_page
mov SI,ES:[SI].car
endm
take_cdr macro
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_cdr
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[SI].cdr_page
mov SI,ES:[SI].cdr
endm
; load arguments for cxr
load_arg macro
lods word ptr ES:[SI] ; fetch source/destination register numbers
save <SI> ; save the location pointer
mov BL,AH ; copy the source register number
mov SI,reg0_dis+[BX] ; load contents of the source register
mov BL,byte ptr reg0_pag+[BX]
endm
car_cdr2 macro arg1,arg2
mov CX,offset PGROUP:arg1&_last
mov DI,offset PGROUP:arg2&_CX
jmp load_ops
endm
car_cdr3 macro arg1,arg2,arg3
mov DX,offset PGROUP:arg1&_last
mov CX,offset PGROUP:arg2&_DX
mov DI,offset PGROUP:arg3&_CX
jmp load_ops
endm
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_car db "CAR",0
m_cdr db "CDR",0
m_caar db "CAAR",0
m_cadr db "CADR",0
m_cdar db "CDAR",0
m_cddr db "CDDR",0
m_caaar db "CAAAR",0
m_caadr db "CAADR",0
m_cadar db "CADAR",0
m_caddr db "CADDR",0
m_cdaar db "CDAAR",0
m_cdadr db "CDADR",0
m_cddar db "CDDAR",0
m_cdddr db "CDDDR",0
m_cadddr db "CADDDR",0
m_%car db "%CAR",0
m_%cdr db "%CDR",0
m_table dw m_car,m_cdr,m_caar,m_cadr,m_cdar,m_cddr,m_caaar,m_caadr
dw m_cadar,m_caddr,m_cdaar,m_cdadr,m_cddar,m_cdddr,m_cadddr
m_setcar db "SET-CAR!",0
m_setcdr db "SET-CDR!",0
m_apendb db "APPEND!",0
m_ltail db "LIST_TAIL",0
m_one dw 1 ; a constant "one" (1)
m_two dw 2 ; a constant "two" (2)
m_three dw 3 ; a constant "three" (3)
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
car_cdr proc near
; Entry points defined in "sinterp.asm"
extrn next:near ; Top of interpreter
extrn next_PC:near ; Reload ES,SI at top of interpreter
extrn next_SP:near ; Reload SP,ES,SI at top of interpreter
extrn src_err:near ; "source operand error" message display
extrn sch_err:near ; "source operand error" message display
extrn printf_c:near ; Error message print routine
;************************************************************************
;* %car %CAR DEST *
;* *
;* Purpose: To obtain the first element of a list. This support is *
;* similar to the usual "car" operation except that %car *
;* returns #!unassigned if one tries to take the car of *
;* nil. *
;************************************************************************
public ld_car1
ld_car1: lods byte ptr ES:[SI] ; load operand
save <SI> ; save the location pointer
mov BX,AX ; copy operand register number to BX
mov SI,reg0_dis+[BX] ; load the source operand
mov BL,byte ptr reg0_pag+[BX]
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car1 ; if not a list cell, error (jump)
cmp BL,0 ; is source operand nil?
jne car_last ; if not nil, jump
cxr_undf: mov BX,AX ; reload dest register number
mov byte ptr reg0_pag+[BX],UN_PAGE*2 ; set destination reg
mov reg0_dis+[BX],UN_DISP ; to #!unassigned
jmp next_PC
bad_car1: mov AX,offset m_%car
jmp bad_one
;************************************************************************
;* %cdr %CDR DEST *
;* *
;* Purpose: To obtain the rest of a list. This support is similar *
;* to the usual "cdr" operation except that %cdr returns *
;* #!unassigned if one tries to take the cdr of nil. *
;************************************************************************
public ld_cdr1
ld_cdr1: lods byte ptr ES:[SI] ; load operand
save <SI> ; save the location pointer
mov BX,AX ; copy operand register number to BX
mov SI,reg0_dis+[BX] ; load the source operand
mov BL,byte ptr reg0_pag+[BX]
cmp BL,0 ; is source operand nil?
je cxr_undf ; if nil, return #!unassigned (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2
je cdr_last ; if a list cell, continue processing (jump)
jmp bad_cdr1 ; if not a list cell, error (jump)
bad_cdr1: mov AX,offset m_%cdr
jmp bad_one
;************************************************************************
;* AL AH *
;* Take "car" of a list cell LD_CAR dest,src *
;************************************************************************
public ld_car
ld_car: load_arg
car_last: cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car ; if not a list cell, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load para addr of page containing cell
mov BL,AL ; copy destination register number
mov AL,ES:[SI].car_page ; copy contents of car field into
mov byte ptr reg0_pag+[BX],AL ; the destination register
mov AX,ES:[SI].car
mov reg0_dis+[BX],AX
jmp next_PC ; return to the interpreter
car_CX: take_car
jmp CX
car_DX: take_car
jmp DX
;************************************************************************
;* AL AH *
;* Take "cdr" of a list cell LD_CDR dest,src *
;************************************************************************
public ld_cdr
ld_cdr: load_arg
cdr_last: cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_cdr ; if not a list cell, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load para addr of page containing cell
mov BL,AL ; copy destination register number
mov AL,ES:[SI].cdr_page ; copy contents of cdr field into
mov byte ptr reg0_pag+[BX],AL ; the destination register
mov AX,ES:[SI].cdr
mov reg0_dis+[BX],AX
jmp next_PC ; return to the interpreter
; ***Error-- attempt to take "car" of non- list cell***
bad_car:
; ***Error-- attempt to take "cdr" of non- list cell***
bad_cdr: les SI,dword ptr [BP].save_SI ; load next instruction's address
xor BX,BX ; load opcode of failing instruction
mov BL,ES:[SI]-3
shl BX,1
mov AX,m_table+[BX]-128
bad_one: les SI,dword ptr [BP].save_SI ; load next instruction's address
xor BX,BX
mov BL,ES:[SI]-1 ; load register used as last operand
add BX,offset reg0
pushm <BX,m_one,AX>
C_call set_src_,,Load_ES
jmp sch_err ; display error message
cdr_CX: take_cdr
jmp CX
cdr_DX: take_cdr
jmp DX
;************************************************************************
;* AL AH *
;* Take "cadddr" of a list cell LD_CADDDR dest,src *
;************************************************************************
public ld_caddd
ld_caddd: load_arg
take_cdr
mov DX,offset PGROUP:car_last
mov CX,offset PGROUP:cdr_DX
jmp cdr_CX
load_ops: load_arg
jmp DI
;************************************************************************
;* AL AH *
;* Take "caar" of a list cell LD_CAAR dest,src *
;************************************************************************
public ld_caar
ld_caar: car_cdr2 car,car
;************************************************************************
;* AL AH *
;* Take "cadr" of a list cell LD_CADR dest,src *
;************************************************************************
public ld_cadr
ld_cadr: car_cdr2 car,cdr
;************************************************************************
;* AL AH *
;* Take "cdar" of a list cell LD_CDAR dest,src *
;************************************************************************
public ld_cdar
ld_cdar: car_cdr2 cdr,car
;************************************************************************
;* AL AH *
;* Take "cddr" of a list cell LD_CDDR dest,src *
;************************************************************************
public ld_cddr
ld_cddr: car_cdr2 cdr,cdr
;************************************************************************
;* AL AH *
;* Take "caaar" of a list cell LD_CAAAR dest,src *
;************************************************************************
public ld_caaar
ld_caaar: car_cdr3 car,car,car
;************************************************************************
;* AL AH *
;* Take "caadr" of a list cell LD_CAADR dest,src *
;************************************************************************
public ld_caadr
ld_caadr: car_cdr3 car,car,cdr
;************************************************************************
;* AL AH *
;* Take "cadar" of a list cell LD_CADAR dest,src *
;************************************************************************
public ld_cadar
ld_cadar: car_cdr3 car,cdr,car
;************************************************************************
;* AL AH *
;* Take "caddr" of a list cell LD_CADDR dest,src *
;************************************************************************
public ld_caddr
ld_caddr: car_cdr3 car,cdr,cdr
;************************************************************************
;* AL AH *
;* Take "cdaar" of a list cell LD_CDAAR dest,src *
;************************************************************************
public ld_cdaar
ld_cdaar: car_cdr3 cdr,car,car
;************************************************************************
;* AL AH *
;* Take "cdadr" of a list cell LD_CDADR dest,src *
;************************************************************************
public ld_cdadr
ld_cdadr: car_cdr3 cdr,car,cdr
;************************************************************************
;* AL AH *
;* Take "cddar" of a list cell LD_CDDAR dest,src *
;************************************************************************
public ld_cddar
ld_cddar: car_cdr3 cdr,cdr,car
;************************************************************************
;* AL AH *
;* Take "cdddr" of a list cell LD_CDDDR dest,src *
;************************************************************************
public ld_cdddr
ld_cdddr: car_cdr3 cdr,cdr,cdr
;************************************************************************
;* Macro support for set-car!/set-cdr! *
;************************************************************************
set_cc macro field
local x
lods word ptr ES:[SI] ; load register numbers
mov DX,ES ; save TIPC register ES
mov BL,AL
mov DI,reg0_pag+[BX] ; load dest register page number
cmp DI,0 ; are we trying to set car/cdr of nil?
je x ; if (set-cxr nil v), error (jump)
cmp byte ptr ptype+[DI],LISTTYPE*2 ; Is destination a list cell?
jne x ; If not, set_field! not defined
LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; Load paragraph addr for dest page
mov DI,reg0_dis+[BX] ; Load destination displacement
mov BL,AH ; Copy src register number
mov AL,byte ptr reg0_pag+[BX] ; redefine field's page number
mov ES:[DI].&field&_page,AL
mov AX,reg0_dis+[BX] ; redefine field's displacement
mov ES:[DI].&field,AX
mov ES,DX ; reload ES segment register
jmp next
x: mov BX,offset m_set&field ; load address of message text
IFIDN <&field>,<car>
bad_stcr: mov ES,DX
bad_st1: xor AX,AX
mov AL,ES:[SI]-1
add AX,offset reg0
push AX
xor AX,AX
mov AL,ES:[SI]-2
add AX,offset reg0
pushm <AX,m_two,BX>
C_call set_src_,<SI>,Load_ES
restore <SI>
jmp sch_err
ELSE
jmp bad_stcr
ENDIF
endm
;************************************************************************
;* AL AH *
;* Side effect car field (set-car! dest src) SET-CAR! dest,src *
;* *
;* Purpose: Interpreter support for the set-car! operation. *
;************************************************************************
public set_car
set_car: set_cc car
;************************************************************************
;* AL AH *
;* Side effect cdr field (set-cdr! dest src) SET-CDR! dest,src *
;* *
;* Purpose: Interpreter support for the set-cdr! operation. *
;************************************************************************
public set_cdr
set_cdr: set_cc cdr
purge set_cc
;************************************************************************
;* DL DH AL *
;* Cons - Create and define new list cell CONS dest,car,cdr *
;* *
;* Purpose: Interpreter support for the Scheme "cons" operation. *
;************************************************************************
public s_cons
s_cons: lods word ptr ES:[SI] ; load destination/car register numbers
mov DX,AX ; and save in DX
xor AX,AX
lods byte ptr ES:[SI] ; load cdr register number
save <SI> ; save the location pointer
; Attempt a "short circuit" list cell allocation
mov DI,listpage
;;; cmp DI,END_LIST
;;; je cons_no
shl DI,1
mov SI,nextcell+[DI]
cmp SI,END_LIST
je cons_no
LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; load list cell page's segment address
mov CX,ES:[SI].car
mov nextcell+[DI],CX
; Move contents of CDR register to CDR field of new list cell
cons_ok: mov BX,AX ; copy register number to BX
mov AL,byte ptr reg0_pag+[BX]
mov ES:[SI].cdr_page,AL
mov AX,reg0_dis+[BX]
mov ES:[SI].cdr,AX
; Move contents of CAR register to CAR field of new list cell
mov BL,DH ; copy CAR register number to BX
mov AL,byte ptr reg0_pag+[BX]
mov ES:[SI].car_page,AL
mov AX,reg0_dis+[BX]
mov ES:[SI].car,AX
; Update destination register number with pointer to new list cell
mov BL,DL
mov reg0_pag+[BX],DI
mov reg0_dis+[BX],SI
jmp next_SP
; "short circuit" list cell allocation failed-- go through channels
cons_no: push tmp_adr
C_call alloc_li,<AX,DX>,Load_ES
add SP,WORDINCR
restore <AX,DX>
mov DI,tmp_page
mov SI,tmp_disp
LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
jmp cons_ok
;************************************************************************
;* List - Create and define new list cell w/ nil cdr LIST dest *
;* *
;* Purpose: Interpreter support for the Scheme "list" operation. *
;************************************************************************
public s_list
s_list: lods byte ptr ES:[SI] ; load destination register number
mov BX,offset tmp_reg ; load address of temporary register
pushm <AX,BX> ; push dest reg number, temp_reg address
C_call alloc_li,<SI>,Load_ES ; allocate list cell
add SP,WORDINCR ; dump argument from TIPC's stack
pop SI ; restore destination register pointer
mov BX,tmp_page ; load page number of new list cell
mov CX,BX
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell's page table address
mov DI,tmp_disp ; load displacement of new list cell
; copy car field into newly allocated list cell
mov AX,reg0_dis+[SI] ; load car's displacement, and
mov ES:[DI].car,AX ; store into new list cell
mov AL,byte ptr reg0_pag+[SI] ; load page number, and
mov ES:[DI].car_page,AL ; store it, too
; create nil cdr field into newly allocated list cell
xor AX,AX
mov ES:[DI].cdr,AX
mov ES:[DI].cdr_page,AL
; copy pointer to new list cell into destination register
mov byte ptr reg0_pag+[SI],CL
mov reg0_dis+[SI],DI
jmp next_PC
;************************************************************************
;* AL AH *
;* (list a b) LIST2 dest,src *
;* *
;* Purpose: Interpreter support for the (list a b) operation. *
;* *
;* Description: This operation: (list a b) *
;* is equivalent to: (cons a (cons b nil)) *
;************************************************************************
public list2
list2: lods word ptr ES:[SI] ; fetch operands
mov BL,AL ; save the destination register number
push BX
mov BL,AH ; copy the source register number
add BX,offset reg0 ; compute source register address
mov AX,offset nil_reg ; load "nil_reg" address
mov CX,offset tmp_reg ; load "tmp_reg" address
pushm <AX,BX,CX> ; push arguments to cons
C_call cons,<SI>,Load_ES ; call: cons(tmp_reg,src,nil_reg)
pop CX ; restore tmp_reg address
add SP,WORDINCR*2 ; drop arguments from TIPC's stack
pop BX ; restore destination register number
add BX,offset reg0 ; compute destination register address
pushm <CX,BX,BX> ; push arguments to cons
C_call cons ; call: cons(dest, dest, tmp_reg)
jmp next_SP ; return to the interpreter
;************************************************************************
;* (append! list obj) append! dest src *
;* *
;* Purpose: Scheme interpreter support for the append! primitive *
;************************************************************************
public appendb
appendb: lods word ptr ES:[SI] ; get args (AL=arg1, AH=arg2)
save <SI> ; save the location pntr
mov BL,AL
lea DI,reg0+[BX] ; DI=address of dest reg
mov BX,[DI].C_page ; load list header from dest reg
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is arg1 a list?
jne short not_list ; if not, error (jump)
;
cmp BL,NIL_PAGE*2 ; is arg1 == nil?
jne short find_end ; if not, continue (jump)
;
mov BL,AH ; else get 2nd arg & return it in dest reg
lea SI,reg0+[BX] ; SI=address of src reg
mov BX,[SI].C_page ; Copy src reg to dest reg
mov [DI].C_page,BX
mov BX,[SI].C_disp
mov [DI].C_disp,BX
jmp next_PC ; RETURN
;
find_end label near
mov CX,SB_CHECK ; load shift-break iteration count
mov DI,[DI].C_disp
next_cell label near
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell page para address
mov BL,ES:[DI].cdr_page ; load list cell's cdr's page
cmp BL,NIL_PAGE*2 ; CDR == nil?
je short eolist ; then end-of-list (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; still pointing to cons nodes?
jne short weird_lst
mov DI,ES:[DI].cdr ; load list cell's cdr's displacement
loop next_cell
; Every one in awhile, check for shift-break
mov CX,SB_CHECK ; reload the shift-break iteration count
cmp s_break,0 ; has the shift-break key been depressed?
je next_cell ; if no shift-break, jump
push m_three ; push instruction length = 3
C_call restart ; link to Scheme debugger
; Note: control does not return from "restart"
;
weird_lst label near ; possible error checking here
; as list was non-nil terminated
eolist label near
mov BL,AH ; else get 2nd arg & return it in dest reg
lea SI,reg0+[BX] ; SI=address of src reg
mov BX,[SI].C_page ; Copy src reg to dest reg
; check page # for src?
mov ES:[DI].cdr_page,BL
mov BX,[SI].C_disp
mov ES:[DI].cdr,bx
jmp next_PC ; return to interpreter
not_list label near
mov BX,offset m_apendb
jmp bad_st1
;************************************************************************
;* (list_tail list count) l_tail list(dest) count *
;* *
;* Purpose: Scheme interpreter support for the list_tail primitive *
;************************************************************************
lt_args struc
COUNT dw ? ; Long integer count of list element
dw ?
REGSAVE dw ?
BP_SAVE dw ? ; Saved base pointer
ES_SAVE dw ? ; Saved ES reg
lt_args ends
public l_tail
l_tail:
lods word ptr ES:[SI] ; get register operands
save <SI> ; save instruction pointer
push ES ; save local registers
push BP
sub SP,offset BP_SAVE ; allocate local storage
mov BP,SP
xor BH,BH
mov BL,AL
add BX,offset reg0 ; reg holding list ptr
mov [BP].REGSAVE,BX ; save for later
xor BH,BH
mov BL,AH
add BX,offset reg0 ; get register containing count
push BX ; and push for call
lea BX,[BP+COUNT] ; get location for return value
push BX ; and push for call
mov DX,DS
mov ES,DX ; set ES for C routine
C_call int2long ; convert register to long
mov SP,BP
or ax,ax
jnz lt_err ; jump on error
mov ax,[BP].COUNT+2 ; get high word of long integer
or ax,ax ; if negative
js lt_rtn ; return
mov SI,[BP].REGSAVE ; reg holding list ptr
mov BX,[SI].C_page ; BX <= page of list
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is it a list ?
jne lt_err ; no, jump
mov AX,BX ; AX <= page of list
mov BX,[SI].C_disp ; BX <= disp of list
lt_loop:
mov CX,[BP].COUNT+2 ; get lsw of long int
or CX,[BP].COUNT
jz lt_rtn ; jump if long int = zero
cmp AX,NIL_PAGE ; end of list?
je lt_rtn ; yes, return
LoadPage ES,AX ; ES <= page address of list cell
mov AL,ES:[BX].cdr_page ; AX <= page # of cdr
mov BX,ES:[BX].cdr ; BX <= disp of cdr
sub word ptr [BP].COUNT,1 ; decrement count
sbb word ptr [BP].COUNT+2,0
jmp lt_loop ; and loop
lt_rtn:
mov byte ptr [SI].C_page,AL ; save page in reg
mov [SI].C_disp,BX ; save disp in reg
add SP,BP_SAVE
pop BP
pop ES
jmp next_SP
lt_err:
add SP,BP_SAVE
pop BP
pop ES ; restore ES register
restore <SI> ; and instruction pointer
xor AX,AX
mov AL,ES:[SI]-1
add AX,offset reg0 ; get last operand
push AX ; and push for call
xor AX,AX
mov AL,ES:[SI]-2
add AX,offset reg0 ; get first operand
push AX ; and push for call
mov BX,offset m_ltail ; load address of message text
pushm <m_two,BX> ; and push
C_call set_src_,<SI>,Load_ES
restore <SI>
jmp sch_err
car_cdr endp
prog ends
end


18
schars.h Normal file
View File

@ -0,0 +1,18 @@
/************************************************************************/
/* Scheme Special Character Declarations */
/* */
/* Copyright 1985 by Texas Instruments Incorporated. */
/* All Rights Reserved. */
/************************************************************************/
#define test_num 8 /* the number of "special" characters */
/* Text Representations for Special Characters */
static char *test_string[test_num] = {"NEWLINE", "SPACE", "RUBOUT",
"PAGE", "TAB", "BACKSPACE",
"RETURN", "ESCAPE"};
/* Values for Special Characters */
static char test_char[test_num] = {'\n', ' ', '\177',
'\f', '\t', '\b',
'\r', '\033'};


5
scheme.equ Normal file
View File

@ -0,0 +1,5 @@
include schemed.equ
include schemed.ref
include schemed.mac
include smmu.mac


4
scheme.h Normal file
View File

@ -0,0 +1,4 @@
/* =====> SCHEME.H */
#include "memtype.h"
#include "schmdefs.h"


607
schemed.asm Normal file
View File

@ -0,0 +1,607 @@
; =====> 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


539
schemed.equ Normal file
View File

@ -0,0 +1,539 @@
; =====> SCHEMED.EQU
page 60,132
; TIPC Scheme Runtime Data Structure Equates
; Copyright 1984,1985 by Texas Instruments Incorporated.
; All Rights Reserved.
;
; Last Update:
;
; tc 10 Feb 1987 - Modified Page 5 special symbols to reflect #T
; per the R^3 Report.
include memtype.equ
; The following equates set the limits on the virtual memory (paging)
; system:
NUMPAGES equ 128 ; Total number of pages
DEDPAGES equ 8 ; Number of dedicated pages
PreAlloc equ DEDPAGES+1 ; Pre-allocated pages
PAGEINCR equ 2
PAGEMASK equ 000FEH
PTRMASK equ MIN_PAGESIZE-1
WORDSIZE equ 16 ; The computer's word size (16 bits/word)
WORDINCR equ 2 ; The number of address units per word
HT_SIZE equ 211 ; The oblist's hash table size
OHT_SIZE equ 17 ; The object hash table's size
STKSIZE equ 900 ; Length of Scheme's internal stack (bytes)
NUM_REGS equ 64 ; Number of general regs in the Scheme VM
SB_CHECK equ 16 ; Iteration count for shift-break checks
; Page attribute bits
ATOM equ 08000H ; 1 = Atomic data
LISTCELL equ 04000H ; 1 = List (cons) cells
FIXNUMS equ 02000H ; 1 = 16-bit integer data
FLONUMS equ 01000H ; 1 = 32-bit floating point data
BIGNUMS equ 00800H ; 1 = big integer values
SYMBOLS equ 00400H ; 1 = symbols
STRINGS equ 00200H ; 1 = strings
VECTORS equ 00100H ; 1 = vector (array) storage
NOMEMORY equ 00080H ; 1 = no memory allocated
READONLY equ 00040H ; 1 = memory is read only (constant)
CONTINU equ 00020H ; 1 = continuation object
CLOSURE equ 00010H ; 1 = closure object
REFS equ 00008H ; 1 = ref cells
PORTS equ 00004H ; 1 = I/O ports
CODE equ 00002H ; 1 = code block
CHARS equ 00001H ; 1 = characters
NUMBERS equ FIXNUMS+FLONUMS+BIGNUMS ; number (fixnums, flonums, bignums)
; Data type equates (classes of data objects)
NUMTYPES equ 15 ; Number of data types
LISTTYPE equ 0
FIXTYPE equ 1
FLOTYPE equ 2
BIGTYPE equ 3
SYMTYPE equ 4
STRTYPE equ 5
VECTTYPE equ 6
CONTTYPE equ 7
CLOSTYPE equ 8
FREETYPE equ 9
CODETYPE equ 10
REFTYPE equ 11
PORTTYPE equ 12
CHARTYPE equ 13
ENVTYPE equ 14
; Data type lengths for fixed length objects
BLK_OVHD equ 3 ; size of a block header
PTRSIZE equ 3 ; size of a Scheme pointer (3 bytes)
FLOSIZE equ 9
; Special pre-allocated pages
SPECCHAR equ 1
SPECFIX equ 3
SPECFLO equ 4
SPECSYM equ 5
SPECPOR equ 6
SPECCODE equ 7
; Predefined constants
T_PAGE equ SPECSYM ; symbol 't' (representing true)
T_DISP equ 0000H
UN_PAGE equ SPECSYM ; symbol '#!unassigned' (unbound variable)
UN_DISP equ 0009H
NTN_PAGE equ SPECSYM ; symbol '#!not-a-number'
NTN_DISP equ 001CH
DIV0_PAGE equ SPECSYM ; symbol for divide by 0
DIV0_DISP equ 001CH
EOF_PAGE equ SPECSYM ; symbol for '#!EOF
EOF_DISP equ 00031H
NPR_PAGE equ SPECSYM ; symbol for '#!unprintable'
NPR_DISP equ 003DH
NIL_PAGE equ 0 ; symbol 'nil' (representing itself)
NIL_DISP equ 0
IN_PAGE equ SPECPOR ; standard input port
IN_DISP equ 0
OUT_PAGE equ SPECPOR ; standard output port
OUT_DISP equ 0
WHO_PAGE equ SPECPOR ; "who-line"
WHO_DISP equ 0123H
; End of linked list indicator
END_LIST equ 07FFFH
; Garbage Collector "marked" bit
GC_BIT equ 080H
NOT_GC_BI equ 07FH
; Special Characters
CR equ 0DH ; ASCII Carriage Return
LF equ 0AH ; ASCII Line Feed
; Numeric operator sub-opcodes
ADD_OP equ 0 ; add
SUB_OP equ 1 ; subtract
MUL_OP equ 2 ; multiply
DIV_OP equ 3 ; divide
MOD_OP equ 4 ; modulo
AND_OP equ 5 ; bitwise-and
OR_OP equ 6 ; bitwise-or
MINUS_OP equ 7 ; minus
EQ_OP equ 8 ; = (equal comparison)
NE_OP equ 9 ; <> (not equal comparison)
LT_OP equ 10 ; < (less than comparison)
GT_OP equ 11 ; > (greater than comparison)
LE_OP equ 12 ; <= (less than or equal comparison)
GE_OP equ 13 ; >= (greater than or equal comparison)
ABS_OP equ 14 ; absolute value
QUOT_OP equ 15 ; quotient (integer division)
ZERO_OP equ 21 ; zero?
POS_OP equ 22 ; positive?
NEG_OP equ 23 ; negative?
XOR_OP equ 24 ; bitwise-xor
; Numeric Error Codes
REF_GLOBAL_ERROR equ 1 ; reference of unbound global variable
SET_GLOBAL_ERROR equ 2 ; SET! error-- global not defined
REF_LEXICAL_ERROR equ 3 ; reference of unbound lexical variable
SET_LEXICAL_ERROR equ 4 ; SET! error-- lexical variable not defined
REF_FLUID_ERROR equ 5 ; reference of unbound fluid variable
SET_FLUID_ERROR equ 6 ; SET-FLUID! error-- fluid not bound
VECTOR_OFFSET_ERROR equ 7 ; vector index out of range
STRING_OFFSET_ERROR equ 8 ; string index out of range
SUBSTRING_RANGE_ERROR equ 9 ; invalid substring range
INVALID_OPERAND_ERROR equ 10 ; Invalid operand to VM instruction
SHIFT_BREAK_CONDITION equ 11 ; SHFT-BRK key was depressed by user
NON_PROCEDURE_ERROR equ 12 ; Attempted to call non-procedural object
TIMEOUT_CONDITION equ 13 ; Timer interrupt
WINDOW_FAULT_CONDITION equ 14 ; Attempt to do I/O to a de-exposed window
FLONUM_OVERFLOW_ERROR equ 15 ; Flonum Over/Under-flow
ZERO_DIVIDE_ERROR equ 16 ; Division by zero
NUMERIC_OPERAND_ERROR equ 17 ; non-numeric operand
APPLY_ARG_LIMIT_ERROR equ 18 ; too many arguments for APPLY to handle
VECTOR_SIZE_LIMIT_ERROR equ 19 ; attempt to allocate vector which is too big
STRING_SIZE_LIMIT_ERROR equ 20 ; attempt to allocate string which is too big
IO_ERRORS_START equ 21 ; Errors between 21 and 84 are DOS I/O errors
DOS_FATAL_ERROR equ 21 ; Generic fatal I/O error
EXTEND_START_ERROR_CODE equ 1 ; Extended error codes from INT 59h
EXTEND_END_ERROR_CODE equ 88
DISK_FULL_ERROR equ 200 ; Our own home-grown error codes
LAST_ERROR equ 200 ; Future errors should start here
; List Cell
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-------------+-+-+-----+-----------------------+
; | car page no.|0|g|0 0 0| car displacement |
; +-------------+-+-+-----+-----------------------+
; | cdr page no.|0|0 0 0 0| cdr displacement |
; +-------------+-+-------+-----------------------+
; where g = used during garbage collection
listdef struc
car_page db ? ; CAR's page number
car dw ? ; CAR's displacement
cdr_page db ? ; CDR's page number
cdr dw ? ; CDR's displacement
listdef ends
list_gc equ car+1 ; High order bit used by GC
LISTSIZE equ size listdef
; Bignum
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| type | length in bytes |
; +-+-------------+-------------------------------+
; | sign | least significant word |
; +---------------+--------------------------------
; : :
; ----------------+-------------------------------+
; | most significant word |
; ----------------+-------------------------------+
; where g = used during garbage collection
bigdef struc
big_type db BIGTYPE ; tag = bignum
big_len dw ? ; length of entire data structure in bytes
big_sign db ? ; sign of the bignum
big_data dw ? ; data bits, stored with least significant
; bits appearing first
big_2nd dw ? ; second word of significant bits
bigdef ends
big_gc equ big_type
; Flonum
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+---------------+---------------+
; |g| type | 64 bit IEEE floating |
; +-+-------------+---------------+---------------+
; | |
; +---------------+---------------+---------------+
; | |
; +---------------+---------------+---------------+
; where g = used during garbage collection
flodef struc
flo_type db FLOTYPE ; tag = flonum
flo_data db 8 dup (?) ; IEEE floating point number
flodef ends
flo_gc equ flo_type
; Vector (Array)
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-+-----------+-------------------------------+
; |g|b| type | length in bytes |
; +-+-+-----------+-------------------------------+
; | first data element, second, ...
; +------------------------------------------------
; : :
; ------------------------------------------------+
; ..., last data element |
; ------------------------------------------------+
; where g = used during garbage collection
; b = unboxed array (contains no type info)
vecdef struc
vec_type db VECTTYPE
vec_len dw ?
vec_page db ?
vec_disp dw ?
vecdef ends
vec_gc equ vec_type
vec_data equ vec_page
; Symbol
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| SYMTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | link page no. | link displacement |
; +-+-------------+-------------------------------+
; | hash value | characters ...
; +---------------+-------------------------------
; : :
; ------------------------------------------------+
; where g = used during garbage collection
symdef struc
sym_type db SYMTYPE ; tag = symbol
sym_len dw ? ; length of symbol structure in bytes
sym_page db ? ; link field page number
sym_disp dw ? ; link field displacement
sym_hkey db ? ; hash key
sym_data db ? ; character(s) in symbol
symdef ends
sym_gc equ sym_type
sym_ovhd equ sym_data-sym_type ; # bytes of overhead in symbol object
; String
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| STRTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | characters ...
; +---------------+---------------+----------------
; : :
; ----------------+---------------+---------------+
; where g = used during garbage collection
strdef struc
str_type db strTYPE ; tag = string
str_len dw ? ; length of string structure in bytes
str_data db ? ; character(s) in string
strdef ends
str_gc equ str_type
str_ovhd equ str_data-str_type ; # bytes of overhead in string object
; Closure
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| CLOSTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | Information Operand Pointer |
; +---------------+-------------------------------+
; | heap page no. | heap environment displacement |
; +---------------+-------------------------------+
; | CB page no. | CB displacement |
; +---------------+-------------------------------+
; | SPECFIX*2 | Entry Point Displacement |
; +---------------+-------------------------------+
; | SPECFIX*2 | Number of Arguments |
; +---------------+-------------------------------+
; where g = used during garbage collection
closdef struc
clo_type db CLOSTYPE ; tag = closure
clo_len dw ? ; length of closure object in bytes
clo_ipag db ? ; information operand page number
clo_idis dw ? ; information operand displacement
clo_hpag db ? ; heap environment pointer page number
clo_hdis dw ? ; heap environment pointer displacement
clo_cb_p db ? ; code base page number
clo_cb_d dw ? ; code base displacement pointer
clo_etag db SPECFIX*2 ; entry point tag = immediate
clo_edis dw ? ; entry point displacement
clo_atag db SPECFIX*2 ; number of arguments tag = immediate
clo_narg dw ? ; number of arguments
clo_dbug db ? ; optional debugging information?
closdef ends
clo_gc equ clo_type ; garbage collection mark bit field
CLO_OVHD equ clo_dbug-clo_type ; number of bytes of overhead in a closure
; Continuation
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| CONTTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | tag=fixnum | stack base of continuation |
; +---------------+-------------------------------+
; | return address code base pointer |\
; +---------------+-------------------------------+ | return address
; | tag=fixnum | return address displacement |/
; +---------------+-------------------------------+
; | tag=fixnum | caller's dynamic link (FP) |
; +---------------+-------------------------------+
; | fluid environment pointer (FNV_reg) |
; +---------------+-------------------------------+
; | previous stack segment (continuation) pointer |
; +---------------+-------------------------------+
; | global environment pointer (GNV_reg) |
; +---------------+-------------------------------+
; : :< - BASE
; : [contents of stack at call/cc] :
; : :< - TOS
; +-----------------------------------------------+
; where g = used during garbage collection
contdef struc
con_type db CONTTYPE ; tag = continuation
con_len dw ? ; length of continuation structure in bytes
con_btag db SPECFIX*2 ; stack base of continuation object
con_base dw ?
con_cb_p db ? ; return address code base pointer
con_cb_d dw ?
con_rtag db SPECFIX*2 ; return address displacement
con_ret dw ?
con_dtag db SPECFIX*2 ; caller's dynamic link
con_ddis dw ?
con_fl_p db ? ; fluid environment pointer
con_fl_d dw ?
con_spag db ? ; previous stack segment pointer
con_sdis dw ?
con_gl_p db ? ; global environment pointer
con_gl_d dw ?
con_data db ? ; contents of stack at call/cc
contdef ends
con_gc equ con_type
; Code Block
;
; +-----------------------------------------------------+
; | 2 2 2 2 1 1 1 1 1 1 1 1 1 1 |
; | 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 |
; | +-+-------------+-------------------------------+ |
; | |g| CODETYPE | length in bytes | |
; | +-+-------------+-------------------------------+ |
; | | FIXTYPE*2 | entry offset |--+
; | +---------------+-------------------------------+
; | | page | displacement |\
; | +---------------+-------------------------------+ |
; | : : : > constants
; | +---------------+-------------------------------+ | area
; | | page | displacement |/
; | +---------------+---------------+---------------+
; +->| code | code | code |\
; +---------------+---------------+---------------+ |
; : : : : > code
; +---------------+---------------+---------------+ |
; | code | code | code |/
; +---------------+---------------+---------------+
; where g = used during garbage collection
codedef struc
cod_type db CODETYPE ; tag = code block
cod_len dw ? ; length of code block in bytes
cod_etag db FIXTYPE*2 ; entry offset tag = fixnum
cod_entr dw ? ; entry offset in bytes
cod_cpag db ? ; code block constants area
cod_cdis dw ?
codedef ends
cod_gc equ cod_type ; garbage collection tag field
; Environment Data Object
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| type | length in bytes |
; +-+-------------+-------------------------------+
; | parent pointer |
; +---------------+-------------------------------+
; | list of symbols (linked through cdr field) |
; +---------------+-------------------------------+
; | list of values (linked through car field) |
; +---------------+-------------------------------+
; where g = used during garbage collection
envdef struc
env_tag db ENVTYPE ; tag = environment
env_len dw ? ; length in bytes
env_ppag db ? ; parent pointer page number
env_pdis dw ? ; parent pointer displacement
env_npag db ? ; list of names page number
env_ndis dw ? ; list of names displacement
env_vpag db ? ; list of values page number
env_vdis dw ? ; list of values displacement
envdef ends
ENV_SIZE equ size envdef
; Port
; +--------+--------+--------+
; 0 |tag=port| length in bytes |
; +--------+--------+--------+
; 3 | string source pointer |
; +--------+--------+--------+--------+
; 6 | port flags | handle |
; +-----------------+-----------------+
; 10 | cursor line | cursor column |
; +-----------------+-----------------+
; 14 | upper left line |upper left column|
; +-----------------+-----------------+
; 18 | number of lines |number of columns|
; +-----------------+-----------------+
; 22 |border attributes| text attributes |
; +-----------------+-----------------+
; 26 | window flags | buffer position |
; +-----------------+-----------------+
; 30 | buffer end |
; +--------+--------+--------+--------+----... -----+
; 32 | input/output buffer |
; +--------+--------+-----------------+-------...---+
; | window label/file pathname |
; +--------+--------+-----------------+---------...-+
; where g = used during garbage collection
;
; 7 6 5 4 3 2 1 0
; +-+-+-+-+-+-+---+
;port flags: | |s|b|t|o|w|mod|
; +-+-+-+-+-+-+---+
;
; mod - mode: 0=read
; 1=write
; 2=read and write
; w - window/file: 0=file
; 1=window
; o - open/closed: 0=closed
; 1=open
; t - transcript: 0=disabled
; 1=enabled
; b - binary: 0=test file/window
; 1=binary file/window
; s - string I/O: 0=file/window I/O
; 1=string I/O
;
; 7 6 5 4 3 2 1 0
; +-----+-+-+-+-+-+
;window flags: | |e|w|
; +-----+-+-+-+-+-+
;
; w - wrap/clip: 0=clip
; 1=wrap
; e - exposed: 0=exposed
; 1=(partially) covered
;
portdef struc
pt_type db PORTTYPE ; tag = port
pt_len dw ? ; length of port structure in bytes
pt_ptr db ?,?,? ; pointer to string, if any
pt_pflgs dw ? ; port flags
pt_handl dw ? ; file's handle
pt_cline dw ? ; cursor line number
pt_ccol dw ? ; cursor column number
pt_ullin dw ? ; upper left hand corner's line number
pt_ulcol dw ? ; upper left hand corner's column number
pt_nline dw ? ; number of lines
pt_ncols dw ? ; number of columns/line length
pt_bordr dw ? ; window's border attributes
pt_text dw ? ; window's text attributes
pt_wflgs dw ? ; window flags
pt_bfpos dw ? ; buffer position (offset)
pt_bfend dw ? ; end of buffer offset
pt_buffr dw ? ; input/output buffer
portdef ends
port_gc equ pt_type
pt_chunk equ pt_ullin
W_CLIP equ 00h
W_WRAP equ 01h
READ_ONLY equ 00h
WRITE_ONLY equ 01h
READWRITE equ 02h
WINDOW equ 04h
OPEN equ 08h
TRANSCRI equ 10h
BINARY equ 20h
STRIO equ 40h
DIRTY equ 80h
; The following is the format of a scheme pointer as far as
; Lattice C is concerned:
C_ptr struc
C_disp dw ?
C_page dw ?
C_ptr ends


99
schemed.mac Normal file
View File

@ -0,0 +1,99 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Assembler Macros *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 19 April 1984 *
;* Last Modification: 06 January 1986 *
;***************************************
; Adjust page number prior to store into pointer
adjpage MACRO reg
sal reg,1
ENDM
; Convert page number from physical representation to logical page
corrpage MACRO reg
shr reg,1
ENDM
; Test if an object in Scheme's memory has been "marked" by
; the Garbage Collector as referenced. If the GC "marked" bit
; is set in the "field" specified, a branch is taken to "label."
markedp MACRO field,label
cmp byte ptr field,0
jl label
ENDM
; Push the page number and displacement components of a Scheme
; pointer onto the runtime stack (parameter passing mechanism)
pushptr MACRO addr
push addr.car ; push the displacement
mov AL,addr.car_page ; load the page number,
and AX,PAGEMASK ; isolate it, and
push AX ; push it on the stack
ENDM
; Pop the page number and displacement components of a Scheme
; pointer from the runtime stack and restore a memory location
; (parameter return mechanism)
popptr MACRO addr
pop AX ; Retrieve the page number and
mov addr.car_page,AL ; update pointer in Scheme's memory
pop addr.car ; Restore displacement in memory
ENDM
; Save the registers in the macro's argument (a list) in the local
; stack in the variables "save_xx", where "xx" is the register name.
save MACRO regs
irp rr,<regs>
mov [BP].save_&&rr,rr
endm
endm
; Restore the registers in the macro's argument (a list) from the local
; stack in the variables "save_xx", where "xx" is the register name.
restore MACRO regs
irp rr,<regs>
mov rr,[BP].save_&&rr
endm
endm
; Push multiple
pushm MACRO objs
irp oo,<objs>
push oo
endm
endm
; Pop multiple
popm MACRO objs
irp oo,<objs>
pop oo
endm
endm
; Call Lattice C routine: C_call rtn,<regs>
; A call is made to "rtn". If "rtn" has not been declared, an "extrn"
; declaration is generated. "<regs>", if specified is the list of
; registers which are to be saved prior to the call (see the "save"
; macro above).
C_call macro rtn,regs,esp
IFNB <regs>
irp rr,<regs>
mov [BP].save_&&rr,rr
endm
ENDIF
IFNB <esp>
mov AX,DS ; make ES point to the current
mov ES,AX ; data segment
ENDIF
IFNDEF rtn
extrn rtn:near
ENDIF
call rtn
endm


309
schmdefs.h Normal file
View File

@ -0,0 +1,309 @@
/* =====> SCHMDEFS.H */
/* TIPC Scheme Data Declarations for Lattice C */
/* Last Modification: */
/* tc 2/10/87 modified Page 5 special symbols to reflect */
/* changes for the R^3 Report. */
/* */
extern char *rtn_name;
#define ASSERT(arg) if(!(arg))asrt$(rtn_name,"arg")
#define ENTER(xyz) static char *rtn_name = "xyz"
/* Data conversion macros */
/* Adjust page number- this macro converts a logical page number to
the representation which is stored in the interpreter's registers
and pointers. "CORRPAGE" performs the reverse transformation */
#define ADJPAGE(x) ((x)<<1)
/* Correct page number- this macro converts the interpreter's encoding
of a page number into the logical page number. "ADJPAGE" performs
the reverse transformation. */
#define CORRPAGE(x) ((x)>>1)
/* Fetch value for Fixnum (immediate) from pointer */
#define get_fix(pg,ds) (((ds)<<1)>>1)
/* Fetch value for Character (immediate) from pointer */
#define get_char(pg,ds) ((ds) & 0x00ff)
/* define truth */
#define TRUE 1
#define FALSE 0
#define NULL 0 /* null pointer */
/* Position of page/displacement values in "registers" */
#define C_DISP 0
#define C_PAGE 1
/* Page Management Table Definitions */
#define NUMPAGES 128 /* maximum number of pages */
#define DEDPAGES 8 /* Number of dedicated pages */
/* MIN_PAGESIZE is defined in either regmem.h, expmem.h, or extmem.h */
#define PTRMASK MIN_PAGESIZE-1 /* mask to isolate a pointer displacement */
#define PAGEINCR 2 /* increment to get to next page */
#define PAGEMASK 0x00FE /* mask to isolate a page number */
#define WORDSIZE 16 /* computer's word size (bits/word) */
#define WORDINCR 2 /* number of address units/word */
#define HT_SIZE 211 /* the oblist's hash table size */
#define STKSIZE 900 /* the stack's length (bytes) */
#define BLK_OVHD 3 /* number of overhead bytes in a block header */
#define NUM_REGS 64 /* number of registers in the Scheme VM */
/* Data Type Equates */
#define NUMTYPES 15 /* the number of data types */
#define LISTTYPE 0
#define FIXTYPE 1
#define FLOTYPE 2
#define BIGTYPE 3
#define SYMTYPE 4
#define STRTYPE 5
#define ARYTYPE 6
#define VECTTYPE ARYTYPE
#define CONTTYPE 7
#define CLOSTYPE 8
#define FREETYPE 9
#define CODETYPE 10
#define REFTYPE 11
#define PORTTYPE 12
#define CHARTYPE 13
#define ENVTYPE 14
#define EOFERR 1 /* Codes for function ERRMSG */
#define DOTERR 2
#define QUOTERR 3
#define RPARERR 4
#define OVERERR 5
#define DIV0ERR 6
#define SHARPERR 7
#define FULLERR -1
#define PORTERR -2
#define HEAPERR -3
#define BUFSIZE 80
#define SYM_OVHD 7
#define PTRSIZE 3
#define LISTSIZE 6
#define FIXSIZE 2
#define FLOSIZE 9
#define SMALL_SIZE 1024 /* a "small" length for a block */
#define SPECCHAR 1 /* special page of characters */
#define SPECFIX 3 /* special page of fixnums */
#define SFIXLEN 0 /* length (bytes) of special fixnum page */
#define SPECFLO 4 /* special page of flonums */
#define SFLOLEN 24 /* length (bytes) of special flonum page */
#define SPECSYM 5 /* special page of symbols */
#define SSYMLEN 0x51 /* length (bytes) of special symbol page */
#define SPECSTK 6
#define SPECPOR 6 /* special page of ports */
#define SPORLEN 92 /* length (bytes) of special port page */
#define SPECCODE 7 /* code page for the bootstrap loader */
#define END_LIST 0x7FFF /* end of linked list marker */
#define NIL_PAGE 0 /* Location of "nil" */
#define NIL_DISP 0
#define T_PAGE SPECSYM /* Location of "t" (for true) */
#define T_DISP 0x0000
#define UN_PAGE SPECSYM /* Location of "#!unassigned" */
#define UN_DISP 0x0009
#define NTN_PAGE SPECSYM /* Location of "#!not-a-number" */
#define NTN_DISP 0x001C
#define OVR_PAGE SPECSYM /* Location of overflow designator */
#define OVR_DISP 0x001C /* (same as "not a number" for now) */
#define DIV0_PAGE SPECSYM /* Location of divide-by-zero designator */
#define DIV0_DISP 0x001C /* (same as "not a number" for now) */
#define IN_PAGE SPECPOR /* Location of standard input port */
#define IN_DISP 0
#define OUT_PAGE SPECPOR /* Location of standard output port */
/* #define OUT_DISP 0x011f */
#define OUT_DISP 0 /* input=output for standard console device */
#define WHO_PAGE SPECPOR /* Location of "who-line" port */
#define WHO_DISP 0x0123
#define EOF_PAGE SPECSYM /* Location of non-interned "**eof**" symbol */
#define EOF_DISP 0x0031
#define NPR_PAGE SPECSYM /* Location of "#!unprintable" */
#define NPR_DISP 0x003D
#define ADD_OP 0 /* addition */
#define SUB_OP 1 /* subtraction */
#define MUL_OP 2 /* multiplication */
#define DIV_OP 3 /* divide */
#define MOD_OP 4 /* modulo */
#define AND_OP 5 /* bitwise and */
#define OR_OP 6 /* bitwise or */
#define MINUS_OP 7 /* minus */
#define EQ_OP 8 /* equal comparison */
#define NE_OP 9 /* not equal comparison */
#define LT_OP 10 /* less than comparison */
#define GT_OP 11 /* greater than comparison */
#define LE_OP 12 /* less than or equal comparison */
#define GE_OP 13 /* greater than or equal comparison */
#define ABS_OP 14 /* absolute value */
#define QUOT_OP 15 /* quotient */
#define TRUNC_OP 16 /* truncate */
#define FLOOR_OP 17 /* floor */
#define CEIL_OP 18 /* ceiling */
#define ROUND_OP 19 /* round */
#define FLOAT_OP 20 /* float */
#define ZERO_OP 21 /* zero? */
#define POS_OP 22 /* positive? */
#define NEG_OP 23 /* negative? */
#define XOR_OP 24 /* bitwise xor */
/* Numeric Error Codes */
#define REF_GLOBAL_ERROR 1 /* reference of unbound global variable */
#define SET_GLOBAL_ERROR 2 /* SET! error-- global not defined */
#define REF_LEXICAL_ERROR 3 /* reference of unbound lexical variable */
#define SET_LEXICAL_ERROR 4 /* SET! error-- lexical variable not defined */
#define REF_FLUID_ERROR 5 /* reference of unbound fluid variable */
#define SET_FLUID_ERROR 6 /* SET-FLUID! error-- fluid not bound */
#define VECTOR_OFFSET_ERROR 7 /* vector index out of range */
#define STRING_OFFSET_ERROR 8 /* string index out of range */
#define SUBSTRING_RANGE_ERROR 9 /* invalid substring range */
#define INVALID_OPERAND_ERROR 10 /* invalid operand to VM instruction */
#define SHIFT_BREAK_CONDITION 11 /* SHFT-BRK key was depressed by user */
#define NON_PROCEDURE_ERROR 12 /* attempted to call non-procedural object */
#define TIMEOUT_CONDITION 13 /* timer interrupt */
#define WINDOW_FAULT_CONDITION 14 /* attempt to do I/O to a de-exposed window */
#define FLONUM_OVERFLOW_ERROR 15 /* flonum overflow/underflow */
#define ZERO_DIVIDE_ERROR 16 /* division by zero */
#define NUMERIC_OPERAND_ERROR 17 /* non-numeric operand */
#define APPLY_ARG_LIMIT_ERROR 18 /* too many arguments for APPLY to handle */
#define VECTOR_SIZE_LIMIT_ERROR 19 /* vector too big */
#define STRING_SIZE_LIMIT_ERROR 20 /* string too big */
#define IO_ERRORS_START 21 /* Errors from 21 and 84 are DOS I/O errors */
#define DOS_FATAL_ERROR 21 /* Generic fatal I/O error */
#define EXTEND_START_ERROR_CODE 1 /* Extended error codes from INT 59h */
#define EXTEND_END_ERROR_CODE 88
#define DISK_FULL_ERROR 200 /* Our own home-grown error codes */
#define LAST_ERROR 200 /* Future errors should start here */
/* Scheme VM Control Flags */
extern int PC_MAKE; /* variable denoting PC's manufacturer & type */
extern int VM_debug; /* VM debug mode flag */
extern int s_break; /* shift-break indicator */
extern int QUOTE_PAGE; /* Location of "quote" */
extern int QUOTE_DISP;
extern unsigned PAGESIZE;
extern unsigned pagetabl[NUMPAGES]; /* Paragraph Address (bases) */
extern struct {
unsigned atom:1;
unsigned listcell:1;
unsigned fixnums:1;
unsigned flonums:1;
unsigned bignums:1;
unsigned symbols:1;
unsigned strings:1;
unsigned arrays:1;
unsigned nomemory:1;
unsigned readonly:1;
unsigned continu:1;
unsigned closure:1;
unsigned refs:1;
unsigned ports:1;
unsigned code:1;
unsigned characters:1;
} attrib[NUMPAGES]; /* Page Attribute Bits */
extern int w_attrib[NUMPAGES]; /* Re-define attribute bits as integer */
extern int nextcell[NUMPAGES]; /* Next Available Cell Pointers */
extern int pagelink[NUMPAGES]; /* Next Page of Same Type */
extern int ptype[NUMPAGES]; /* Page Type Index */
extern unsigned psize[NUMPAGES]; /* Page Size Table */
extern int pageattr[NUMTYPES]; /* Page attribute initialization table */
extern int pagelist[NUMTYPES]; /* Page allocation table (by types) */
extern int listpage; /* Page for List Cell allocation */
extern int fixpage; /* Page for Fixnum allocation */
extern int flopage; /* Page for Flonum allocation */
extern int bigpage; /* Page for Bignum allocation */
extern int sympage; /* Page for Symbol allocation */
extern int strpage; /* Page for String allocation */
extern int arypage; /* Page for Array allocation */
extern int contpage; /* Page for Continuation allocation */
extern int clospage; /* Page for Closure allocation */
extern int freepage; /* Free page allocation list header */
extern int codepage; /* Page for Code Block allocation */
extern int refpage; /* Ref cell page allocation list header */
extern int nextpage; /* Next Page # for Allocation in Address Space */
extern int lastpage; /* Last Page # for Allocation in Address Space */
extern unsigned nextpara; /* Next Paragraph Address for Allocation */
/* Scheme's Virtual Registers */
extern long reg0, regs[NUM_REGS];
extern int nil_reg[2];
extern int reg0_page, reg0_disp, tmp_reg[2], tmp_page, tmp_disp;
extern int tm2_reg[2], tm2_page, tm2_disp;
extern int FNV_reg[2], GNV_reg[2], CB_reg[2], PREV_reg[2];
extern int FNV_pag, FNV_dis, GNV_pag, GNV_dis, CB_pag, CB_dis;
extern int PREV_pag, PREV_dis, FP, BASE;
extern int CONSOLE_[2], CON_PAGE, CON_DISP;
extern int TRNS_reg[2], TRNS_pag, TRNS_dis; /* transcript file pointer */
extern int condcode, S_pc;
/* Stack */
extern int TOS; /* top of stack pointer (displacement in bytes */
extern char S_stack[STKSIZE]; /* the stack itself */
/* Hash Table */
extern char hash_page[HT_SIZE];
extern int hash_disp[HT_SIZE];
/* Property List Hash Table */
extern char prop_page[HT_SIZE];
extern int prop_disp[HT_SIZE];
/* State Variables for (reset) and (scheme-reset) */
extern int FP_save, RST_ent;
extern int FNV_save[2];
extern int STL_save[2];
/* Port fields */
#define pt_direc 6
#define pt_lnlen 20
#define pt_csrcol 12
#define dtaoffs 32
/* Error message text strings */
extern char m_error[], m_src[], m_dest[], m_first[], m_second[], m_third[];
/* Macros Normally Found in STDIO.H */
#define abs(x) ((x)<0?-(x):(x))
#define max(a,b) ((a)>(b)?(a):(b))
#define min(a,b) ((a)<=(b)?(a):(b))
/* Scheme Function Macros */
#define alloc_sym(dest,len) alloc_block(dest,SYMTYPE,len+PTRSIZE+1)
#ifdef PROMEM
#define outchar(ch) printcha(ch)
#define outtext(str,len) printtxt(str,len)
#else
#define outchar(ch) givechar(ch)
#define outtext(str,len) printstr(str,len)
#endif
/* International Case Conversion Macros */
extern char locases[256];
extern char hicases[256];
#undef tolower
#define tolower(c) locases[(c)]
#undef toupper
#define toupper(c) hicases[(c)]
#undef islower
#define islower(c) ((c)!=hicases[(c)])
#undef isupper
#define isupper(c) ((c)!=locases[(c)])
#undef isspace
#undef isdigit
#define isdigit(c) isdig((c),10)
#undef isxdigit
#define isxdigit(c) isdig((c),16)


4
screen.equ Normal file
View File

@ -0,0 +1,4 @@
DEFAULT_NUM_ROWS equ 25
DEFAULT_VGA_ROWS equ 30
DEFAULT_NUM_COLS equ 80


114
scroll.asm Normal file
View File

@ -0,0 +1,114 @@
; =====> SCROLL.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* Window Support Routine *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: October 1985 *
;* Last Modification: *
;***************************************
include pcmake.equ
TI_CRT equ 049h
IBM_CRT equ 010h
DGROUP group DATA
DATA segment word public 'DATA'
assume DS:DGROUP
extrn PC_MAKE:word
DATA ends
XGROUP group PROGX
PROGX segment byte public 'PROGX'
assume CS:XGROUP,DS:DGROUP
extrn crt_dsr:far
;************************************************************************
;* Scroll Window Down one line *
;************************************************************************
s_args struc
dw ? ; caller's BP
dd ? ; return address
dw ?
s_line dw ? ; upper left hand corner line number
s_col dw ? ; upper left hand corner column number
s_nline dw ? ; number of lines
s_ncols dw ? ; number of columns
s_attr dw ? ; text attributes (used for blanking)
s_args ends
scroll%d proc far
push BP ; save caller's BP
mov BP,SP
; scroll window's text down one line
mov CL,byte ptr [BP].s_nline ; load number of lines
dec CL ; decrease number of lines by one
jz blank ; Jump if scrolling 1-line and just blank it
mov CH,byte ptr [BP].s_ncols ; load number of columns
mov DL,byte ptr [BP].s_line ; load upper left line number
mov DH,byte ptr [BP].s_col ; load upper left column number
mov AX,0701h ; load "scroll text" code with no blanking
cmp DGROUP:PC_MAKE,TIPC
je ti_down
push AX ; else
mov AH,0Fh
int IBM_CRT ; Are we in graphics mode?
cmp AL,4 ; If we are then fix blank fill attributes
jl text_m ; so that the bar characters don't show up
cmp AL,7
je text_m
xor BH,BH ; zero attribute for fill blanks
jmp short wrte_atr
text_m: mov BH,byte ptr [BP].s_attr ; Blanked lines' attribute txt mode
wrte_atr: pop AX
xchg CX,DX ; CX=Upper left corner
xchg CH,CL ; Row,column instead of TI's column,row
xchg DH,DL ; ditto
add DX,CX ; DX=Lower right corner
dec DL ; adjust column count (0 is first column)
int IBM_CRT
jmp short quit ; IFF IBM is in graphics mode weird char's
; are used for blanks when scrolling. Do
; as TIPC does and "manual" blank 'em.
;
ti_down: mov BX,DX ; copy destination coordinates
inc BL ; compute dest by incrementing line number
int TI_CRT ; perform the block move
; paint the first line of the window with blank of proper attributes
blank: mov DH,byte ptr [BP].s_col ; load starting column number
mov DL,byte ptr [BP].s_line ; load upper line number
mov AH,02h ; load the "put cursor" code
xor BH,BH ; IBMism
call crt_dsr ; position cursor for write
mov AX,0920h ; load "write char/attr" code, write a blank
mov BL,byte ptr [BP].s_attr ; load attribute bit setting
xor BH,BH ; IBMism
mov CX,[BP].s_ncols ; load line length
call crt_dsr ; write a line of blanks
; return to caller
quit: pop BP ; restore caller's BP
ret
scroll%d endp
PROGX ends
;****************************************************************************
;* Link routine *
;****************************************************************************
PGROUP GROUP PROG
PROG SEGMENT BYTE PUBLIC 'PROG'
assume CS:PGROUP
public scroll_d
scroll_d proc near
call scroll%d ; link to window scroll down routine
ret
scroll_d endp
PROG ends
end


1052
senv.asm Normal file
View File

File diff suppressed because it is too large Load Diff

91
sexec.asm Normal file
View File

@ -0,0 +1,91 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Operation Support *
;* *
;* (C) Copyright 1984,1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 19 April 1984 *
;* Last Modification: 26 February 1986*
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
new_disp dw 0
new_page dw 0
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
; CONS Support -- combine two pointers in a new list cell
con_arg struc
dw ? ; return address
con_res dw ? ; address of result register
con_car dw ? ; address of reg. containing car
con_cdr dw ? ; address of reg. containing cdr
con_arg ends
extrn alloc_li:near ; C routine to allocate a list cell
public cons
cons proc near
; Attempt a "short circuit" allocation of a list cell
mov BX,listpage ; load current list cell allocation page no.
;;; cmp BX,END_LIST ; is allocation page specified?
;;; je cons_no
shl BX,1
mov SI,nextcell+[BX] ; load next available cell offset
cmp SI,END_LIST
je cons_no
; at this point, the allocation has succeeded
mov DX,ES ; save the caller's ES register
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell page's segment address
mov AX,ES:[SI].car ; load pointer to next available cell
mov nextcell+[BX],AX ; and update free cell chain header
; store CDR value into list cell
cons_ok: mov CX,BP ; save the caller's base pointer
mov BP,SP ; and establish addressability for args
mov DI,[BP].con_cdr ; fetch address of register containing CDR
mov AL,byte ptr [DI].C_page ; copy contents of register into
mov ES:[SI].cdr_page,AL ; the new list cell's CDR field
mov AX,[DI].C_disp
mov ES:[SI].cdr,AX
; store CAR value into list cell
mov DI,[BP].con_car ; fetch address of register containing CAR
mov AL,byte ptr [DI].C_page ; copy contents of register into
mov ES:[SI].car_page,AL ; the new list cell's CAR field
mov AX,[DI].C_disp
mov ES:[SI].car,AX
; store pointer to new list cell in destination register
mov DI,[BP].con_res ; fetch address of destination register
mov byte ptr [DI].C_page,BL
mov [DI].C_disp,SI
mov ES,DX ; restore caller's ES register
mov BP,CX ; restore caller's BP register
ret ; return to caller
; OOPS-- no list cell immediately available-- go through channels
cons_no: mov AX,offset new_disp ; push address of a dummy result
push AX ; register onto the TIPC's stack
call alloc_li ; allocate a list cell
add SP,WORDINCR ; drop argument from stack
mov BX,new_page ; fetch list cell's page number
mov SI,new_disp ; and displacement
mov DX,ES ; save the caller's ES register
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; make ES point to the new list cell
jmp cons_ok
cons endp
prog ends
end


329
sgcmark.asm Normal file
View File

@ -0,0 +1,329 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Garbage Collection - Mark Phase *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: April 1984 *
;* Last Modification: 06 January 1986 *
;***************************************
include scheme.equ
arguments struc
dw ? ; Caller's BP
dw ? ; Return address
page_idx dw ? ; Page number of pointer
pointer dw ? ; Displacement of pointer
arguments ends
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn _base:word ; base address of the TIPC runtime stack
sum_bt dw sum_list ; [0] List cells
dw sum_fix ; [1] Fixnums
dw sum_flo ; [2] Flonums
dw sum_big ; [3] Bignums
dw sum_sym ; [4] Symbols
dw sum_str ; [5] Strings
dw sum_ary ; [6] Arrays
dw sum_cont ; [7] Continuations
dw sum_clos ; [8] Closures
dw sum_free ; [9] Free page
dw sum_code ; [10] Code page
dw sum_free ; [11] (Formerly, Reference cells)
dw sum_port ; [12] Port data objects
dw sum_char ; [13] Characters
dw sum_env ; [14] Environments
; Branch table for pointer classification
branchtab dw gcmlist ; [0] List cells
dw gcmfix ; [1] Fixnums
dw gcmflo ; [2] Flonums
dw gcmbig ; [3] Bignums
dw gcmsym ; [4] Symbols
dw gcmstr ; [5] Strings
dw gcmary ; [6] Arrays
dw gcmcont ; [7] Continuations
dw gcmclos ; [8] Closures
dw gcmfree ; [9] Free page
dw gcmcode ; [10] Code page
dw gcmfree ; [11] (Formerly, Reference cells)
dw gcmport ; [12] Port data objects
dw gcmchar ; [13] Characters
dw gcmenv ; [14] Environments
m_oops db "[VM INTERNAL ERROR] sum_spac: infinite loop page %d",LF,0
m_format db "[VM INTERNAL ERROR] sgcmark: invalid pointer: %x:%04x "
db "(unadjusted)",LF,0
m_overfl db "[VM FATAL ERROR] Stack overflow during GC",LF,0
DS_addr dw DGROUP
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public garbage
garbage proc near
push ES
mov ES,DS_addr
C_call garbage1
pop ES
ret
garbage endp
mark proc near
; ***error-- bad pointer found-- report error***
gcmfix: ; Fixnums are immediates
gcmchar: ; Characters are immediates
gcmfree: ; Why are we collecting in a free page?
bad_ptr:
push AX
mov AX,offset m_format ; load address of format text
push DX ; save the return address
pushm <SI,BX,AX> ; push arguments to printf
C_call printf,,Load_ES ; print error message
add SP,WORDINCR*3 ; drop arguments from stack
C_call force_de ; go into debug mode
pop DX ; restore the return address
pop AX
jmp gcmret ; go on as if nothing happened
public gcmark
gcmark: pop DX ; unload return address
pop BX ; fetch page number (x 2)
mov AX,BX ; save in AX
pop SI ; fetch displacement
push DX ; save return address
push ES ; save ES
mov DX,offset pgroup:gcmarkret
jmp gcm_tr
gcmarkret:
pop ES
pop DX
jmp DX ; return
; see if pointer is to one of the "special" non-collected pages
gcm_tr: cmp BX,DEDPAGES*PAGEINCR ; check for non-gc'ed pages
jge gcm_go ; if not one of the special pages, jump
jmp DX ; return
;
gcm_go: push AX ; Preserve the page number
; load pointer offset into ES:; displacement into SI
test BX,0FF01h ; valid pointer?
jnz bad_ptr ; if so, error (jump)
LoadPage ES,BX
mov AX,BX ; Use AX to store page number
; classify pointer according to data type
mov DI,ptype+[BX] ; load data type*2
cmp DI,NUMTYPES*2 ; valid page type?
jae bad_ptr ; if not, error (jump)
jmp branchtab+[DI]
; Process symbol or port
gcmport:
gcmsym: markedp ES:[SI].sym_gc,gcmret ; already marked? if so, return (jump)
or byte ptr ES:[SI].sym_gc,GC_BIT ; mark symbol/port as seen
mov BL,ES:[SI].sym_page ; fetch pointer from symbol/port object
mov SI,ES:[SI].sym_disp
pop AX ; restore saved page number
LoadPage ES,AX ; Get Page address
jmp gcm_tr ; make a tail recursive call to gcmark
; Process List Cell-- If marked, skip rest of processing
gcmlist: markedp ES:[SI].list_gc,gcmret ; if marked, jump to return
; Call gcmark with CAR of list cell
or byte ptr ES:[SI].list_gc,GC_BIT ; "mark" as referenced
mov BL,ES:[SI].car_page ; load page number of car field
cmp BX,DEDPAGES*PAGEINCR ; check for non-gc'ed pages
jl gcmls_ok ; if one of the special pages, jump
; Test for TIPC stack overflow
push AX
mov AX,SP ; copy the current stack top pointer
sub AX,_base ; and compute number of bytes remaining
cmp AX,64 ; enough space to continue?
pop AX
jb stk_ovfl ; if not enough room, abort (jump)
; Mark expression pointed to by the car field
push SI ; save offset of list cell
push DX ; save the previous return address
mov DX,offset PGROUP:gcmls_rt ; Load the return address
mov SI,ES:[SI].car ; Load car field pointer
and SI,07FFFh ; Clear out the GC bit
jmp gcm_go ; Call gcmark recursively
gcmls_rt:
pop DX ; Restore previous return address
pop SI ; Restore offset of list cell
; Call gcmark tail recursively with CDR of list cell
gcmls_ok: mov BL,ES:[SI].cdr_page ; load the pointer contained in the
mov SI,ES:[SI].cdr ; cdr field
pop AX ; restore saved page
LoadPage ES,AX ; Get Page address
jmp gcm_tr ; call gcmark tail recursively
; TIPC stack overflow-- Abort
stk_ovfl: mov AX,offset m_overfl ; load address of error message text
push AX ; and push it as an argument to printf
C_call printf,,Load_ES ; print the error message
C_call getch ; wait for any key to be pressed
C_call exit ; return to MS-DOS
; Return to caller
gcmret: pop AX ; restore saved page
LoadPage ES,AX ; Get Page address
jmp DX ; return to caller
; Process reference to variable length data object or flonum
gcmflo:
gcmbig:
gcmstr:
or byte ptr ES:[SI].vec_gc,GC_BIT
pop AX ; restore saved page
LoadPage ES,AX ; Get Page address
jmp DX ; return
; Process Code Block
gcmcode: markedp ES:[SI].cod_gc,gcmret ; If already processed, return
or byte ptr ES:[SI].cod_gc,GC_BIT
mov CX,ES:[SI].cod_entr ; load entry point offset as counter
jmp gcmlop1
; Process Variable Length Object Containing Pointers
gcmary:
gcmclos:
gcmcont:
gcmenv:
markedp ES:[SI].vec_gc,gcmret ; If already processed, jump to return
or byte ptr ES:[SI].vec_gc,GC_BIT ; mark as referenced
mov CX,ES:[SI].vec_len
cmp CX,PTRSIZE ; test for zero length vector
jle gcmret ; if no elements, jump
; Test the size of the TIPC stack to insure room to continue
gcmlop1: push AX
mov AX,SP ; load the current stack top pointer
sub AX,_base ; and compute the number of bytes remaining
cmp AX,64 ; are there at least 64 bytes left?
pop AX
jb stk_ovfl ; if not enough room, abort (jump)
; Call gcmark with pointer in this object
push DX ; Save previous return address
mov DX,offset PGROUP:gcml_ret ; Load return address into DX
gcmloop: add SI,PTRSIZE ; Increment address for next pointer
push CX ; Save counter across calls
push SI ; Save curr offset into vector (or whatever)
mov BL,ES:[SI].car_page ; load next element pointer from array,
mov SI,ES:[SI].car ; closure, etc.
jmp gcm_tr ; call gcmark recursively
gcml_ret: pop SI ; Restore current offset
pop CX ; Restore iteration count
sub CX,PTRSIZE ; Decrement counter
cmp CX,PTRSIZE ; and test for completion
jg gcmloop ; Loop through all pointers in object
pop DX ; Restore previous return address
pop AX ; Restore saved page
LoadPage ES,AX ; Get Page address
jmp DX ; Return
mark endp
sum_args struc
dw ? ; caller's ES
dw ? ; caller's BP
dw ? ; return address
sum_vctr dw ? ; pointer to summation vector (for results)
sum_args ends
public sum_spac
sum_spac proc near
push BP ; save the caller's BP on entry
push ES ; save the caller's ES
mov BP,SP ; update BP
; initialize
mov DI,[BP].sum_vctr ; load address of result vector
xor BX,BX ; start with zero-th page
; top of loop-- look at next page
sum_loop: xor AX,AX ; clear the free space counter
cmp BX,DEDPAGES*PAGEINCR
jl sum_end
test attrib+[BX],NOMEMORY ; is page allocated?
jnz sum_end ; if not, skip it (branch)
cmp ptype+[BX],FREETYPE*2
je sum_free ; Ignore free pages [TC]
LoadPage ES,BX ; load current paragraph's base address
mov SI,ptype+[BX] ; load type of current page
jmp sum_bt+[SI] ; branch on page type
; add up unused list cells
sum_list: mov CX,LISTSIZE ; load size of list cell data object
sum_l1st: mov SI,nextcell+[BX] ; load list cell free storage chain header
sum_lnxt: cmp SI,END_LIST ; end of list?
je sum_end ; if so, we're through here
add AX,CX ; increment the free list cell counter
jo sum_oops ; if overflow, we're stuck in a loop
mov SI,ES:[SI].car ; follow free cell chain
jmp sum_lnxt ; keep following linked list
; add up unused variable length things
sum_big:
sum_sym:
sum_str:
sum_clos:
sum_cont:
sum_ary:
sum_code:
sum_port:
sum_env:
mov SI,0 ; initialize pointer into page
mov CX,psize+[BX] ; load size of current page
sub CX,PTRSIZE ; adjust size for page boundary check
sum_vnxt: cmp SI,CX ; through with this page?
ja sum_end ; if so, branch
mov DX,ES:[SI].vec_len ; load block length
cmp DX,0 ;;; check for small string
jge sum_010
mov DX,BLK_OVHD+PTRSIZE ;;; get the exact length
sum_010: cmp ES:[SI].vec_type,FREETYPE ; free block?
jne sum_used ; if so, branch around add
add AX,DX ; add in number of free bytes
sum_used: add SI,DX ; update pointer to next block in page
jmp sum_vnxt ; look at next block
sum_free: mov AX,psize+[BX] ; load size of free page
sum_fix:
sum_char:
sum_end: mov [DI],AX ; store number of free bytes (AX)
add DI,2 ; increment array index
add BX,2 ; increment page index
cmp BX,NUMPAGES*2 ; test for completion
jl sum_loop ; if more pages, jump
sum_ret: pop ES ; restore caller's ES
pop BP ; restore caller's BP
ret ; return to caller
; add up unused flonums
sum_flo: mov CX,FLOSIZE ; load size of flonum
jmp sum_l1st ; process assuming linked list allocation
sum_oops: shr BX,1
lea SI,m_oops
pushm <BX,SI>
mov AX,DS
mov ES,AX
C_call printf
C_call exit
sum_spac endp
prog ends
end


335
sgcsweep.asm Normal file
View File

@ -0,0 +1,335 @@
; =====> SGCSWEEP.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Garbage Collector - Sweep Phase *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: April 1984 *
;* Last Modification: 06 January 1986 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_fix_er db "[VM INTERNAL ERROR] swpage: logical page not found",LF,0
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public gcsweep
gcsweep proc near
push BP
mov BP,SP
; Initialize similar page type chain headers
push ES ; save the caller's ES register
mov AX,DS ; set ES to point to the current
mov ES,AX ; data segment
mov AX,END_LIST ; load the end of list indicator
mov CX,NUMTYPES ; load table length
mov DI,offset pagelist ; load table address
cld ; move direction = forward
rep stosw ; initialize the pagelist table
pop ES ; restore the caller's ES
; Process all except the "special" non-garbage collected pages
; mov DX,DEDPAGES-1 ;;;; mov dx,NUMPAGES
; Increment loop index, test for completion
;gcsloop: inc DX ;;;; dec dx
; cmp DX,NUMPAGES ;;;; cmp dx,DEDPAGES-1
; jl gcsl010 ;;;; ja gcsl010
mov DX,NUMPAGES
gcsloop: dec DX
cmp DX,DEDPAGES-1
ja gcsl010
pop BP
ret
gcsl010: push DX
call swpage ; "sweep" the page (GC it)
pop DX
mov BX,DX ; copy current page number
sal BX,1 ; double for use as index
test attrib+[BX],NOMEMORY ; is page frame allocated?
jnz gcsloop ; if not, skip list update
mov AX,DX ; copy current page number
mov SI,ptype+[BX] ; move current page's type to SI
xchg pagelist+[SI],AX ; pagelist[type] <- page
mov pagelink+[BX],AX ; pagelink[page] <- old pagelist[type]
jmp short gcsloop
gcsweep endp
arguments struc
page_len dw ? ; page boundary (length - fudge factor)
args_BP dw ? ; Caller's BP
dw ? ; Return address
page_no dw ?
arguments ends
; Test the current page to see if it's been allocated
public swpage
swpage proc near
push BP
sub SP,offset args_BP ; reserve local storage
mov BP,SP
push ES ; save caller's ES
mov BX,[BP].page_no
sal BX,1 ; double page number for index
test DGROUP:attrib+[BX],NOMEMORY ; allocated?
jz swp020 ; if not allocated, loop
swpfix: ; Fixnums are handled as immediates
swpchar: ; Characters are handled as immediates
swpfree: ; Why are we processing a free page?
swpref: ; Ref cells no longer exist?
swpret: pop ES
add SP,offset args_BP ; drop local storage from stack
pop BP
ret
swp020:
; Dispatch on the type of data stored in this page
mov DI,DGROUP:ptype+[BX] ; load data type for this page
cmp DI,FREETYPE*2 ; Ignore free pages [HS]
jz swpfree ; to relieve the swapper... [HS]
LoadPage ES,BX ; define base paragraph for this page[HS]
mov DI,CS:btable+[DI]
jmp DI
; Process List Cells (and other fixed length pointer objects)
swplist: mov AX,LISTSIZE
swpl010: xor SI,SI ; SI <- 0
xor DI,DI ; zero referenced cell counter
mov CX,END_LIST ; load end of list marker
mov DX,-1 ; marker for unused cell header
push BX ; save page number index
mov BX,psize+[BX] ; load page length and
sub BX,AX ; adjust for boundary check
swpl020: markedp ES:[SI].list_gc,swpl030 ; branch, if marked
; add cell to free list
mov ES:[SI].car,CX
mov ES:[SI].car_page,DL ; make page=FF for unused cell
mov CX,SI
jmp short swpl040
; clear GC bit
swpl030: and byte ptr ES:[SI].list_gc,NOT_GC_BI ; clear GC "marked" bit
inc DI ; increment referenced cell counter
; increment cell pointer and test for end of page
swpl040: add SI,AX
cmp SI,BX ; test for end of page
jbe swpl020
; end of page-- update free list header and process next page
pop BX ; restore page table index
mov DGROUP:nextcell+[BX],CX
cmp DI,0 ; any referenced cells in this page?
jne swpret ; if ref'd cells in page, branch
mov ptype+[BX],FREETYPE*2 ; mark empty page as free
mov attrib+[BX],0
jmp short swpret
; Process Page of Flonums
swpflo: mov AX,FLOSIZE ; load size of a single flonum
xor SI,SI ; SI <- 0
xor DI,DI ; zero referenced cell counter
mov CX,END_LIST ; load end of list marker
mov DX,-1 ; marker for unused cell header
push BX ; save page number index
mov BX,psize+[BX] ; load page length and
sub BX,AX ; adjust for boundary check
swpf020: cmp ES:[SI].flo_type,DL ; tag = free?
je swpf025 ; if a non-allocated cell, jump
markedp ES:[SI].flo_gc,swpf030 ; branch, if marked
; add flonum to free list
mov ES:[SI].car_page,DL ; make page=FF for unused cell
swpf025: mov ES:[SI].car,CX
mov CX,SI
jmp short swpf040
; clear GC bit
swpf030: and byte ptr ES:[SI].flo_gc,NOT_GC_BI ; clear GC "marked" bit
inc DI ; increment referenced cell counter
; increment cell pointer and test for end of page
swpf040: add SI,AX
cmp SI,BX ; test for end of page
jbe swpf020
; end of page-- update free list header and process next page
pop BX ; restore page table index
mov DGROUP:nextcell+[BX],CX
cmp DI,0 ; any referenced cells in this page?
jne swpf050 ; if ref'd cells in page, branch
mov ptype+[BX],FREETYPE*2 ; mark empty page as free
mov attrib+[BX],0
swpf050: jmp swpret
; Process variable length data object
swpbig:
swpsym:
swpstr:
swpary:
swpclos:
swpcont:
swpcode:
swpenv:
xor SI,SI
mov DI,-1
push BX ; save page table index
mov BX,psize+[BX] ; load size of current page and
sub BX,PTRSIZE ; adjust for boundary check
swpvloop: mov DX,ES:[SI].vec_len ; load length of current object
cmp DX,0
jge swp001
mov DX,BLK_OVHD+PTRSIZE
swp001: markedp ES:[SI].vec_gc,swpv020 ; branch if object referenced
; Object not referenced-- can we combine with previous free area?
cmp DI,0
jge swpv010 ; If prev obj free, branch
; Object not referenced, but previous area was
mov ES:[SI].vec_type,FREETYPE ; Mark this object as free
cmp ES:[SI].vec_len,0
jge swp002
mov ES:[SI].vec_len,BLK_OVHD+PTRSIZE
swp002: mov DI,SI ; Record this fact for next iteration
jmp short swpvnxt
; Object was not referenced and can be combined with prev free area
swpv010: add ES:[DI].vec_len,DX ; add length into previous free obj
jmp short swpvnxt
; Object was referenced
swpv020: and ES:[SI].vec_gc,NOT_GC_BI ; clear gc bit
mov DI,-1 ; Remember last object was referenced
; Processing of current object finished-- add length and iterate
swpvnxt: add SI,DX ; Increment area pointer by block length
cmp SI,BX ; Last object in block?
jb swpvloop ; Branch, if more space
; Processing of this page finished-- update next free area pointer
swppfin: pop BX ; Restore page table index
cmp DI,-1
je swpv030 ; If last block not free, skip it
sub SI,psize+[BX] ; Adjust in case last byte of page
neg SI ; not accounted for
add ES:[DI].vec_len,SI
mov nextcell+[BX],DI ; Update free pool header
cmp DI,0 ; is page empty?
jne swpv040 ; if not, jump
mov ptype+[BX],FREETYPE*2 ; mark page as being free
mov attrib+[BX],0
mov AX,psize+[BX]
cmp AX,PAGESIZE ; is page larger than default page size?
ja fix_big ; if a "large" page, must fix memory tables
jmp swpret
swpv030: mov nextcell+[BX],END_LIST ; Indicate no free pool
swpv040: jmp swpret
; Process page of ports-- close any open files before salvaging memory
swpport:
xor SI,SI
mov DI,-1
push BX ; save page table index
mov BX,psize+[BX] ; load size of current page and
sub BX,PTRSIZE ; adjust for boundary check
swpploop: mov DX,ES:[SI].pt_len ; load length of current object
markedp ES:[SI].port_gc,swpp020 ; branch if object referenced
cmp ES:[SI].pt_type,FREETYPE
je not_file
; Object not referenced-- is it an open file?
test ES:[SI].pt_pflgs,WINDOW+STRIO
; is this a file or a window?
jnz not_file ; if a window, don't bother with close (jump)
test ES:[SI].pt_pflgs,OPEN ; is file opened?
jz not_open ; if not open, skip close (jump)
; Close the file
push BX ; save BX across call
mov BX,ES:[SI].pt_handl ; load handle
push BX ; and push as argument
extrn zclose:near
call zclose
pop BX ; drop argument off stack
pop BX ; restore register BX
not_file:
not_open:
; Object not referenced-- can we combine with previous free area?
cmp DI,0
jge swpp010 ; If prev obj free, branch
; Object not referenced, but previous area was
mov ES:[SI].pt_type,FREETYPE ; Mark this object as free